diff --git a/include/common.fypp b/include/common.fypp index ed1cf2b4e..0d861aead 100644 --- a/include/common.fypp +++ b/include/common.fypp @@ -60,6 +60,19 @@ #:set CMPLX_INIT = CMPLX_INIT + ["w"] #:endif +#! BLAS/LAPACK complex->real kind initial conversion +#! Converts a BLAS/LAPACK complex kind initial to a real kind initial +#! +#! Args: +#! ci (character): Complex kind initial in ["c","z","y","w"] +#! +#! Returns: +#! Real kind initial in ["s","d","x","q"] or an empty string on invalid input +#! +#:def c2ri(cmplx) +$:"s" if cmplx=="c" else "d" if cmplx=="z" else "x" if cmplx=="y" else "q" if cmplx=="w" else "ERROR" +#:enddef + #! Complex types to be considered during templating #:set CMPLX_TYPES = ["complex({})".format(k) for k in CMPLX_KINDS] diff --git a/src/stdlib_linalg.fypp b/src/stdlib_linalg.fypp index 10cd16650..0dfbba5dd 100644 --- a/src/stdlib_linalg.fypp +++ b/src/stdlib_linalg.fypp @@ -251,11 +251,9 @@ module stdlib_linalg !! or several (from a 2-d right-hand-side vector `b(:,:)`) systems. !! !!@note The solution is based on LAPACK's generic LU decomposition based solvers `*GESV`. - !!@note BLAS/LAPACK backends do not currently support extended precision (``xdp``). !! #:for nd,ndsuf,nde in ALL_RHS #:for rk,rt,ri in RC_KINDS_TYPES - #:if rk!="xdp" module function stdlib_linalg_${ri}$_solve_${ndsuf}$(a,b,overwrite_a,err) result(x) !> Input matrix a[n,n] ${rt}$, intent(inout), target :: a(:,:) @@ -276,7 +274,6 @@ module stdlib_linalg !> Result array/matrix x[n] or x[n,nrhs] ${rt}$, allocatable, target :: x${nd}$ end function stdlib_linalg_${ri}$_pure_solve_${ndsuf}$ - #:endif #:endfor #:endfor end interface solve @@ -302,11 +299,9 @@ module stdlib_linalg !! or several (from a 2-d right-hand-side vector `b(:,:)`) systems. !! !!@note The solution is based on LAPACK's generic LU decomposition based solvers `*GESV`. - !!@note BLAS/LAPACK backends do not currently support extended precision (``xdp``). !! #:for nd,ndsuf,nde in ALL_RHS #:for rk,rt,ri in RC_KINDS_TYPES - #:if rk!="xdp" pure module subroutine stdlib_linalg_${ri}$_solve_lu_${ndsuf}$(a,b,x,pivot,overwrite_a,err) !> Input matrix a[n,n] ${rt}$, intent(inout), target :: a(:,:) @@ -321,7 +316,6 @@ module stdlib_linalg !> [optional] state return flag. On error if not requested, the code will stop type(linalg_state_type), optional, intent(out) :: err end subroutine stdlib_linalg_${ri}$_solve_lu_${ndsuf}$ - #:endif #:endfor #:endfor end interface solve_lu @@ -342,11 +336,9 @@ module stdlib_linalg !! Supported data types include `real` and `complex`. !! !!@note The solution is based on LAPACK's singular value decomposition `*GELSD` methods. - !!@note BLAS/LAPACK backends do not currently support extended precision (``xdp``). !! #:for nd,ndsuf,nde in ALL_RHS #:for rk,rt,ri in RC_KINDS_TYPES - #:if rk!="xdp" module function stdlib_linalg_${ri}$_lstsq_${ndsuf}$(a,b,cond,overwrite_a,rank,err) result(x) !> Input matrix a[n,n] ${rt}$, intent(inout), target :: a(:,:) @@ -363,7 +355,6 @@ module stdlib_linalg !> Result array/matrix x[n] or x[n,nrhs] ${rt}$, allocatable, target :: x${nd}$ end function stdlib_linalg_${ri}$_lstsq_${ndsuf}$ - #:endif #:endfor #:endfor end interface lstsq @@ -385,11 +376,9 @@ module stdlib_linalg !! are provided, no internal memory allocations take place when using this interface. !! !!@note The solution is based on LAPACK's singular value decomposition `*GELSD` methods. - !!@note BLAS/LAPACK backends do not currently support extended precision (``xdp``). !! #:for nd,ndsuf,nde in ALL_RHS #:for rk,rt,ri in RC_KINDS_TYPES - #:if rk!="xdp" module subroutine stdlib_linalg_${ri}$_solve_lstsq_${ndsuf}$(a,b,x,real_storage,int_storage,& #{if rt.startswith('c')}#cmpl_storage,#{endif}#cond,singvals,overwrite_a,rank,err) !> Input matrix a[n,n] @@ -417,7 +406,6 @@ module stdlib_linalg !> [optional] state return flag. On error if not requested, the code will stop type(linalg_state_type), optional, intent(out) :: err end subroutine stdlib_linalg_${ri}$_solve_lstsq_${ndsuf}$ - #:endif #:endfor #:endfor end interface solve_lstsq @@ -438,7 +426,6 @@ module stdlib_linalg !! #:for nd,ndsuf,nde in ALL_RHS #:for rk,rt,ri in RC_KINDS_TYPES - #:if rk!="xdp" pure module subroutine stdlib_linalg_${ri}$_lstsq_space_${ndsuf}$(a,b,lrwork,liwork#{if rt.startswith('c')}#,lcwork#{endif}#) !> Input matrix a[m,n] ${rt}$, intent(in), target :: a(:,:) @@ -447,7 +434,6 @@ module stdlib_linalg !> Size of the working space arrays integer(ilp), intent(out) :: lrwork,liwork#{if rt.startswith('c')}#,lcwork#{endif}# end subroutine stdlib_linalg_${ri}$_lstsq_space_${ndsuf}$ - #:endif #:endfor #:endfor end interface lstsq_space @@ -573,7 +559,6 @@ module stdlib_linalg !! It is possible to use partial storage [m,k] and [k,n], `k=min(m,n)`, choosing `full_matrices=.false.`. !! !!@note The solution is based on LAPACK's singular value decomposition `*GESDD` methods. - !!@note BLAS/LAPACK backends do not currently support extended precision (``xdp``). !! !!### Example !! @@ -586,7 +571,6 @@ module stdlib_linalg !!``` !! #:for rk,rt,ri in RC_KINDS_TYPES - #:if rk!="xdp" module subroutine stdlib_linalg_svd_${ri}$(a,s,u,vt,overwrite_a,full_matrices,err) !!### Summary !! Compute singular value decomposition of a matrix \( A = U \cdot S \cdot \V^T \) @@ -622,7 +606,6 @@ module stdlib_linalg !> [optional] state return flag. On error if not requested, the code will stop type(linalg_state_type), optional, intent(out) :: err end subroutine stdlib_linalg_svd_${ri}$ - #:endif #:endfor end interface svd @@ -645,7 +628,6 @@ module stdlib_linalg !! singular values, with size [min(m,n)]. !! !!@note The solution is based on LAPACK's singular value decomposition `*GESDD` methods. - !!@note BLAS/LAPACK backends do not currently support extended precision (``xdp``). !! !!### Example !! @@ -658,7 +640,6 @@ module stdlib_linalg !!``` !! #:for rk,rt,ri in RC_KINDS_TYPES - #:if rk!="xdp" module function stdlib_linalg_svdvals_${ri}$(a,err) result(s) !!### Summary !! Compute singular values \(S \) from the singular-value decomposition of a matrix \( A = U \cdot S \cdot \V^T \). @@ -682,7 +663,6 @@ module stdlib_linalg !> Array of singular values real(${rk}$), allocatable :: s(:) end function stdlib_linalg_svdvals_${ri}$ - #:endif #:endfor end interface svdvals diff --git a/src/stdlib_linalg_blas.fypp b/src/stdlib_linalg_blas.fypp index e1bd5b76e..504a15108 100644 --- a/src/stdlib_linalg_blas.fypp +++ b/src/stdlib_linalg_blas.fypp @@ -1,17 +1,11 @@ -#:include "common.fypp" +#:include "common.fypp" +#:set RC_KINDS_TYPES = REAL_KINDS_TYPES + CMPLX_KINDS_TYPES module stdlib_linalg_blas use stdlib_linalg_constants use stdlib_linalg_blas_aux - use stdlib_linalg_blas_s - use stdlib_linalg_blas_d -#:if WITH_QP - use stdlib_linalg_blas_q -#:endif - use stdlib_linalg_blas_c - use stdlib_linalg_blas_z -#:if WITH_QP - use stdlib_linalg_blas_w -#:endif + #:for rk,rt,ri in RC_KINDS_TYPES + use stdlib_linalg_blas_${ri}$ + #:endfor implicit none(type,external) public @@ -39,9 +33,12 @@ module stdlib_linalg_blas #else module procedure stdlib_daxpy #endif -#:if WITH_QP - module procedure stdlib_qaxpy +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$axpy + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_BLAS pure subroutine saxpy(n,sa,sx,incx,sy,incy) import sp,dp,qp,ilp,lk @@ -53,9 +50,12 @@ module stdlib_linalg_blas #else module procedure stdlib_saxpy #endif -#:if WITH_QP - module procedure stdlib_waxpy +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$axpy + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_BLAS pure subroutine zaxpy(n,za,zx,incx,zy,incy) import sp,dp,qp,ilp,lk @@ -95,9 +95,12 @@ module stdlib_linalg_blas #else module procedure stdlib_dcopy #endif -#:if WITH_QP - module procedure stdlib_qcopy +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$copy + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_BLAS pure subroutine scopy(n,sx,incx,sy,incy) import sp,dp,qp,ilp,lk @@ -109,9 +112,12 @@ module stdlib_linalg_blas #else module procedure stdlib_scopy #endif -#:if WITH_QP - module procedure stdlib_wcopy +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$copy + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_BLAS pure subroutine zcopy(n,zx,incx,zy,incy) import sp,dp,qp,ilp,lk @@ -140,9 +146,12 @@ module stdlib_linalg_blas #else module procedure stdlib_ddot #endif -#:if WITH_QP - module procedure stdlib_qdot +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$dot + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_BLAS pure real(sp) function sdot(n,sx,incx,sy,incy) import sp,dp,qp,ilp,lk @@ -170,9 +179,12 @@ module stdlib_linalg_blas #else module procedure stdlib_cdotc #endif -#:if WITH_QP - module procedure stdlib_wdotc +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$dotc + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_BLAS pure complex(dp) function zdotc(n,zx,incx,zy,incy) import sp,dp,qp,ilp,lk @@ -200,9 +212,12 @@ module stdlib_linalg_blas #else module procedure stdlib_cdotu #endif -#:if WITH_QP - module procedure stdlib_wdotu +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$dotu + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_BLAS pure complex(dp) function zdotu(n,zx,incx,zy,incy) import sp,dp,qp,ilp,lk @@ -247,9 +262,12 @@ module stdlib_linalg_blas #else module procedure stdlib_dgbmv #endif -#:if WITH_QP - module procedure stdlib_qgbmv +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$gbmv + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_BLAS pure subroutine sgbmv(trans,m,n,kl,ku,alpha,a,lda,x,incx,beta,y,incy) import sp,dp,qp,ilp,lk @@ -262,9 +280,12 @@ module stdlib_linalg_blas #else module procedure stdlib_sgbmv #endif -#:if WITH_QP - module procedure stdlib_wgbmv +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$gbmv + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_BLAS pure subroutine zgbmv(trans,m,n,kl,ku,alpha,a,lda,x,incx,beta,y,incy) import sp,dp,qp,ilp,lk @@ -312,9 +333,12 @@ module stdlib_linalg_blas #else module procedure stdlib_dgemm #endif -#:if WITH_QP - module procedure stdlib_qgemm +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$gemm + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_BLAS pure subroutine sgemm(transa,transb,m,n,k,alpha,a,lda,b,ldb,beta,c,ldc) import sp,dp,qp,ilp,lk @@ -327,9 +351,12 @@ module stdlib_linalg_blas #else module procedure stdlib_sgemm #endif -#:if WITH_QP - module procedure stdlib_wgemm +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$gemm + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_BLAS pure subroutine zgemm(transa,transb,m,n,k,alpha,a,lda,b,ldb,beta,c,ldc) import sp,dp,qp,ilp,lk @@ -376,9 +403,12 @@ module stdlib_linalg_blas #else module procedure stdlib_dgemv #endif -#:if WITH_QP - module procedure stdlib_qgemv +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$gemv + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_BLAS pure subroutine sgemv(trans,m,n,alpha,a,lda,x,incx,beta,y,incy) import sp,dp,qp,ilp,lk @@ -391,9 +421,12 @@ module stdlib_linalg_blas #else module procedure stdlib_sgemv #endif -#:if WITH_QP - module procedure stdlib_wgemv +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$gemv + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_BLAS pure subroutine zgemv(trans,m,n,alpha,a,lda,x,incx,beta,y,incy) import sp,dp,qp,ilp,lk @@ -426,9 +459,12 @@ module stdlib_linalg_blas #else module procedure stdlib_dger #endif -#:if WITH_QP - module procedure stdlib_qger +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$ger + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_BLAS pure subroutine sger(m,n,alpha,x,incx,y,incy,a,lda) import sp,dp,qp,ilp,lk @@ -460,9 +496,12 @@ module stdlib_linalg_blas #else module procedure stdlib_cgerc #endif -#:if WITH_QP - module procedure stdlib_wgerc +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$gerc + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_BLAS pure subroutine zgerc(m,n,alpha,x,incx,y,incy,a,lda) import sp,dp,qp,ilp,lk @@ -494,9 +533,12 @@ module stdlib_linalg_blas #else module procedure stdlib_cgeru #endif -#:if WITH_QP - module procedure stdlib_wgeru +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$geru + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_BLAS pure subroutine zgeru(m,n,alpha,x,incx,y,incy,a,lda) import sp,dp,qp,ilp,lk @@ -529,9 +571,12 @@ module stdlib_linalg_blas #else module procedure stdlib_chbmv #endif -#:if WITH_QP - module procedure stdlib_whbmv +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$hbmv + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_BLAS pure subroutine zhbmv(uplo,n,k,alpha,a,lda,x,incx,beta,y,incy) import sp,dp,qp,ilp,lk @@ -567,9 +612,12 @@ module stdlib_linalg_blas #else module procedure stdlib_chemm #endif -#:if WITH_QP - module procedure stdlib_whemm +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$hemm + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_BLAS pure subroutine zhemm(side,uplo,m,n,alpha,a,lda,b,ldb,beta,c,ldc) import sp,dp,qp,ilp,lk @@ -603,9 +651,12 @@ module stdlib_linalg_blas #else module procedure stdlib_chemv #endif -#:if WITH_QP - module procedure stdlib_whemv +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$hemv + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_BLAS pure subroutine zhemv(uplo,n,alpha,a,lda,x,incx,beta,y,incy) import sp,dp,qp,ilp,lk @@ -640,9 +691,12 @@ module stdlib_linalg_blas #else module procedure stdlib_cher #endif -#:if WITH_QP - module procedure stdlib_wher +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$her + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_BLAS pure subroutine zher(uplo,n,alpha,x,incx,a,lda) import sp,dp,qp,ilp,lk @@ -677,9 +731,12 @@ module stdlib_linalg_blas #else module procedure stdlib_cher2 #endif -#:if WITH_QP - module procedure stdlib_wher2 +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$her2 + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_BLAS pure subroutine zher2(uplo,n,alpha,x,incx,y,incy,a,lda) import sp,dp,qp,ilp,lk @@ -717,9 +774,12 @@ module stdlib_linalg_blas #else module procedure stdlib_cher2k #endif -#:if WITH_QP - module procedure stdlib_wher2k +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$her2k + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_BLAS pure subroutine zher2k(uplo,trans,n,k,alpha,a,lda,b,ldb,beta,c,ldc) import sp,dp,qp,ilp,lk @@ -758,9 +818,12 @@ module stdlib_linalg_blas #else module procedure stdlib_cherk #endif -#:if WITH_QP - module procedure stdlib_wherk +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$herk + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_BLAS pure subroutine zherk(uplo,trans,n,k,alpha,a,lda,beta,c,ldc) import sp,dp,qp,ilp,lk @@ -795,9 +858,12 @@ module stdlib_linalg_blas #else module procedure stdlib_chpmv #endif -#:if WITH_QP - module procedure stdlib_whpmv +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$hpmv + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_BLAS pure subroutine zhpmv(uplo,n,alpha,ap,x,incx,beta,y,incy) import sp,dp,qp,ilp,lk @@ -832,9 +898,12 @@ module stdlib_linalg_blas #else module procedure stdlib_chpr #endif -#:if WITH_QP - module procedure stdlib_whpr +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$hpr + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_BLAS pure subroutine zhpr(uplo,n,alpha,x,incx,ap) import sp,dp,qp,ilp,lk @@ -869,9 +938,12 @@ module stdlib_linalg_blas #else module procedure stdlib_chpr2 #endif -#:if WITH_QP - module procedure stdlib_whpr2 +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$hpr2 + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_BLAS pure subroutine zhpr2(uplo,n,alpha,x,incx,y,incy,ap) import sp,dp,qp,ilp,lk @@ -902,9 +974,12 @@ module stdlib_linalg_blas #else module procedure stdlib_dnrm2 #endif -#:if WITH_QP - module procedure stdlib_qnrm2 +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$nrm2 + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_BLAS pure real(sp) function snrm2( n, x, incx ) import sp,dp,qp,ilp,lk @@ -932,9 +1007,12 @@ module stdlib_linalg_blas #else module procedure stdlib_drot #endif -#:if WITH_QP - module procedure stdlib_qrot +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$rot + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_BLAS pure subroutine srot(n,sx,incx,sy,incy,c,s) import sp,dp,qp,ilp,lk @@ -986,9 +1064,12 @@ module stdlib_linalg_blas #else module procedure stdlib_drotg #endif -#:if WITH_QP - module procedure stdlib_qrotg +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$rotg + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_BLAS pure subroutine srotg( a, b, c, s ) import sp,dp,qp,ilp,lk @@ -999,9 +1080,12 @@ module stdlib_linalg_blas #else module procedure stdlib_srotg #endif -#:if WITH_QP - module procedure stdlib_wrotg +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$rotg + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_BLAS pure subroutine zrotg( a, b, c, s ) import sp,dp,qp,ilp,lk @@ -1041,9 +1125,12 @@ module stdlib_linalg_blas #else module procedure stdlib_drotm #endif -#:if WITH_QP - module procedure stdlib_qrotm +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$rotm + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_BLAS pure subroutine srotm(n,sx,incx,sy,incy,sparam) import sp,dp,qp,ilp,lk @@ -1083,9 +1170,12 @@ module stdlib_linalg_blas #else module procedure stdlib_drotmg #endif -#:if WITH_QP - module procedure stdlib_qrotmg +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$rotmg + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_BLAS pure subroutine srotmg(sd1,sd2,sx1,sy1,sparam) import sp,dp,qp,ilp,lk @@ -1118,9 +1208,12 @@ module stdlib_linalg_blas #else module procedure stdlib_dsbmv #endif -#:if WITH_QP - module procedure stdlib_qsbmv +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$sbmv + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_BLAS pure subroutine ssbmv(uplo,n,k,alpha,a,lda,x,incx,beta,y,incy) import sp,dp,qp,ilp,lk @@ -1161,9 +1254,12 @@ module stdlib_linalg_blas #else module procedure stdlib_dscal #endif -#:if WITH_QP - module procedure stdlib_qscal +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$scal + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_BLAS pure subroutine sscal(n,sa,sx,incx) import sp,dp,qp,ilp,lk @@ -1175,9 +1271,12 @@ module stdlib_linalg_blas #else module procedure stdlib_sscal #endif -#:if WITH_QP - module procedure stdlib_wscal +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$scal + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_BLAS pure subroutine zscal(n,za,zx,incx) import sp,dp,qp,ilp,lk @@ -1210,8 +1309,15 @@ module stdlib_linalg_blas #else module procedure stdlib_dsdot #endif + #:if WITH_QP + !! Provide a unique interface to accumulate double precision reals + !! into the highest available precision. module procedure stdlib_qsdot +#:elif WITH_XDP + !! Provide a unique interface to accumulate double precision reals + !! into the highest available precision. + module procedure stdlib_xsdot #:endif end interface sdot @@ -1234,9 +1340,12 @@ module stdlib_linalg_blas #else module procedure stdlib_dspmv #endif -#:if WITH_QP - module procedure stdlib_qspmv +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$spmv + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_BLAS pure subroutine sspmv(uplo,n,alpha,ap,x,incx,beta,y,incy) import sp,dp,qp,ilp,lk @@ -1270,9 +1379,12 @@ module stdlib_linalg_blas #else module procedure stdlib_dspr #endif -#:if WITH_QP - module procedure stdlib_qspr +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$spr + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_BLAS pure subroutine sspr(uplo,n,alpha,x,incx,ap) import sp,dp,qp,ilp,lk @@ -1306,9 +1418,12 @@ module stdlib_linalg_blas #else module procedure stdlib_dspr2 #endif -#:if WITH_QP - module procedure stdlib_qspr2 +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$spr2 + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_BLAS pure subroutine sspr2(uplo,n,alpha,x,incx,y,incy,ap) import sp,dp,qp,ilp,lk @@ -1383,9 +1498,12 @@ module stdlib_linalg_blas #else module procedure stdlib_dswap #endif -#:if WITH_QP - module procedure stdlib_qswap +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$swap + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_BLAS pure subroutine sswap(n,sx,incx,sy,incy) import sp,dp,qp,ilp,lk @@ -1396,9 +1514,12 @@ module stdlib_linalg_blas #else module procedure stdlib_sswap #endif -#:if WITH_QP - module procedure stdlib_wswap +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$swap + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_BLAS pure subroutine zswap(n,zx,incx,zy,incy) import sp,dp,qp,ilp,lk @@ -1444,9 +1565,12 @@ module stdlib_linalg_blas #else module procedure stdlib_dsymm #endif -#:if WITH_QP - module procedure stdlib_qsymm +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$symm + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_BLAS pure subroutine ssymm(side,uplo,m,n,alpha,a,lda,b,ldb,beta,c,ldc) import sp,dp,qp,ilp,lk @@ -1459,9 +1583,12 @@ module stdlib_linalg_blas #else module procedure stdlib_ssymm #endif -#:if WITH_QP - module procedure stdlib_wsymm +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$symm + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_BLAS pure subroutine zsymm(side,uplo,m,n,alpha,a,lda,b,ldb,beta,c,ldc) import sp,dp,qp,ilp,lk @@ -1495,9 +1622,12 @@ module stdlib_linalg_blas #else module procedure stdlib_dsymv #endif -#:if WITH_QP - module procedure stdlib_qsymv +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$symv + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_BLAS pure subroutine ssymv(uplo,n,alpha,a,lda,x,incx,beta,y,incy) import sp,dp,qp,ilp,lk @@ -1531,9 +1661,12 @@ module stdlib_linalg_blas #else module procedure stdlib_dsyr #endif -#:if WITH_QP - module procedure stdlib_qsyr +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$syr + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_BLAS pure subroutine ssyr(uplo,n,alpha,x,incx,a,lda) import sp,dp,qp,ilp,lk @@ -1567,9 +1700,12 @@ module stdlib_linalg_blas #else module procedure stdlib_dsyr2 #endif -#:if WITH_QP - module procedure stdlib_qsyr2 +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$syr2 + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_BLAS pure subroutine ssyr2(uplo,n,alpha,x,incx,y,incy,a,lda) import sp,dp,qp,ilp,lk @@ -1618,9 +1754,12 @@ module stdlib_linalg_blas #else module procedure stdlib_dsyr2k #endif -#:if WITH_QP - module procedure stdlib_qsyr2k +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$syr2k + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_BLAS pure subroutine ssyr2k(uplo,trans,n,k,alpha,a,lda,b,ldb,beta,c,ldc) import sp,dp,qp,ilp,lk @@ -1633,9 +1772,12 @@ module stdlib_linalg_blas #else module procedure stdlib_ssyr2k #endif -#:if WITH_QP - module procedure stdlib_wsyr2k +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$syr2k + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_BLAS pure subroutine zsyr2k(uplo,trans,n,k,alpha,a,lda,b,ldb,beta,c,ldc) import sp,dp,qp,ilp,lk @@ -1684,9 +1826,12 @@ module stdlib_linalg_blas #else module procedure stdlib_dsyrk #endif -#:if WITH_QP - module procedure stdlib_qsyrk +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$syrk + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_BLAS pure subroutine ssyrk(uplo,trans,n,k,alpha,a,lda,beta,c,ldc) import sp,dp,qp,ilp,lk @@ -1699,9 +1844,12 @@ module stdlib_linalg_blas #else module procedure stdlib_ssyrk #endif -#:if WITH_QP - module procedure stdlib_wsyrk +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$syrk + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_BLAS pure subroutine zsyrk(uplo,trans,n,k,alpha,a,lda,beta,c,ldc) import sp,dp,qp,ilp,lk @@ -1747,9 +1895,12 @@ module stdlib_linalg_blas #else module procedure stdlib_dtbmv #endif -#:if WITH_QP - module procedure stdlib_qtbmv +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$tbmv + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_BLAS pure subroutine stbmv(uplo,trans,diag,n,k,a,lda,x,incx) import sp,dp,qp,ilp,lk @@ -1762,9 +1913,12 @@ module stdlib_linalg_blas #else module procedure stdlib_stbmv #endif -#:if WITH_QP - module procedure stdlib_wtbmv +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$tbmv + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_BLAS pure subroutine ztbmv(uplo,trans,diag,n,k,a,lda,x,incx) import sp,dp,qp,ilp,lk @@ -1813,9 +1967,12 @@ module stdlib_linalg_blas #else module procedure stdlib_dtbsv #endif -#:if WITH_QP - module procedure stdlib_qtbsv +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$tbsv + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_BLAS pure subroutine stbsv(uplo,trans,diag,n,k,a,lda,x,incx) import sp,dp,qp,ilp,lk @@ -1828,9 +1985,12 @@ module stdlib_linalg_blas #else module procedure stdlib_stbsv #endif -#:if WITH_QP - module procedure stdlib_wtbsv +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$tbsv + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_BLAS pure subroutine ztbsv(uplo,trans,diag,n,k,a,lda,x,incx) import sp,dp,qp,ilp,lk @@ -1876,9 +2036,12 @@ module stdlib_linalg_blas #else module procedure stdlib_dtpmv #endif -#:if WITH_QP - module procedure stdlib_qtpmv +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$tpmv + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_BLAS pure subroutine stpmv(uplo,trans,diag,n,ap,x,incx) import sp,dp,qp,ilp,lk @@ -1891,9 +2054,12 @@ module stdlib_linalg_blas #else module procedure stdlib_stpmv #endif -#:if WITH_QP - module procedure stdlib_wtpmv +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$tpmv + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_BLAS pure subroutine ztpmv(uplo,trans,diag,n,ap,x,incx) import sp,dp,qp,ilp,lk @@ -1941,9 +2107,12 @@ module stdlib_linalg_blas #else module procedure stdlib_dtpsv #endif -#:if WITH_QP - module procedure stdlib_qtpsv +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$tpsv + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_BLAS pure subroutine stpsv(uplo,trans,diag,n,ap,x,incx) import sp,dp,qp,ilp,lk @@ -1956,9 +2125,12 @@ module stdlib_linalg_blas #else module procedure stdlib_stpsv #endif -#:if WITH_QP - module procedure stdlib_wtpsv +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$tpsv + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_BLAS pure subroutine ztpsv(uplo,trans,diag,n,ap,x,incx) import sp,dp,qp,ilp,lk @@ -2005,9 +2177,12 @@ module stdlib_linalg_blas #else module procedure stdlib_dtrmm #endif -#:if WITH_QP - module procedure stdlib_qtrmm +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$trmm + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_BLAS pure subroutine strmm(side,uplo,transa,diag,m,n,alpha,a,lda,b,ldb) import sp,dp,qp,ilp,lk @@ -2020,9 +2195,12 @@ module stdlib_linalg_blas #else module procedure stdlib_strmm #endif -#:if WITH_QP - module procedure stdlib_wtrmm +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$trmm + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_BLAS pure subroutine ztrmm(side,uplo,transa,diag,m,n,alpha,a,lda,b,ldb) import sp,dp,qp,ilp,lk @@ -2068,9 +2246,12 @@ module stdlib_linalg_blas #else module procedure stdlib_dtrmv #endif -#:if WITH_QP - module procedure stdlib_qtrmv +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$trmv + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_BLAS pure subroutine strmv(uplo,trans,diag,n,a,lda,x,incx) import sp,dp,qp,ilp,lk @@ -2083,9 +2264,12 @@ module stdlib_linalg_blas #else module procedure stdlib_strmv #endif -#:if WITH_QP - module procedure stdlib_wtrmv +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$trmv + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_BLAS pure subroutine ztrmv(uplo,trans,diag,n,a,lda,x,incx) import sp,dp,qp,ilp,lk @@ -2133,9 +2317,12 @@ module stdlib_linalg_blas #else module procedure stdlib_dtrsm #endif -#:if WITH_QP - module procedure stdlib_qtrsm +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$trsm + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_BLAS pure subroutine strsm(side,uplo,transa,diag,m,n,alpha,a,lda,b,ldb) import sp,dp,qp,ilp,lk @@ -2148,9 +2335,12 @@ module stdlib_linalg_blas #else module procedure stdlib_strsm #endif -#:if WITH_QP - module procedure stdlib_wtrsm +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$trsm + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_BLAS pure subroutine ztrsm(side,uplo,transa,diag,m,n,alpha,a,lda,b,ldb) import sp,dp,qp,ilp,lk @@ -2198,9 +2388,12 @@ module stdlib_linalg_blas #else module procedure stdlib_dtrsv #endif -#:if WITH_QP - module procedure stdlib_qtrsv +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$trsv + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_BLAS pure subroutine strsv(uplo,trans,diag,n,a,lda,x,incx) import sp,dp,qp,ilp,lk @@ -2213,9 +2406,12 @@ module stdlib_linalg_blas #else module procedure stdlib_strsv #endif -#:if WITH_QP - module procedure stdlib_wtrsv +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$trsv + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_BLAS pure subroutine ztrsv(uplo,trans,diag,n,a,lda,x,incx) import sp,dp,qp,ilp,lk diff --git a/src/stdlib_linalg_blas_aux.fypp b/src/stdlib_linalg_blas_aux.fypp index 10ce0e7cd..84b2ebdec 100644 --- a/src/stdlib_linalg_blas_aux.fypp +++ b/src/stdlib_linalg_blas_aux.fypp @@ -1,4 +1,5 @@ #:include "common.fypp" +#:set RC_KINDS_TYPES = REAL_KINDS_TYPES + CMPLX_KINDS_TYPES module stdlib_linalg_blas_aux use stdlib_linalg_constants implicit none(type,external) @@ -6,133 +7,40 @@ module stdlib_linalg_blas_aux public :: sp,dp,qp,lk,ilp - public :: stdlib_dcabs1 - public :: stdlib_icamax - public :: stdlib_idamax - public :: stdlib_isamax - public :: stdlib_izamax + public :: stdlib_cabs1 + #:for rk,rt,ri in RC_KINDS_TYPES + public :: stdlib_i${ri}$amax + #:endfor public :: stdlib_lsame - public :: stdlib_scabs1 public :: stdlib_xerbla public :: stdlib_xerbla_array -#:if WITH_QP - public :: stdlib_qcabs1 -#:endif -#:if WITH_QP - public :: stdlib_iqamax -#:endif -#:if WITH_QP - public :: stdlib_iwamax -#:endif - + interface stdlib_cabs1 + #:for rk,rt,ri in REAL_KINDS_TYPES + module procedure stdlib_${ri}$cabs1 + #:endfor + end interface stdlib_cabs1 + contains - pure real(dp) function stdlib_dcabs1(z) +#:for ck,ct,ci in REAL_KINDS_TYPES + pure elemental real(${ck}$) function stdlib_${ci}$cabs1(z) !! DCABS1 computes |Re(.)| + |Im(.)| of a double complex number ! -- reference blas level1 routine -- ! -- reference blas is a software package provided by univ. of tennessee, -- ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments - complex(dp), intent(in) :: z + complex(${ck}$), intent(in) :: z ! ===================================================================== ! Intrinsic Functions intrinsic :: abs,real,aimag - stdlib_dcabs1 = abs(real(z,KIND=dp)) + abs(aimag(z)) - return - end function stdlib_dcabs1 - - - pure integer(ilp) function stdlib_isamax(n,sx,incx) - !! ISAMAX finds the index of the first element having maximum absolute value. - ! -- reference blas level1 routine -- - ! -- reference blas is a software package provided by univ. of tennessee, -- - ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- - ! Scalar Arguments - integer(ilp), intent(in) :: incx, n - ! Array Arguments - real(sp), intent(in) :: sx(*) - ! ===================================================================== - ! Local Scalars - real(sp) :: smax - integer(ilp) :: i, ix - ! Intrinsic Functions - intrinsic :: abs - stdlib_isamax = 0 - if (n<1 .or. incx<=0) return - stdlib_isamax = 1 - if (n==1) return - if (incx==1) then - ! code for increment equal to 1 - smax = abs(sx(1)) - do i = 2,n - if (abs(sx(i))>smax) then - stdlib_isamax = i - smax = abs(sx(i)) - end if - end do - else - ! code for increment not equal to 1 - ix = 1 - smax = abs(sx(1)) - ix = ix + incx - do i = 2,n - if (abs(sx(ix))>smax) then - stdlib_isamax = i - smax = abs(sx(ix)) - end if - ix = ix + incx - end do - end if - return - end function stdlib_isamax - - - pure integer(ilp) function stdlib_izamax(n,zx,incx) - !! IZAMAX finds the index of the first element having maximum |Re(.)| + |Im(.)| - ! -- reference blas level1 routine -- - ! -- reference blas is a software package provided by univ. of tennessee, -- - ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- - ! Scalar Arguments - integer(ilp), intent(in) :: incx, n - ! Array Arguments - complex(dp), intent(in) :: zx(*) - ! ===================================================================== - ! Local Scalars - real(dp) :: dmax - integer(ilp) :: i, ix - stdlib_izamax = 0 - if (n<1 .or. incx<=0) return - stdlib_izamax = 1 - if (n==1) return - if (incx==1) then - ! code for increment equal to 1 - dmax = stdlib_dcabs1(zx(1)) - do i = 2,n - if (stdlib_dcabs1(zx(i))>dmax) then - stdlib_izamax = i - dmax = stdlib_dcabs1(zx(i)) - end if - end do - else - ! code for increment not equal to 1 - ix = 1 - dmax = stdlib_dcabs1(zx(1)) - ix = ix + incx - do i = 2,n - if (stdlib_dcabs1(zx(ix))>dmax) then - stdlib_izamax = i - dmax = stdlib_dcabs1(zx(ix)) - end if - ix = ix + incx - end do - end if + stdlib_${ci}$cabs1 = abs(real(z,KIND=${ck}$)) + abs(aimag(z)) return - end function stdlib_izamax - + end function stdlib_${ci}$cabs1 +#:endfor - pure logical(lk) function stdlib_lsame(ca,cb) + pure elemental logical(lk) function stdlib_lsame(ca,cb) !! LSAME returns .TRUE. if CA is the same letter as CB regardless of !! case. ! -- reference blas level1 routine -- @@ -178,22 +86,6 @@ module stdlib_linalg_blas_aux ! return end function stdlib_lsame - - pure real(sp) function stdlib_scabs1(z) - !! SCABS1 computes |Re(.)| + |Im(.)| of a complex number - ! -- reference blas level1 routine -- - ! -- reference blas is a software package provided by univ. of tennessee, -- - ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- - ! Scalar Arguments - complex(sp), intent(in) :: z - ! ===================================================================== - ! Intrinsic Functions - intrinsic :: abs,aimag,real - stdlib_scabs1 = abs(real(z,KIND=sp)) + abs(aimag(z)) - return - end function stdlib_scabs1 - - pure subroutine stdlib_xerbla( srname, info ) !! XERBLA is an error handler for the LAPACK routines. !! It is called by an LAPACK routine if an input parameter has an @@ -255,28 +147,8 @@ module stdlib_linalg_blas_aux return end subroutine stdlib_xerbla_array -#:if WITH_QP - - - pure real(qp) function stdlib_qcabs1(z) - !! DCABS1: computes |Re(.)| + |Im(.)| of a double complex number - ! -- reference blas level1 routine -- - ! -- reference blas is a software package provided by univ. of tennessee, -- - ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- - ! Scalar Arguments - complex(qp), intent(in) :: z - ! ===================================================================== - ! Intrinsic Functions - intrinsic :: abs,real,aimag - stdlib_qcabs1 = abs(real(z,KIND=qp)) + abs(aimag(z)) - return - end function stdlib_qcabs1 -#:endif - -#:if WITH_QP - - - pure integer(ilp) function stdlib_iqamax(n,dx,incx) +#:for rk,rt,ri in REAL_KINDS_TYPES + pure integer(ilp) function stdlib_i${ri}$amax(n,dx,incx) !! IDAMAX: finds the index of the first element having maximum absolute value. ! -- reference blas level1 routine -- ! -- reference blas is a software package provided by univ. of tennessee, -- @@ -284,23 +156,23 @@ module stdlib_linalg_blas_aux ! Scalar Arguments integer(ilp), intent(in) :: incx, n ! Array Arguments - real(qp), intent(in) :: dx(*) + real(${rk}$), intent(in) :: dx(*) ! ===================================================================== ! Local Scalars - real(qp) :: dmax + real(${rk}$) :: dmax integer(ilp) :: i, ix ! Intrinsic Functions intrinsic :: abs - stdlib_iqamax = 0 + stdlib_i${ri}$amax = 0 if (n<1 .or. incx<=0) return - stdlib_iqamax = 1 + stdlib_i${ri}$amax = 1 if (n==1) return if (incx==1) then ! code for increment equal to 1 dmax = abs(dx(1)) do i = 2,n if (abs(dx(i))>dmax) then - stdlib_iqamax = i + stdlib_i${ri}$amax = i dmax = abs(dx(i)) end if end do @@ -311,20 +183,19 @@ module stdlib_linalg_blas_aux ix = ix + incx do i = 2,n if (abs(dx(ix))>dmax) then - stdlib_iqamax = i + stdlib_i${ri}$amax = i dmax = abs(dx(ix)) end if ix = ix + incx end do end if return - end function stdlib_iqamax -#:endif - -#:if WITH_QP + end function stdlib_i${ri}$amax + +#:endfor - - pure integer(ilp) function stdlib_iwamax(n,zx,incx) +#:for ck,ct,ci in CMPLX_KINDS_TYPES + pure integer(ilp) function stdlib_i${ci}$amax(n,zx,incx) !! IZAMAX: finds the index of the first element having maximum |Re(.)| + |Im(.)| ! -- reference blas level1 routine -- ! -- reference blas is a software package provided by univ. of tennessee, -- @@ -332,129 +203,40 @@ module stdlib_linalg_blas_aux ! Scalar Arguments integer(ilp), intent(in) :: incx, n ! Array Arguments - complex(qp), intent(in) :: zx(*) - ! ===================================================================== - ! Local Scalars - real(qp) :: dmax - integer(ilp) :: i, ix - stdlib_iwamax = 0 - if (n<1 .or. incx<=0) return - stdlib_iwamax = 1 - if (n==1) return - if (incx==1) then - ! code for increment equal to 1 - dmax = stdlib_qcabs1(zx(1)) - do i = 2,n - if (stdlib_qcabs1(zx(i))>dmax) then - stdlib_iwamax = i - dmax = stdlib_qcabs1(zx(i)) - end if - end do - else - ! code for increment not equal to 1 - ix = 1 - dmax = stdlib_qcabs1(zx(1)) - ix = ix + incx - do i = 2,n - if (stdlib_qcabs1(zx(ix))>dmax) then - stdlib_iwamax = i - dmax = stdlib_qcabs1(zx(ix)) - end if - ix = ix + incx - end do - end if - return - end function stdlib_iwamax -#:endif - - - pure integer(ilp) function stdlib_icamax(n,cx,incx) - !! ICAMAX finds the index of the first element having maximum |Re(.)| + |Im(.)| - ! -- reference blas level1 routine -- - ! -- reference blas is a software package provided by univ. of tennessee, -- - ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- - ! Scalar Arguments - integer(ilp), intent(in) :: incx, n - ! Array Arguments - complex(sp), intent(in) :: cx(*) + complex(${ck}$), intent(in) :: zx(*) ! ===================================================================== ! Local Scalars - real(sp) :: smax + real(${ck}$) :: dmax integer(ilp) :: i, ix - stdlib_icamax = 0 + stdlib_i${ci}$amax = 0 if (n<1 .or. incx<=0) return - stdlib_icamax = 1 + stdlib_i${ci}$amax = 1 if (n==1) return if (incx==1) then ! code for increment equal to 1 - smax = stdlib_scabs1(cx(1)) + dmax = stdlib_cabs1(zx(1)) do i = 2,n - if (stdlib_scabs1(cx(i))>smax) then - stdlib_icamax = i - smax = stdlib_scabs1(cx(i)) + if (stdlib_cabs1(zx(i))>dmax) then + stdlib_i${ci}$amax = i + dmax = stdlib_cabs1(zx(i)) end if end do else ! code for increment not equal to 1 ix = 1 - smax = stdlib_scabs1(cx(1)) + dmax = stdlib_cabs1(zx(1)) ix = ix + incx do i = 2,n - if (stdlib_scabs1(cx(ix))>smax) then - stdlib_icamax = i - smax = stdlib_scabs1(cx(ix)) + if (stdlib_cabs1(zx(ix))>dmax) then + stdlib_i${ci}$amax = i + dmax = stdlib_cabs1(zx(ix)) end if ix = ix + incx end do end if return - end function stdlib_icamax - - - pure integer(ilp) function stdlib_idamax(n,dx,incx) - !! IDAMAX finds the index of the first element having maximum absolute value. - ! -- reference blas level1 routine -- - ! -- reference blas is a software package provided by univ. of tennessee, -- - ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- - ! Scalar Arguments - integer(ilp), intent(in) :: incx, n - ! Array Arguments - real(dp), intent(in) :: dx(*) - ! ===================================================================== - ! Local Scalars - real(dp) :: dmax - integer(ilp) :: i, ix - ! Intrinsic Functions - intrinsic :: abs - stdlib_idamax = 0 - if (n<1 .or. incx<=0) return - stdlib_idamax = 1 - if (n==1) return - if (incx==1) then - ! code for increment equal to 1 - dmax = abs(dx(1)) - do i = 2,n - if (abs(dx(i))>dmax) then - stdlib_idamax = i - dmax = abs(dx(i)) - end if - end do - else - ! code for increment not equal to 1 - ix = 1 - dmax = abs(dx(1)) - ix = ix + incx - do i = 2,n - if (abs(dx(ix))>dmax) then - stdlib_idamax = i - dmax = abs(dx(ix)) - end if - ix = ix + incx - end do - end if - return - end function stdlib_idamax - - + end function stdlib_i${ci}$amax + +#:endfor end module stdlib_linalg_blas_aux diff --git a/src/stdlib_linalg_blas_c.fypp b/src/stdlib_linalg_blas_c.fypp index 7a6145506..19a8af232 100644 --- a/src/stdlib_linalg_blas_c.fypp +++ b/src/stdlib_linalg_blas_c.fypp @@ -100,7 +100,7 @@ module stdlib_linalg_blas_c ! Local Scalars integer(ilp) :: i, ix, iy if (n<=0) return - if (stdlib_scabs1(ca)==0.0e+0_sp) return + if (stdlib_cabs1(ca)==0.0e+0_sp) return if (incx==1 .and. incy==1) then ! code for both increments equal to 1 do i = 1,n diff --git a/src/stdlib_linalg_blas_d.fypp b/src/stdlib_linalg_blas_d.fypp index 463dfd954..de2c4ae74 100644 --- a/src/stdlib_linalg_blas_d.fypp +++ b/src/stdlib_linalg_blas_d.fypp @@ -4398,13 +4398,13 @@ module stdlib_linalg_blas_d if (incx==1) then ! code for increment equal to 1 do i = 1,n - stemp = stemp + stdlib_dcabs1(zx(i)) + stemp = stemp + stdlib_cabs1(zx(i)) end do else ! code for increment not equal to 1 nincx = n*incx do i = 1,nincx,incx - stemp = stemp + stdlib_dcabs1(zx(i)) + stemp = stemp + stdlib_cabs1(zx(i)) end do end if stdlib_dzasum = stemp diff --git a/src/stdlib_linalg_blas_q.fypp b/src/stdlib_linalg_blas_q.fypp index bf8dd91d0..8ae5dad2b 100644 --- a/src/stdlib_linalg_blas_q.fypp +++ b/src/stdlib_linalg_blas_q.fypp @@ -1,6 +1,7 @@ #:include "common.fypp" -#:if WITH_QP -module stdlib_linalg_blas_q +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] +module stdlib_linalg_blas_${ri}$ use stdlib_linalg_constants use stdlib_linalg_blas_aux use stdlib_linalg_blas_s @@ -11,86 +12,86 @@ module stdlib_linalg_blas_q private - public :: sp,dp,qp,lk,ilp - public :: stdlib_qasum - public :: stdlib_qaxpy - public :: stdlib_qcopy - public :: stdlib_qdot - public :: stdlib_qgbmv - public :: stdlib_qgemm - public :: stdlib_qgemv - public :: stdlib_qger - public :: stdlib_qnrm2 - public :: stdlib_qrot - public :: stdlib_qrotg - public :: stdlib_qrotm - public :: stdlib_qrotmg - public :: stdlib_qsbmv - public :: stdlib_qscal - public :: stdlib_qsdot - public :: stdlib_qspmv - public :: stdlib_qspr - public :: stdlib_qspr2 - public :: stdlib_qswap - public :: stdlib_qsymm - public :: stdlib_qsymv - public :: stdlib_qsyr - public :: stdlib_qsyr2 - public :: stdlib_qsyr2k - public :: stdlib_qsyrk - public :: stdlib_qtbmv - public :: stdlib_qtbsv - public :: stdlib_qtpmv - public :: stdlib_qtpsv - public :: stdlib_qtrmm - public :: stdlib_qtrmv - public :: stdlib_qtrsm - public :: stdlib_qtrsv - public :: stdlib_qzasum - public :: stdlib_qznrm2 + public :: sp,dp,${rk}$,lk,ilp + public :: stdlib_${ri}$asum + public :: stdlib_${ri}$axpy + public :: stdlib_${ri}$copy + public :: stdlib_${ri}$dot + public :: stdlib_${ri}$gbmv + public :: stdlib_${ri}$gemm + public :: stdlib_${ri}$gemv + public :: stdlib_${ri}$ger + public :: stdlib_${ri}$nrm2 + public :: stdlib_${ri}$rot + public :: stdlib_${ri}$rotg + public :: stdlib_${ri}$rotm + public :: stdlib_${ri}$rotmg + public :: stdlib_${ri}$sbmv + public :: stdlib_${ri}$scal + public :: stdlib_${ri}$sdot + public :: stdlib_${ri}$spmv + public :: stdlib_${ri}$spr + public :: stdlib_${ri}$spr2 + public :: stdlib_${ri}$swap + public :: stdlib_${ri}$symm + public :: stdlib_${ri}$symv + public :: stdlib_${ri}$syr + public :: stdlib_${ri}$syr2 + public :: stdlib_${ri}$syr2k + public :: stdlib_${ri}$syrk + public :: stdlib_${ri}$tbmv + public :: stdlib_${ri}$tbsv + public :: stdlib_${ri}$tpmv + public :: stdlib_${ri}$tpsv + public :: stdlib_${ri}$trmm + public :: stdlib_${ri}$trmv + public :: stdlib_${ri}$trsm + public :: stdlib_${ri}$trsv + public :: stdlib_${ri}$zasum + public :: stdlib_${ri}$znrm2 ! 128-bit real constants - real(qp), parameter, private :: negone = -1.00_qp - real(qp), parameter, private :: zero = 0.00_qp - real(qp), parameter, private :: half = 0.50_qp - real(qp), parameter, private :: one = 1.00_qp - real(qp), parameter, private :: two = 2.00_qp - real(qp), parameter, private :: three = 3.00_qp - real(qp), parameter, private :: four = 4.00_qp - real(qp), parameter, private :: eight = 8.00_qp - real(qp), parameter, private :: ten = 10.00_qp + real(${rk}$), parameter, private :: negone = -1.00_${rk}$ + real(${rk}$), parameter, private :: zero = 0.00_${rk}$ + real(${rk}$), parameter, private :: half = 0.50_${rk}$ + real(${rk}$), parameter, private :: one = 1.00_${rk}$ + real(${rk}$), parameter, private :: two = 2.00_${rk}$ + real(${rk}$), parameter, private :: three = 3.00_${rk}$ + real(${rk}$), parameter, private :: four = 4.00_${rk}$ + real(${rk}$), parameter, private :: eight = 8.00_${rk}$ + real(${rk}$), parameter, private :: ten = 10.00_${rk}$ ! 128-bit complex constants - complex(qp), parameter, private :: czero = ( 0.0_qp,0.0_qp) - complex(qp), parameter, private :: chalf = ( 0.5_qp,0.0_qp) - complex(qp), parameter, private :: cone = ( 1.0_qp,0.0_qp) - complex(qp), parameter, private :: cnegone = (-1.0_qp,0.0_qp) + complex(${rk}$), parameter, private :: czero = ( 0.0_${rk}$,0.0_${rk}$) + complex(${rk}$), parameter, private :: chalf = ( 0.5_${rk}$,0.0_${rk}$) + complex(${rk}$), parameter, private :: cone = ( 1.0_${rk}$,0.0_${rk}$) + complex(${rk}$), parameter, private :: cnegone = (-1.0_${rk}$,0.0_${rk}$) ! 128-bit scaling constants integer, parameter, private :: maxexp = maxexponent(zero) integer, parameter, private :: minexp = minexponent(zero) - real(qp), parameter, private :: rradix = real(radix(zero),qp) - real(qp), parameter, private :: ulp = epsilon(zero) - real(qp), parameter, private :: eps = ulp*half - real(qp), parameter, private :: safmin = rradix**max(minexp-1,1-maxexp) - real(qp), parameter, private :: safmax = one/safmin - real(qp), parameter, private :: smlnum = safmin/ulp - real(qp), parameter, private :: bignum = safmax*ulp - real(qp), parameter, private :: rtmin = sqrt(smlnum) - real(qp), parameter, private :: rtmax = sqrt(bignum) + real(${rk}$), parameter, private :: rradix = real(radix(zero),${rk}$) + real(${rk}$), parameter, private :: ulp = epsilon(zero) + real(${rk}$), parameter, private :: eps = ulp*half + real(${rk}$), parameter, private :: safmin = rradix**max(minexp-1,1-maxexp) + real(${rk}$), parameter, private :: safmax = one/safmin + real(${rk}$), parameter, private :: smlnum = safmin/ulp + real(${rk}$), parameter, private :: bignum = safmax*ulp + real(${rk}$), parameter, private :: rtmin = sqrt(smlnum) + real(${rk}$), parameter, private :: rtmax = sqrt(bignum) ! 128-bit Blue's scaling constants ! ssml>=1/s and sbig==1/S with s,S as defined in https://doi.org/10.1145/355769.355771 - real(qp), parameter, private :: tsml = rradix**ceiling((minexp-1)*half) - real(qp), parameter, private :: tbig = rradix**floor((maxexp-digits(zero)+1)*half) - real(qp), parameter, private :: ssml = rradix**(-floor((minexp-digits(zero))*half)) - real(qp), parameter, private :: sbig = rradix**(-ceiling((maxexp+digits(zero)-1)*half)) + real(${rk}$), parameter, private :: tsml = rradix**ceiling((minexp-1)*half) + real(${rk}$), parameter, private :: tbig = rradix**floor((maxexp-digits(zero)+1)*half) + real(${rk}$), parameter, private :: ssml = rradix**(-floor((minexp-digits(zero))*half)) + real(${rk}$), parameter, private :: sbig = rradix**(-ceiling((maxexp+digits(zero)-1)*half)) contains - pure real(qp) function stdlib_qasum(n,dx,incx) + pure real(${rk}$) function stdlib_${ri}$asum(n,dx,incx) !! DASUM: takes the sum of the absolute values. ! -- reference blas level1 routine -- ! -- reference blas is a software package provided by univ. of tennessee, -- @@ -98,14 +99,14 @@ module stdlib_linalg_blas_q ! Scalar Arguments integer(ilp), intent(in) :: incx, n ! Array Arguments - real(qp), intent(in) :: dx(*) + real(${rk}$), intent(in) :: dx(*) ! ===================================================================== ! Local Scalars - real(qp) :: dtemp + real(${rk}$) :: dtemp integer(ilp) :: i, m, mp1, nincx ! Intrinsic Functions intrinsic :: abs,mod - stdlib_qasum = zero + stdlib_${ri}$asum = zero dtemp = zero if (n<=0 .or. incx<=0) return if (incx==1) then @@ -117,7 +118,7 @@ module stdlib_linalg_blas_q dtemp = dtemp + abs(dx(i)) end do if (n<6) then - stdlib_qasum = dtemp + stdlib_${ri}$asum = dtemp return end if end if @@ -133,30 +134,30 @@ module stdlib_linalg_blas_q dtemp = dtemp + abs(dx(i)) end do end if - stdlib_qasum = dtemp + stdlib_${ri}$asum = dtemp return - end function stdlib_qasum + end function stdlib_${ri}$asum - pure subroutine stdlib_qaxpy(n,da,dx,incx,dy,incy) + pure subroutine stdlib_${ri}$axpy(n,da,dx,incx,dy,incy) !! DAXPY: constant times a vector plus a vector. !! uses unrolled loops for increments equal to one. ! -- reference blas level1 routine -- ! -- reference blas is a software package provided by univ. of tennessee, -- ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments - real(qp), intent(in) :: da + real(${rk}$), intent(in) :: da integer(ilp), intent(in) :: incx, incy, n ! Array Arguments - real(qp), intent(in) :: dx(*) - real(qp), intent(inout) :: dy(*) + real(${rk}$), intent(in) :: dx(*) + real(${rk}$), intent(inout) :: dy(*) ! ===================================================================== ! Local Scalars integer(ilp) :: i, ix, iy, m, mp1 ! Intrinsic Functions intrinsic :: mod if (n<=0) return - if (da==0.0_qp) return + if (da==0.0_${rk}$) return if (incx==1 .and. incy==1) then ! code for both increments equal to 1 ! clean-up loop @@ -188,10 +189,10 @@ module stdlib_linalg_blas_q end do end if return - end subroutine stdlib_qaxpy + end subroutine stdlib_${ri}$axpy - pure subroutine stdlib_qcopy(n,dx,incx,dy,incy) + pure subroutine stdlib_${ri}$copy(n,dx,incx,dy,incy) !! DCOPY: copies a vector, x, to a vector, y. !! uses unrolled loops for increments equal to 1. ! -- reference blas level1 routine -- @@ -200,8 +201,8 @@ module stdlib_linalg_blas_q ! Scalar Arguments integer(ilp), intent(in) :: incx, incy, n ! Array Arguments - real(qp), intent(in) :: dx(*) - real(qp), intent(out) :: dy(*) + real(${rk}$), intent(in) :: dx(*) + real(${rk}$), intent(out) :: dy(*) ! ===================================================================== ! Local Scalars integer(ilp) :: i, ix, iy, m, mp1 @@ -242,10 +243,10 @@ module stdlib_linalg_blas_q end do end if return - end subroutine stdlib_qcopy + end subroutine stdlib_${ri}$copy - pure real(qp) function stdlib_qdot(n,dx,incx,dy,incy) + pure real(${rk}$) function stdlib_${ri}$dot(n,dx,incx,dy,incy) !! DDOT: forms the dot product of two vectors. !! uses unrolled loops for increments equal to one. ! -- reference blas level1 routine -- @@ -254,14 +255,14 @@ module stdlib_linalg_blas_q ! Scalar Arguments integer(ilp), intent(in) :: incx, incy, n ! Array Arguments - real(qp), intent(in) :: dx(*), dy(*) + real(${rk}$), intent(in) :: dx(*), dy(*) ! ===================================================================== ! Local Scalars - real(qp) :: dtemp + real(${rk}$) :: dtemp integer(ilp) :: i, ix, iy, m, mp1 ! Intrinsic Functions intrinsic :: mod - stdlib_qdot = zero + stdlib_${ri}$dot = zero dtemp = zero if (n<=0) return if (incx==1 .and. incy==1) then @@ -273,7 +274,7 @@ module stdlib_linalg_blas_q dtemp = dtemp + dx(i)*dy(i) end do if (n<5) then - stdlib_qdot=dtemp + stdlib_${ri}$dot=dtemp return end if end if @@ -295,12 +296,12 @@ module stdlib_linalg_blas_q iy = iy + incy end do end if - stdlib_qdot = dtemp + stdlib_${ri}$dot = dtemp return - end function stdlib_qdot + end function stdlib_${ri}$dot - pure subroutine stdlib_qgbmv(trans,m,n,kl,ku,alpha,a,lda,x,incx,beta,y,incy) + pure subroutine stdlib_${ri}$gbmv(trans,m,n,kl,ku,alpha,a,lda,x,incx,beta,y,incy) !! DGBMV: performs one of the matrix-vector operations !! y := alpha*A*x + beta*y, or y := alpha*A**T*x + beta*y, !! where alpha and beta are scalars, x and y are vectors and A is an @@ -309,16 +310,16 @@ module stdlib_linalg_blas_q ! -- reference blas is a software package provided by univ. of tennessee, -- ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments - real(qp), intent(in) :: alpha, beta + real(${rk}$), intent(in) :: alpha, beta integer(ilp), intent(in) :: incx, incy, kl, ku, lda, m, n character, intent(in) :: trans ! Array Arguments - real(qp), intent(in) :: a(lda,*), x(*) - real(qp), intent(inout) :: y(*) + real(${rk}$), intent(in) :: a(lda,*), x(*) + real(${rk}$), intent(inout) :: y(*) ! ===================================================================== ! Local Scalars - real(qp) :: temp + real(${rk}$) :: temp integer(ilp) :: i, info, ix, iy, j, jx, jy, k, kup1, kx, ky, lenx, leny ! Intrinsic Functions intrinsic :: max,min @@ -452,10 +453,10 @@ module stdlib_linalg_blas_q end if end if return - end subroutine stdlib_qgbmv + end subroutine stdlib_${ri}$gbmv - pure subroutine stdlib_qgemm(transa,transb,m,n,k,alpha,a,lda,b,ldb,beta,c,ldc) + pure subroutine stdlib_${ri}$gemm(transa,transb,m,n,k,alpha,a,lda,b,ldb,beta,c,ldc) !! DGEMM: performs one of the matrix-matrix operations !! C := alpha*op( A )*op( B ) + beta*C, !! where op( X ) is one of @@ -466,17 +467,17 @@ module stdlib_linalg_blas_q ! -- reference blas is a software package provided by univ. of tennessee, -- ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments - real(qp), intent(in) :: alpha, beta + real(${rk}$), intent(in) :: alpha, beta integer(ilp), intent(in) :: k, lda, ldb, ldc, m, n character, intent(in) :: transa, transb ! Array Arguments - real(qp), intent(in) :: a(lda,*), b(ldb,*) - real(qp), intent(inout) :: c(ldc,*) + real(${rk}$), intent(in) :: a(lda,*), b(ldb,*) + real(${rk}$), intent(inout) :: c(ldc,*) ! ===================================================================== ! Intrinsic Functions intrinsic :: max ! Local Scalars - real(qp) :: temp + real(${rk}$) :: temp integer(ilp) :: i, info, j, l, nrowa, nrowb logical(lk) :: nota, notb @@ -615,10 +616,10 @@ module stdlib_linalg_blas_q end if end if return - end subroutine stdlib_qgemm + end subroutine stdlib_${ri}$gemm - pure subroutine stdlib_qgemv(trans,m,n,alpha,a,lda,x,incx,beta,y,incy) + pure subroutine stdlib_${ri}$gemv(trans,m,n,alpha,a,lda,x,incx,beta,y,incy) !! DGEMV: performs one of the matrix-vector operations !! y := alpha*A*x + beta*y, or y := alpha*A**T*x + beta*y, !! where alpha and beta are scalars, x and y are vectors and A is an @@ -627,16 +628,16 @@ module stdlib_linalg_blas_q ! -- reference blas is a software package provided by univ. of tennessee, -- ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments - real(qp), intent(in) :: alpha, beta + real(${rk}$), intent(in) :: alpha, beta integer(ilp), intent(in) :: incx, incy, lda, m, n character, intent(in) :: trans ! Array Arguments - real(qp), intent(in) :: a(lda,*), x(*) - real(qp), intent(inout) :: y(*) + real(${rk}$), intent(in) :: a(lda,*), x(*) + real(${rk}$), intent(inout) :: y(*) ! ===================================================================== ! Local Scalars - real(qp) :: temp + real(${rk}$) :: temp integer(ilp) :: i, info, ix, iy, j, jx, jy, kx, ky, lenx, leny ! Intrinsic Functions intrinsic :: max @@ -759,10 +760,10 @@ module stdlib_linalg_blas_q end if end if return - end subroutine stdlib_qgemv + end subroutine stdlib_${ri}$gemv - pure subroutine stdlib_qger(m,n,alpha,x,incx,y,incy,a,lda) + pure subroutine stdlib_${ri}$ger(m,n,alpha,x,incx,y,incy,a,lda) !! DGER: performs the rank 1 operation !! A := alpha*x*y**T + A, !! where alpha is a scalar, x is an m element vector, y is an n element @@ -771,15 +772,15 @@ module stdlib_linalg_blas_q ! -- reference blas is a software package provided by univ. of tennessee, -- ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments - real(qp), intent(in) :: alpha + real(${rk}$), intent(in) :: alpha integer(ilp), intent(in) :: incx, incy, lda, m, n ! Array Arguments - real(qp), intent(inout) :: a(lda,*) - real(qp), intent(in) :: x(*), y(*) + real(${rk}$), intent(inout) :: a(lda,*) + real(${rk}$), intent(in) :: x(*), y(*) ! ===================================================================== ! Local Scalars - real(qp) :: temp + real(${rk}$) :: temp integer(ilp) :: i, info, ix, j, jy, kx ! Intrinsic Functions intrinsic :: max @@ -838,32 +839,32 @@ module stdlib_linalg_blas_q end do end if return - end subroutine stdlib_qger + end subroutine stdlib_${ri}$ger - pure function stdlib_qnrm2( n, x, incx ) + pure function stdlib_${ri}$nrm2( n, x, incx ) !! DNRM2: returns the euclidean norm of a vector via the function !! name, so that !! DNRM2 := sqrt( x'*x ) - real(qp) :: stdlib_qnrm2 - ! -- reference blas level1 routine (version 3.9.1_qp) -- + real(${rk}$) :: stdlib_${ri}$nrm2 + ! -- reference blas level1 routine (version 3.9.1_${rk}$) -- ! -- reference blas is a software package provided by univ. of tennessee, -- ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! march 2021 ! Constants - integer, parameter :: wp = kind(1._qp) - real(qp), parameter :: maxn = huge(0.0_qp) + integer, parameter :: wp = kind(1._${rk}$) + real(${rk}$), parameter :: maxn = huge(0.0_${rk}$) ! .. blue's scaling constants .. ! Scalar Arguments integer(ilp), intent(in) :: incx, n ! Array Arguments - real(qp), intent(in) :: x(*) + real(${rk}$), intent(in) :: x(*) ! Local Scalars integer(ilp) :: i, ix logical(lk) :: notbig - real(qp) :: abig, amed, asml, ax, scl, sumsq, ymax, ymin + real(${rk}$) :: abig, amed, asml, ax, scl, sumsq, ymax, ymin ! quick return if possible - stdlib_qnrm2 = zero + stdlib_${ri}$nrm2 = zero if( n <= 0 ) return scl = one sumsq = zero @@ -924,24 +925,24 @@ module stdlib_linalg_blas_q scl = one sumsq = amed end if - stdlib_qnrm2 = scl*sqrt( sumsq ) + stdlib_${ri}$nrm2 = scl*sqrt( sumsq ) return - end function stdlib_qnrm2 + end function stdlib_${ri}$nrm2 - pure subroutine stdlib_qrot(n,dx,incx,dy,incy,c,s) + pure subroutine stdlib_${ri}$rot(n,dx,incx,dy,incy,c,s) !! DROT: applies a plane rotation. ! -- reference blas level1 routine -- ! -- reference blas is a software package provided by univ. of tennessee, -- ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments - real(qp), intent(in) :: c, s + real(${rk}$), intent(in) :: c, s integer(ilp), intent(in) :: incx, incy, n ! Array Arguments - real(qp), intent(inout) :: dx(*), dy(*) + real(${rk}$), intent(inout) :: dx(*), dy(*) ! ===================================================================== ! Local Scalars - real(qp) :: dtemp + real(${rk}$) :: dtemp integer(ilp) :: i, ix, iy if (n<=0) return if (incx==1 .and. incy==1) then @@ -967,10 +968,10 @@ module stdlib_linalg_blas_q end do end if return - end subroutine stdlib_qrot + end subroutine stdlib_${ri}$rot - pure subroutine stdlib_qrotg( a, b, c, s ) + pure subroutine stdlib_${ri}$rotg( a, b, c, s ) !! The computation uses the formulas !! sigma = sgn(a) if |a| > |b| !! = sgn(b) if |b| >= |a| @@ -989,13 +990,13 @@ module stdlib_linalg_blas_q ! -- reference blas is a software package provided by univ. of tennessee, -- ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Constants - integer, parameter :: wp = kind(1._qp) + integer, parameter :: wp = kind(1._${rk}$) ! Scaling Constants ! Scalar Arguments - real(qp), intent(inout) :: a, b - real(qp), intent(out) :: c, s + real(${rk}$), intent(inout) :: a, b + real(${rk}$), intent(out) :: c, s ! Local Scalars - real(qp) :: anorm, bnorm, scl, sigma, r, z + real(${rk}$) :: anorm, bnorm, scl, sigma, r, z anorm = abs(a) bnorm = abs(b) if( bnorm == zero ) then @@ -1028,10 +1029,10 @@ module stdlib_linalg_blas_q b = z end if return - end subroutine stdlib_qrotg + end subroutine stdlib_${ri}$rotg - pure subroutine stdlib_qrotm(n,dx,incx,dy,incy,dparam) + pure subroutine stdlib_${ri}$rotm(n,dx,incx,dy,incy,dparam) !! QROTM applies the modified Givens transformation, \(H\), to the 2-by-N matrix !! $$ \left[ \begin{array}{c}DX^T\\DY^T\\ \end{array} \right], $$ !! where \(^T\) indicates transpose. The elements of \(DX\) are in @@ -1049,15 +1050,15 @@ module stdlib_linalg_blas_q ! Scalar Arguments integer(ilp), intent(in) :: incx, incy, n ! Array Arguments - real(qp), intent(in) :: dparam(5) - real(qp), intent(inout) :: dx(*), dy(*) + real(${rk}$), intent(in) :: dparam(5) + real(${rk}$), intent(inout) :: dx(*), dy(*) ! ===================================================================== ! Local Scalars - real(qp) :: dflag, dh11, dh12, dh21, dh22, two, w, z, zero + real(${rk}$) :: dflag, dh11, dh12, dh21, dh22, two, w, z, zero integer(ilp) :: i, kx, ky, nsteps ! Data Statements - zero = 0.0_qp - two = 2.0_qp + zero = 0.0_${rk}$ + two = 2.0_${rk}$ dflag = dparam(1) if (n<=0 .or. (dflag+two==zero)) return if (incx==incy.and.incx>0) then @@ -1135,10 +1136,10 @@ module stdlib_linalg_blas_q end if end if return - end subroutine stdlib_qrotm + end subroutine stdlib_${ri}$rotm - pure subroutine stdlib_qrotmg(dd1,dd2,dx1,dy1,dparam) + pure subroutine stdlib_${ri}$rotmg(dd1,dd2,dx1,dy1,dparam) !! QROTMG Constructs the modified Givens transformation matrix \(H\) which zeros the !! second component of the 2-vector !! $$ \left[ {\sqrt{DD_1}\cdot DX_1,\sqrt{DD_2}\cdot DY_2} \right]^T. $$ @@ -1155,23 +1156,23 @@ module stdlib_linalg_blas_q ! -- reference blas is a software package provided by univ. of tennessee, -- ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments - real(qp), intent(inout) :: dd1, dd2, dx1 - real(qp), intent(in) :: dy1 + real(${rk}$), intent(inout) :: dd1, dd2, dx1 + real(${rk}$), intent(in) :: dy1 ! Array Arguments - real(qp), intent(out) :: dparam(5) + real(${rk}$), intent(out) :: dparam(5) ! ===================================================================== ! Local Scalars - real(qp) :: dflag, dh11, dh12, dh21, dh22, dp1, dp2, dq1, dq2, dtemp, du, gam, gamsq, & + real(${rk}$) :: dflag, dh11, dh12, dh21, dh22, dp1, dp2, dq1, dq2, dtemp, du, gam, gamsq, & one, rgamsq, two, zero ! Intrinsic Functions intrinsic :: abs ! Data Statements - zero = 0.0_qp - one = 1.0_qp - two = 2.0_qp - gam = 4096.0_qp - gamsq = 16777216.0_qp - rgamsq = 5.9604645e-8_qp + zero = 0.0_${rk}$ + one = 1.0_${rk}$ + two = 2.0_${rk}$ + gam = 4096.0_${rk}$ + gamsq = 16777216.0_${rk}$ + rgamsq = 5.9604645e-8_${rk}$ if (dd10) then ! code for equal, positive, non-unit increments. ns = n*incx do i = 1,ns,incx - stdlib_qsdot = stdlib_qsdot + real(sx(i),KIND=qp)*real(sy(i),KIND=qp) + stdlib_${ri}$sdot = stdlib_${ri}$sdot + real(sx(i),KIND=${rk}$)*real(sy(i),KIND=${rk}$) end do else ! code for unequal or nonpositive increments. @@ -1549,16 +1550,16 @@ module stdlib_linalg_blas_q if (incx<0) kx = 1 + (1-n)*incx if (incy<0) ky = 1 + (1-n)*incy do i = 1,n - stdlib_qsdot = stdlib_qsdot + real(sx(kx),KIND=qp)*real(sy(ky),KIND=qp) + stdlib_${ri}$sdot = stdlib_${ri}$sdot + real(sx(kx),KIND=${rk}$)*real(sy(ky),KIND=${rk}$) kx = kx + incx ky = ky + incy end do end if return - end function stdlib_qsdot + end function stdlib_${ri}$sdot - pure subroutine stdlib_qspmv(uplo,n,alpha,ap,x,incx,beta,y,incy) + pure subroutine stdlib_${ri}$spmv(uplo,n,alpha,ap,x,incx,beta,y,incy) !! DSPMV: performs the matrix-vector operation !! y := alpha*A*x + beta*y, !! where alpha and beta are scalars, x and y are n element vectors and @@ -1567,16 +1568,16 @@ module stdlib_linalg_blas_q ! -- reference blas is a software package provided by univ. of tennessee, -- ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments - real(qp), intent(in) :: alpha, beta + real(${rk}$), intent(in) :: alpha, beta integer(ilp), intent(in) :: incx, incy, n character, intent(in) :: uplo ! Array Arguments - real(qp), intent(in) :: ap(*), x(*) - real(qp), intent(inout) :: y(*) + real(${rk}$), intent(in) :: ap(*), x(*) + real(${rk}$), intent(inout) :: y(*) ! ===================================================================== ! Local Scalars - real(qp) :: temp1, temp2 + real(${rk}$) :: temp1, temp2 integer(ilp) :: i, info, ix, iy, j, jx, jy, k, kk, kx, ky ! test the input parameters. info = 0 @@ -1711,10 +1712,10 @@ module stdlib_linalg_blas_q end if end if return - end subroutine stdlib_qspmv + end subroutine stdlib_${ri}$spmv - pure subroutine stdlib_qspr(uplo,n,alpha,x,incx,ap) + pure subroutine stdlib_${ri}$spr(uplo,n,alpha,x,incx,ap) !! DSPR: performs the symmetric rank 1 operation !! A := alpha*x*x**T + A, !! where alpha is a real scalar, x is an n element vector and A is an @@ -1723,16 +1724,16 @@ module stdlib_linalg_blas_q ! -- reference blas is a software package provided by univ. of tennessee, -- ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments - real(qp), intent(in) :: alpha + real(${rk}$), intent(in) :: alpha integer(ilp), intent(in) :: incx, n character, intent(in) :: uplo ! Array Arguments - real(qp), intent(inout) :: ap(*) - real(qp), intent(in) :: x(*) + real(${rk}$), intent(inout) :: ap(*) + real(${rk}$), intent(in) :: x(*) ! ===================================================================== ! Local Scalars - real(qp) :: temp + real(${rk}$) :: temp integer(ilp) :: i, info, ix, j, jx, k, kk, kx ! test the input parameters. info = 0 @@ -1818,10 +1819,10 @@ module stdlib_linalg_blas_q end if end if return - end subroutine stdlib_qspr + end subroutine stdlib_${ri}$spr - pure subroutine stdlib_qspr2(uplo,n,alpha,x,incx,y,incy,ap) + pure subroutine stdlib_${ri}$spr2(uplo,n,alpha,x,incx,y,incy,ap) !! DSPR2: performs the symmetric rank 2 operation !! A := alpha*x*y**T + alpha*y*x**T + A, !! where alpha is a scalar, x and y are n element vectors and A is an @@ -1830,16 +1831,16 @@ module stdlib_linalg_blas_q ! -- reference blas is a software package provided by univ. of tennessee, -- ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments - real(qp), intent(in) :: alpha + real(${rk}$), intent(in) :: alpha integer(ilp), intent(in) :: incx, incy, n character, intent(in) :: uplo ! Array Arguments - real(qp), intent(inout) :: ap(*) - real(qp), intent(in) :: x(*), y(*) + real(${rk}$), intent(inout) :: ap(*) + real(${rk}$), intent(in) :: x(*), y(*) ! ===================================================================== ! Local Scalars - real(qp) :: temp1, temp2 + real(${rk}$) :: temp1, temp2 integer(ilp) :: i, info, ix, iy, j, jx, jy, k, kk, kx, ky ! test the input parameters. info = 0 @@ -1945,10 +1946,10 @@ module stdlib_linalg_blas_q end if end if return - end subroutine stdlib_qspr2 + end subroutine stdlib_${ri}$spr2 - pure subroutine stdlib_qswap(n,dx,incx,dy,incy) + pure subroutine stdlib_${ri}$swap(n,dx,incx,dy,incy) !! DSWAP: interchanges two vectors. !! uses unrolled loops for increments equal to 1. ! -- reference blas level1 routine -- @@ -1957,10 +1958,10 @@ module stdlib_linalg_blas_q ! Scalar Arguments integer(ilp), intent(in) :: incx, incy, n ! Array Arguments - real(qp), intent(inout) :: dx(*), dy(*) + real(${rk}$), intent(inout) :: dx(*), dy(*) ! ===================================================================== ! Local Scalars - real(qp) :: dtemp + real(${rk}$) :: dtemp integer(ilp) :: i, ix, iy, m, mp1 ! Intrinsic Functions intrinsic :: mod @@ -2005,10 +2006,10 @@ module stdlib_linalg_blas_q end do end if return - end subroutine stdlib_qswap + end subroutine stdlib_${ri}$swap - pure subroutine stdlib_qsymm(side,uplo,m,n,alpha,a,lda,b,ldb,beta,c,ldc) + pure subroutine stdlib_${ri}$symm(side,uplo,m,n,alpha,a,lda,b,ldb,beta,c,ldc) !! DSYMM: performs one of the matrix-matrix operations !! C := alpha*A*B + beta*C, !! or @@ -2019,17 +2020,17 @@ module stdlib_linalg_blas_q ! -- reference blas is a software package provided by univ. of tennessee, -- ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments - real(qp), intent(in) :: alpha, beta + real(${rk}$), intent(in) :: alpha, beta integer(ilp), intent(in) :: lda, ldb, ldc, m, n character, intent(in) :: side, uplo ! Array Arguments - real(qp), intent(in) :: a(lda,*), b(ldb,*) - real(qp), intent(inout) :: c(ldc,*) + real(${rk}$), intent(in) :: a(lda,*), b(ldb,*) + real(${rk}$), intent(inout) :: c(ldc,*) ! ===================================================================== ! Intrinsic Functions intrinsic :: max ! Local Scalars - real(qp) :: temp1, temp2 + real(${rk}$) :: temp1, temp2 integer(ilp) :: i, info, j, k, nrowa logical(lk) :: upper @@ -2152,10 +2153,10 @@ module stdlib_linalg_blas_q end do loop_170 end if return - end subroutine stdlib_qsymm + end subroutine stdlib_${ri}$symm - pure subroutine stdlib_qsymv(uplo,n,alpha,a,lda,x,incx,beta,y,incy) + pure subroutine stdlib_${ri}$symv(uplo,n,alpha,a,lda,x,incx,beta,y,incy) !! DSYMV: performs the matrix-vector operation !! y := alpha*A*x + beta*y, !! where alpha and beta are scalars, x and y are n element vectors and @@ -2164,16 +2165,16 @@ module stdlib_linalg_blas_q ! -- reference blas is a software package provided by univ. of tennessee, -- ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments - real(qp), intent(in) :: alpha, beta + real(${rk}$), intent(in) :: alpha, beta integer(ilp), intent(in) :: incx, incy, lda, n character, intent(in) :: uplo ! Array Arguments - real(qp), intent(in) :: a(lda,*), x(*) - real(qp), intent(inout) :: y(*) + real(${rk}$), intent(in) :: a(lda,*), x(*) + real(${rk}$), intent(inout) :: y(*) ! ===================================================================== ! Local Scalars - real(qp) :: temp1, temp2 + real(${rk}$) :: temp1, temp2 integer(ilp) :: i, info, ix, iy, j, jx, jy, kx, ky ! Intrinsic Functions intrinsic :: max @@ -2304,10 +2305,10 @@ module stdlib_linalg_blas_q end if end if return - end subroutine stdlib_qsymv + end subroutine stdlib_${ri}$symv - pure subroutine stdlib_qsyr(uplo,n,alpha,x,incx,a,lda) + pure subroutine stdlib_${ri}$syr(uplo,n,alpha,x,incx,a,lda) !! DSYR: performs the symmetric rank 1 operation !! A := alpha*x*x**T + A, !! where alpha is a real scalar, x is an n element vector and A is an @@ -2316,16 +2317,16 @@ module stdlib_linalg_blas_q ! -- reference blas is a software package provided by univ. of tennessee, -- ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments - real(qp), intent(in) :: alpha + real(${rk}$), intent(in) :: alpha integer(ilp), intent(in) :: incx, lda, n character, intent(in) :: uplo ! Array Arguments - real(qp), intent(inout) :: a(lda,*) - real(qp), intent(in) :: x(*) + real(${rk}$), intent(inout) :: a(lda,*) + real(${rk}$), intent(in) :: x(*) ! ===================================================================== ! Local Scalars - real(qp) :: temp + real(${rk}$) :: temp integer(ilp) :: i, info, ix, j, jx, kx ! Intrinsic Functions intrinsic :: max @@ -2407,10 +2408,10 @@ module stdlib_linalg_blas_q end if end if return - end subroutine stdlib_qsyr + end subroutine stdlib_${ri}$syr - pure subroutine stdlib_qsyr2(uplo,n,alpha,x,incx,y,incy,a,lda) + pure subroutine stdlib_${ri}$syr2(uplo,n,alpha,x,incx,y,incy,a,lda) !! DSYR2: performs the symmetric rank 2 operation !! A := alpha*x*y**T + alpha*y*x**T + A, !! where alpha is a scalar, x and y are n element vectors and A is an n @@ -2419,16 +2420,16 @@ module stdlib_linalg_blas_q ! -- reference blas is a software package provided by univ. of tennessee, -- ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments - real(qp), intent(in) :: alpha + real(${rk}$), intent(in) :: alpha integer(ilp), intent(in) :: incx, incy, lda, n character, intent(in) :: uplo ! Array Arguments - real(qp), intent(inout) :: a(lda,*) - real(qp), intent(in) :: x(*), y(*) + real(${rk}$), intent(inout) :: a(lda,*) + real(${rk}$), intent(in) :: x(*), y(*) ! ===================================================================== ! Local Scalars - real(qp) :: temp1, temp2 + real(${rk}$) :: temp1, temp2 integer(ilp) :: i, info, ix, iy, j, jx, jy, kx, ky ! Intrinsic Functions intrinsic :: max @@ -2530,10 +2531,10 @@ module stdlib_linalg_blas_q end if end if return - end subroutine stdlib_qsyr2 + end subroutine stdlib_${ri}$syr2 - pure subroutine stdlib_qsyr2k(uplo,trans,n,k,alpha,a,lda,b,ldb,beta,c,ldc) + pure subroutine stdlib_${ri}$syr2k(uplo,trans,n,k,alpha,a,lda,b,ldb,beta,c,ldc) !! DSYR2K: performs one of the symmetric rank 2k operations !! C := alpha*A*B**T + alpha*B*A**T + beta*C, !! or @@ -2545,17 +2546,17 @@ module stdlib_linalg_blas_q ! -- reference blas is a software package provided by univ. of tennessee, -- ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments - real(qp), intent(in) :: alpha, beta + real(${rk}$), intent(in) :: alpha, beta integer(ilp), intent(in) :: k, lda, ldb, ldc, n character, intent(in) :: trans, uplo ! Array Arguments - real(qp), intent(in) :: a(lda,*), b(ldb,*) - real(qp), intent(inout) :: c(ldc,*) + real(${rk}$), intent(in) :: a(lda,*), b(ldb,*) + real(${rk}$), intent(inout) :: c(ldc,*) ! ===================================================================== ! Intrinsic Functions intrinsic :: max ! Local Scalars - real(qp) :: temp1, temp2 + real(${rk}$) :: temp1, temp2 integer(ilp) :: i, info, j, l, nrowa logical(lk) :: upper @@ -2705,10 +2706,10 @@ module stdlib_linalg_blas_q end if end if return - end subroutine stdlib_qsyr2k + end subroutine stdlib_${ri}$syr2k - pure subroutine stdlib_qsyrk(uplo,trans,n,k,alpha,a,lda,beta,c,ldc) + pure subroutine stdlib_${ri}$syrk(uplo,trans,n,k,alpha,a,lda,beta,c,ldc) !! DSYRK: performs one of the symmetric rank k operations !! C := alpha*A*A**T + beta*C, !! or @@ -2720,17 +2721,17 @@ module stdlib_linalg_blas_q ! -- reference blas is a software package provided by univ. of tennessee, -- ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments - real(qp), intent(in) :: alpha, beta + real(${rk}$), intent(in) :: alpha, beta integer(ilp), intent(in) :: k, lda, ldc, n character, intent(in) :: trans, uplo ! Array Arguments - real(qp), intent(in) :: a(lda,*) - real(qp), intent(inout) :: c(ldc,*) + real(${rk}$), intent(in) :: a(lda,*) + real(${rk}$), intent(inout) :: c(ldc,*) ! ===================================================================== ! Intrinsic Functions intrinsic :: max ! Local Scalars - real(qp) :: temp + real(${rk}$) :: temp integer(ilp) :: i, info, j, l, nrowa logical(lk) :: upper @@ -2872,10 +2873,10 @@ module stdlib_linalg_blas_q end if end if return - end subroutine stdlib_qsyrk + end subroutine stdlib_${ri}$syrk - pure subroutine stdlib_qtbmv(uplo,trans,diag,n,k,a,lda,x,incx) + pure subroutine stdlib_${ri}$tbmv(uplo,trans,diag,n,k,a,lda,x,incx) !! DTBMV: performs one of the matrix-vector operations !! x := A*x, or x := A**T*x, !! where x is an n element vector and A is an n by n unit, or non-unit, @@ -2887,12 +2888,12 @@ module stdlib_linalg_blas_q integer(ilp), intent(in) :: incx, k, lda, n character, intent(in) :: diag, trans, uplo ! Array Arguments - real(qp), intent(in) :: a(lda,*) - real(qp), intent(inout) :: x(*) + real(${rk}$), intent(in) :: a(lda,*) + real(${rk}$), intent(inout) :: x(*) ! ===================================================================== ! Local Scalars - real(qp) :: temp + real(${rk}$) :: temp integer(ilp) :: i, info, ix, j, jx, kplus1, kx, l logical(lk) :: nounit ! Intrinsic Functions @@ -3055,10 +3056,10 @@ module stdlib_linalg_blas_q end if end if return - end subroutine stdlib_qtbmv + end subroutine stdlib_${ri}$tbmv - pure subroutine stdlib_qtbsv(uplo,trans,diag,n,k,a,lda,x,incx) + pure subroutine stdlib_${ri}$tbsv(uplo,trans,diag,n,k,a,lda,x,incx) !! DTBSV: solves one of the systems of equations !! A*x = b, or A**T*x = b, !! where b and x are n element vectors and A is an n by n unit, or @@ -3073,12 +3074,12 @@ module stdlib_linalg_blas_q integer(ilp), intent(in) :: incx, k, lda, n character, intent(in) :: diag, trans, uplo ! Array Arguments - real(qp), intent(in) :: a(lda,*) - real(qp), intent(inout) :: x(*) + real(${rk}$), intent(in) :: a(lda,*) + real(${rk}$), intent(inout) :: x(*) ! ===================================================================== ! Local Scalars - real(qp) :: temp + real(${rk}$) :: temp integer(ilp) :: i, info, ix, j, jx, kplus1, kx, l logical(lk) :: nounit ! Intrinsic Functions @@ -3241,10 +3242,10 @@ module stdlib_linalg_blas_q end if end if return - end subroutine stdlib_qtbsv + end subroutine stdlib_${ri}$tbsv - pure subroutine stdlib_qtpmv(uplo,trans,diag,n,ap,x,incx) + pure subroutine stdlib_${ri}$tpmv(uplo,trans,diag,n,ap,x,incx) !! DTPMV: performs one of the matrix-vector operations !! x := A*x, or x := A**T*x, !! where x is an n element vector and A is an n by n unit, or non-unit, @@ -3256,12 +3257,12 @@ module stdlib_linalg_blas_q integer(ilp), intent(in) :: incx, n character, intent(in) :: diag, trans, uplo ! Array Arguments - real(qp), intent(in) :: ap(*) - real(qp), intent(inout) :: x(*) + real(${rk}$), intent(in) :: ap(*) + real(${rk}$), intent(inout) :: x(*) ! ===================================================================== ! Local Scalars - real(qp) :: temp + real(${rk}$) :: temp integer(ilp) :: i, info, ix, j, jx, k, kk, kx logical(lk) :: nounit ! test the input parameters. @@ -3423,10 +3424,10 @@ module stdlib_linalg_blas_q end if end if return - end subroutine stdlib_qtpmv + end subroutine stdlib_${ri}$tpmv - pure subroutine stdlib_qtpsv(uplo,trans,diag,n,ap,x,incx) + pure subroutine stdlib_${ri}$tpsv(uplo,trans,diag,n,ap,x,incx) !! DTPSV: solves one of the systems of equations !! A*x = b, or A**T*x = b, !! where b and x are n element vectors and A is an n by n unit, or @@ -3440,12 +3441,12 @@ module stdlib_linalg_blas_q integer(ilp), intent(in) :: incx, n character, intent(in) :: diag, trans, uplo ! Array Arguments - real(qp), intent(in) :: ap(*) - real(qp), intent(inout) :: x(*) + real(${rk}$), intent(in) :: ap(*) + real(${rk}$), intent(inout) :: x(*) ! ===================================================================== ! Local Scalars - real(qp) :: temp + real(${rk}$) :: temp integer(ilp) :: i, info, ix, j, jx, k, kk, kx logical(lk) :: nounit ! test the input parameters. @@ -3607,10 +3608,10 @@ module stdlib_linalg_blas_q end if end if return - end subroutine stdlib_qtpsv + end subroutine stdlib_${ri}$tpsv - pure subroutine stdlib_qtrmm(side,uplo,transa,diag,m,n,alpha,a,lda,b,ldb) + pure subroutine stdlib_${ri}$trmm(side,uplo,transa,diag,m,n,alpha,a,lda,b,ldb) !! DTRMM: performs one of the matrix-matrix operations !! B := alpha*op( A )*B, or B := alpha*B*op( A ), !! where alpha is a scalar, B is an m by n matrix, A is a unit, or @@ -3620,17 +3621,17 @@ module stdlib_linalg_blas_q ! -- reference blas is a software package provided by univ. of tennessee, -- ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments - real(qp), intent(in) :: alpha + real(${rk}$), intent(in) :: alpha integer(ilp), intent(in) :: lda, ldb, m, n character, intent(in) :: diag, side, transa, uplo ! Array Arguments - real(qp), intent(in) :: a(lda,*) - real(qp), intent(inout) :: b(ldb,*) + real(${rk}$), intent(in) :: a(lda,*) + real(${rk}$), intent(inout) :: b(ldb,*) ! ===================================================================== ! Intrinsic Functions intrinsic :: max ! Local Scalars - real(qp) :: temp + real(${rk}$) :: temp integer(ilp) :: i, info, j, k, nrowa logical(lk) :: lside, nounit, upper @@ -3813,10 +3814,10 @@ module stdlib_linalg_blas_q end if end if return - end subroutine stdlib_qtrmm + end subroutine stdlib_${ri}$trmm - pure subroutine stdlib_qtrmv(uplo,trans,diag,n,a,lda,x,incx) + pure subroutine stdlib_${ri}$trmv(uplo,trans,diag,n,a,lda,x,incx) !! DTRMV: performs one of the matrix-vector operations !! x := A*x, or x := A**T*x, !! where x is an n element vector and A is an n by n unit, or non-unit, @@ -3828,12 +3829,12 @@ module stdlib_linalg_blas_q integer(ilp), intent(in) :: incx, lda, n character, intent(in) :: diag, trans, uplo ! Array Arguments - real(qp), intent(in) :: a(lda,*) - real(qp), intent(inout) :: x(*) + real(${rk}$), intent(in) :: a(lda,*) + real(${rk}$), intent(inout) :: x(*) ! ===================================================================== ! Local Scalars - real(qp) :: temp + real(${rk}$) :: temp integer(ilp) :: i, info, ix, j, jx, kx logical(lk) :: nounit ! Intrinsic Functions @@ -3979,10 +3980,10 @@ module stdlib_linalg_blas_q end if end if return - end subroutine stdlib_qtrmv + end subroutine stdlib_${ri}$trmv - pure subroutine stdlib_qtrsm(side,uplo,transa,diag,m,n,alpha,a,lda,b,ldb) + pure subroutine stdlib_${ri}$trsm(side,uplo,transa,diag,m,n,alpha,a,lda,b,ldb) !! DTRSM: solves one of the matrix equations !! op( A )*X = alpha*B, or X*op( A ) = alpha*B, !! where alpha is a scalar, X and B are m by n matrices, A is a unit, or @@ -3993,17 +3994,17 @@ module stdlib_linalg_blas_q ! -- reference blas is a software package provided by univ. of tennessee, -- ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments - real(qp), intent(in) :: alpha + real(${rk}$), intent(in) :: alpha integer(ilp), intent(in) :: lda, ldb, m, n character, intent(in) :: diag, side, transa, uplo ! Array Arguments - real(qp), intent(in) :: a(lda,*) - real(qp), intent(inout) :: b(ldb,*) + real(${rk}$), intent(in) :: a(lda,*) + real(${rk}$), intent(inout) :: b(ldb,*) ! ===================================================================== ! Intrinsic Functions intrinsic :: max ! Local Scalars - real(qp) :: temp + real(${rk}$) :: temp integer(ilp) :: i, info, j, k, nrowa logical(lk) :: lside, nounit, upper @@ -4210,10 +4211,10 @@ module stdlib_linalg_blas_q end if end if return - end subroutine stdlib_qtrsm + end subroutine stdlib_${ri}$trsm - pure subroutine stdlib_qtrsv(uplo,trans,diag,n,a,lda,x,incx) + pure subroutine stdlib_${ri}$trsv(uplo,trans,diag,n,a,lda,x,incx) !! DTRSV: solves one of the systems of equations !! A*x = b, or A**T*x = b, !! where b and x are n element vectors and A is an n by n unit, or @@ -4227,12 +4228,12 @@ module stdlib_linalg_blas_q integer(ilp), intent(in) :: incx, lda, n character, intent(in) :: diag, trans, uplo ! Array Arguments - real(qp), intent(in) :: a(lda,*) - real(qp), intent(inout) :: x(*) + real(${rk}$), intent(in) :: a(lda,*) + real(${rk}$), intent(inout) :: x(*) ! ===================================================================== ! Local Scalars - real(qp) :: temp + real(${rk}$) :: temp integer(ilp) :: i, info, ix, j, jx, kx logical(lk) :: nounit ! Intrinsic Functions @@ -4378,10 +4379,10 @@ module stdlib_linalg_blas_q end if end if return - end subroutine stdlib_qtrsv + end subroutine stdlib_${ri}$trsv - pure real(qp) function stdlib_qzasum(n,zx,incx) + pure real(${rk}$) function stdlib_${ri}$zasum(n,zx,incx) !! DZASUM: takes the sum of the (|Re(.)| + |Im(.)|)'s of a complex vector and !! returns a quad precision result. ! -- reference blas level1 routine -- @@ -4390,54 +4391,54 @@ module stdlib_linalg_blas_q ! Scalar Arguments integer(ilp), intent(in) :: incx, n ! Array Arguments - complex(qp), intent(in) :: zx(*) + complex(${rk}$), intent(in) :: zx(*) ! ===================================================================== ! Local Scalars - real(qp) :: stemp + real(${rk}$) :: stemp integer(ilp) :: i, nincx - stdlib_qzasum = zero + stdlib_${ri}$zasum = zero stemp = zero if (n<=0 .or. incx<=0) return if (incx==1) then ! code for increment equal to 1 do i = 1,n - stemp = stemp + stdlib_qcabs1(zx(i)) + stemp = stemp + stdlib_cabs1(zx(i)) end do else ! code for increment not equal to 1 nincx = n*incx do i = 1,nincx,incx - stemp = stemp + stdlib_qcabs1(zx(i)) + stemp = stemp + stdlib_cabs1(zx(i)) end do end if - stdlib_qzasum = stemp + stdlib_${ri}$zasum = stemp return - end function stdlib_qzasum + end function stdlib_${ri}$zasum - pure function stdlib_qznrm2( n, x, incx ) + pure function stdlib_${ri}$znrm2( n, x, incx ) !! DZNRM2: returns the euclidean norm of a vector via the function !! name, so that !! DZNRM2 := sqrt( x**H*x ) - real(qp) :: stdlib_qznrm2 - ! -- reference blas level1 routine (version 3.9.1_qp) -- + real(${rk}$) :: stdlib_${ri}$znrm2 + ! -- reference blas level1 routine (version 3.9.1_${rk}$) -- ! -- reference blas is a software package provided by univ. of tennessee, -- ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! march 2021 ! Constants - integer, parameter :: wp = kind(1._qp) - real(qp), parameter :: maxn = huge(0.0_qp) + integer, parameter :: wp = kind(1._${rk}$) + real(${rk}$), parameter :: maxn = huge(0.0_${rk}$) ! .. blue's scaling constants .. ! Scalar Arguments integer(ilp), intent(in) :: incx, n ! Array Arguments - complex(qp), intent(in) :: x(*) + complex(${rk}$), intent(in) :: x(*) ! Local Scalars integer(ilp) :: i, ix logical(lk) :: notbig - real(qp) :: abig, amed, asml, ax, scl, sumsq, ymax, ymin + real(${rk}$) :: abig, amed, asml, ax, scl, sumsq, ymax, ymin ! quick return if possible - stdlib_qznrm2 = zero + stdlib_${ri}$znrm2 = zero if( n <= 0 ) return scl = one sumsq = zero @@ -4455,7 +4456,7 @@ module stdlib_linalg_blas_q ix = 1 if( incx < 0 ) ix = 1 - (n-1)*incx do i = 1, n - ax = abs(real(x(ix),KIND=qp)) + ax = abs(real(x(ix),KIND=${rk}$)) if (ax > tbig) then abig = abig + (ax*sbig)**2 notbig = .false. @@ -4507,11 +4508,11 @@ module stdlib_linalg_blas_q scl = one sumsq = amed end if - stdlib_qznrm2 = scl*sqrt( sumsq ) + stdlib_${ri}$znrm2 = scl*sqrt( sumsq ) return - end function stdlib_qznrm2 + end function stdlib_${ri}$znrm2 - - -end module stdlib_linalg_blas_q +end module stdlib_linalg_blas_${ri}$ #:endif + +#:endfor diff --git a/src/stdlib_linalg_blas_w.fypp b/src/stdlib_linalg_blas_w.fypp index dafc4a314..332a170fc 100644 --- a/src/stdlib_linalg_blas_w.fypp +++ b/src/stdlib_linalg_blas_w.fypp @@ -1,111 +1,116 @@ #:include "common.fypp" -#:if WITH_QP -module stdlib_linalg_blas_w +#:for ck,ct,ci in CMPLX_KINDS_TYPES +#:if not ck in ["sp","dp"] +module stdlib_linalg_blas_${ci}$ use stdlib_linalg_constants use stdlib_linalg_blas_aux use stdlib_linalg_blas_s use stdlib_linalg_blas_c use stdlib_linalg_blas_d use stdlib_linalg_blas_z - use stdlib_linalg_blas_q + #:for rk,rt,ri in REAL_KINDS_TYPES + #:if not rk in ["sp","dp"] + use stdlib_linalg_blas_${ri}$ + #:endif + #:endfor implicit none(type,external) private - public :: sp,dp,qp,lk,ilp - public :: stdlib_waxpy - public :: stdlib_wcopy - public :: stdlib_wdotc - public :: stdlib_wdotu - public :: stdlib_wdrot - public :: stdlib_wdscal - public :: stdlib_wgbmv - public :: stdlib_wgemm - public :: stdlib_wgemv - public :: stdlib_wgerc - public :: stdlib_wgeru - public :: stdlib_whbmv - public :: stdlib_whemm - public :: stdlib_whemv - public :: stdlib_wher - public :: stdlib_wher2 - public :: stdlib_wher2k - public :: stdlib_wherk - public :: stdlib_whpmv - public :: stdlib_whpr - public :: stdlib_whpr2 - public :: stdlib_wrotg - public :: stdlib_wscal - public :: stdlib_wswap - public :: stdlib_wsymm - public :: stdlib_wsyr2k - public :: stdlib_wsyrk - public :: stdlib_wtbmv - public :: stdlib_wtbsv - public :: stdlib_wtpmv - public :: stdlib_wtpsv - public :: stdlib_wtrmm - public :: stdlib_wtrmv - public :: stdlib_wtrsm - public :: stdlib_wtrsv + public :: sp,dp,${ck}$,lk,ilp + public :: stdlib_${ci}$axpy + public :: stdlib_${ci}$copy + public :: stdlib_${ci}$dotc + public :: stdlib_${ci}$dotu + public :: stdlib_${ci}$drot + public :: stdlib_${ci}$dscal + public :: stdlib_${ci}$gbmv + public :: stdlib_${ci}$gemm + public :: stdlib_${ci}$gemv + public :: stdlib_${ci}$gerc + public :: stdlib_${ci}$geru + public :: stdlib_${ci}$hbmv + public :: stdlib_${ci}$hemm + public :: stdlib_${ci}$hemv + public :: stdlib_${ci}$her + public :: stdlib_${ci}$her2 + public :: stdlib_${ci}$her2k + public :: stdlib_${ci}$herk + public :: stdlib_${ci}$hpmv + public :: stdlib_${ci}$hpr + public :: stdlib_${ci}$hpr2 + public :: stdlib_${ci}$rotg + public :: stdlib_${ci}$scal + public :: stdlib_${ci}$swap + public :: stdlib_${ci}$symm + public :: stdlib_${ci}$syr2k + public :: stdlib_${ci}$syrk + public :: stdlib_${ci}$tbmv + public :: stdlib_${ci}$tbsv + public :: stdlib_${ci}$tpmv + public :: stdlib_${ci}$tpsv + public :: stdlib_${ci}$trmm + public :: stdlib_${ci}$trmv + public :: stdlib_${ci}$trsm + public :: stdlib_${ci}$trsv ! 128-bit real constants - real(qp), parameter, private :: negone = -1.00_qp - real(qp), parameter, private :: zero = 0.00_qp - real(qp), parameter, private :: half = 0.50_qp - real(qp), parameter, private :: one = 1.00_qp - real(qp), parameter, private :: two = 2.00_qp - real(qp), parameter, private :: three = 3.00_qp - real(qp), parameter, private :: four = 4.00_qp - real(qp), parameter, private :: eight = 8.00_qp - real(qp), parameter, private :: ten = 10.00_qp + real(${ck}$), parameter, private :: negone = -1.00_${ck}$ + real(${ck}$), parameter, private :: zero = 0.00_${ck}$ + real(${ck}$), parameter, private :: half = 0.50_${ck}$ + real(${ck}$), parameter, private :: one = 1.00_${ck}$ + real(${ck}$), parameter, private :: two = 2.00_${ck}$ + real(${ck}$), parameter, private :: three = 3.00_${ck}$ + real(${ck}$), parameter, private :: four = 4.00_${ck}$ + real(${ck}$), parameter, private :: eight = 8.00_${ck}$ + real(${ck}$), parameter, private :: ten = 10.00_${ck}$ ! 128-bit complex constants - complex(qp), parameter, private :: czero = ( 0.0_qp,0.0_qp) - complex(qp), parameter, private :: chalf = ( 0.5_qp,0.0_qp) - complex(qp), parameter, private :: cone = ( 1.0_qp,0.0_qp) - complex(qp), parameter, private :: cnegone = (-1.0_qp,0.0_qp) + complex(${ck}$), parameter, private :: czero = ( 0.0_${ck}$,0.0_${ck}$) + complex(${ck}$), parameter, private :: chalf = ( 0.5_${ck}$,0.0_${ck}$) + complex(${ck}$), parameter, private :: cone = ( 1.0_${ck}$,0.0_${ck}$) + complex(${ck}$), parameter, private :: cnegone = (-1.0_${ck}$,0.0_${ck}$) ! 128-bit scaling constants integer, parameter, private :: maxexp = maxexponent(zero) integer, parameter, private :: minexp = minexponent(zero) - real(qp), parameter, private :: rradix = real(radix(zero),qp) - real(qp), parameter, private :: ulp = epsilon(zero) - real(qp), parameter, private :: eps = ulp*half - real(qp), parameter, private :: safmin = rradix**max(minexp-1,1-maxexp) - real(qp), parameter, private :: safmax = one/safmin - real(qp), parameter, private :: smlnum = safmin/ulp - real(qp), parameter, private :: bignum = safmax*ulp - real(qp), parameter, private :: rtmin = sqrt(smlnum) - real(qp), parameter, private :: rtmax = sqrt(bignum) + real(${ck}$), parameter, private :: rradix = real(radix(zero),${ck}$) + real(${ck}$), parameter, private :: ulp = epsilon(zero) + real(${ck}$), parameter, private :: eps = ulp*half + real(${ck}$), parameter, private :: safmin = rradix**max(minexp-1,1-maxexp) + real(${ck}$), parameter, private :: safmax = one/safmin + real(${ck}$), parameter, private :: smlnum = safmin/ulp + real(${ck}$), parameter, private :: bignum = safmax*ulp + real(${ck}$), parameter, private :: rtmin = sqrt(smlnum) + real(${ck}$), parameter, private :: rtmax = sqrt(bignum) ! 128-bit Blue's scaling constants ! ssml>=1/s and sbig==1/S with s,S as defined in https://doi.org/10.1145/355769.355771 - real(qp), parameter, private :: tsml = rradix**ceiling((minexp-1)*half) - real(qp), parameter, private :: tbig = rradix**floor((maxexp-digits(zero)+1)*half) - real(qp), parameter, private :: ssml = rradix**(-floor((minexp-digits(zero))*half)) - real(qp), parameter, private :: sbig = rradix**(-ceiling((maxexp+digits(zero)-1)*half)) + real(${ck}$), parameter, private :: tsml = rradix**ceiling((minexp-1)*half) + real(${ck}$), parameter, private :: tbig = rradix**floor((maxexp-digits(zero)+1)*half) + real(${ck}$), parameter, private :: ssml = rradix**(-floor((minexp-digits(zero))*half)) + real(${ck}$), parameter, private :: sbig = rradix**(-ceiling((maxexp+digits(zero)-1)*half)) contains - pure subroutine stdlib_waxpy(n,za,zx,incx,zy,incy) + pure subroutine stdlib_${ci}$axpy(n,za,zx,incx,zy,incy) !! ZAXPY: constant times a vector plus a vector. ! -- reference blas level1 routine -- ! -- reference blas is a software package provided by univ. of tennessee, -- ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments - complex(qp), intent(in) :: za + complex(${ck}$), intent(in) :: za integer(ilp), intent(in) :: incx, incy, n ! Array Arguments - complex(qp), intent(in) :: zx(*) - complex(qp), intent(inout) :: zy(*) + complex(${ck}$), intent(in) :: zx(*) + complex(${ck}$), intent(inout) :: zy(*) ! ===================================================================== ! Local Scalars integer(ilp) :: i, ix, iy if (n<=0) return - if (stdlib_qcabs1(za)==0.0_qp) return + if (stdlib_cabs1(za)==0.0_${ck}$) return if (incx==1 .and. incy==1) then ! code for both increments equal to 1 do i = 1,n @@ -125,10 +130,10 @@ module stdlib_linalg_blas_w end do end if return - end subroutine stdlib_waxpy + end subroutine stdlib_${ci}$axpy - pure subroutine stdlib_wcopy(n,zx,incx,zy,incy) + pure subroutine stdlib_${ci}$copy(n,zx,incx,zy,incy) !! ZCOPY: copies a vector, x, to a vector, y. ! -- reference blas level1 routine -- ! -- reference blas is a software package provided by univ. of tennessee, -- @@ -136,8 +141,8 @@ module stdlib_linalg_blas_w ! Scalar Arguments integer(ilp), intent(in) :: incx, incy, n ! Array Arguments - complex(qp), intent(in) :: zx(*) - complex(qp), intent(out) :: zy(*) + complex(${ck}$), intent(in) :: zx(*) + complex(${ck}$), intent(out) :: zy(*) ! ===================================================================== ! Local Scalars integer(ilp) :: i, ix, iy @@ -161,10 +166,10 @@ module stdlib_linalg_blas_w end do end if return - end subroutine stdlib_wcopy + end subroutine stdlib_${ci}$copy - pure complex(qp) function stdlib_wdotc(n,zx,incx,zy,incy) + pure complex(${ck}$) function stdlib_${ci}$dotc(n,zx,incx,zy,incy) !! ZDOTC: forms the dot product of two complex vectors !! ZDOTC = X^H * Y ! -- reference blas level1 routine -- @@ -173,15 +178,15 @@ module stdlib_linalg_blas_w ! Scalar Arguments integer(ilp), intent(in) :: incx, incy, n ! Array Arguments - complex(qp), intent(in) :: zx(*), zy(*) + complex(${ck}$), intent(in) :: zx(*), zy(*) ! ===================================================================== ! Local Scalars - complex(qp) :: ztemp + complex(${ck}$) :: ztemp integer(ilp) :: i, ix, iy ! Intrinsic Functions intrinsic :: conjg - ztemp = (0.0_qp,0.0_qp) - stdlib_wdotc = (0.0_qp,0.0_qp) + ztemp = (0.0_${ck}$,0.0_${ck}$) + stdlib_${ci}$dotc = (0.0_${ck}$,0.0_${ck}$) if (n<=0) return if (incx==1 .and. incy==1) then ! code for both increments equal to 1 @@ -201,12 +206,12 @@ module stdlib_linalg_blas_w iy = iy + incy end do end if - stdlib_wdotc = ztemp + stdlib_${ci}$dotc = ztemp return - end function stdlib_wdotc + end function stdlib_${ci}$dotc - pure complex(qp) function stdlib_wdotu(n,zx,incx,zy,incy) + pure complex(${ck}$) function stdlib_${ci}$dotu(n,zx,incx,zy,incy) !! ZDOTU: forms the dot product of two complex vectors !! ZDOTU = X^T * Y ! -- reference blas level1 routine -- @@ -215,13 +220,13 @@ module stdlib_linalg_blas_w ! Scalar Arguments integer(ilp), intent(in) :: incx, incy, n ! Array Arguments - complex(qp), intent(in) :: zx(*), zy(*) + complex(${ck}$), intent(in) :: zx(*), zy(*) ! ===================================================================== ! Local Scalars - complex(qp) :: ztemp + complex(${ck}$) :: ztemp integer(ilp) :: i, ix, iy - ztemp = (0.0_qp,0.0_qp) - stdlib_wdotu = (0.0_qp,0.0_qp) + ztemp = (0.0_${ck}$,0.0_${ck}$) + stdlib_${ci}$dotu = (0.0_${ck}$,0.0_${ck}$) if (n<=0) return if (incx==1 .and. incy==1) then ! code for both increments equal to 1 @@ -241,12 +246,12 @@ module stdlib_linalg_blas_w iy = iy + incy end do end if - stdlib_wdotu = ztemp + stdlib_${ci}$dotu = ztemp return - end function stdlib_wdotu + end function stdlib_${ci}$dotu - pure subroutine stdlib_wdrot( n, zx, incx, zy, incy, c, s ) + pure subroutine stdlib_${ci}$drot( n, zx, incx, zy, incy, c, s ) !! Applies a plane rotation, where the cos and sin (c and s) are real !! and the vectors cx and cy are complex. !! jack dongarra, linpack, 3/11/78. @@ -255,13 +260,13 @@ module stdlib_linalg_blas_w ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments integer(ilp), intent(in) :: incx, incy, n - real(qp), intent(in) :: c, s + real(${ck}$), intent(in) :: c, s ! Array Arguments - complex(qp), intent(inout) :: zx(*), zy(*) + complex(${ck}$), intent(inout) :: zx(*), zy(*) ! ===================================================================== ! Local Scalars integer(ilp) :: i, ix, iy - complex(qp) :: ctemp + complex(${ck}$) :: ctemp ! Executable Statements if( n<=0 )return if( incx==1 .and. incy==1 ) then @@ -287,19 +292,19 @@ module stdlib_linalg_blas_w end do end if return - end subroutine stdlib_wdrot + end subroutine stdlib_${ci}$drot - pure subroutine stdlib_wdscal(n,da,zx,incx) + pure subroutine stdlib_${ci}$dscal(n,da,zx,incx) !! ZDSCAL: scales a vector by a constant. ! -- reference blas level1 routine -- ! -- reference blas is a software package provided by univ. of tennessee, -- ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments - real(qp), intent(in) :: da + real(${ck}$), intent(in) :: da integer(ilp), intent(in) :: incx, n ! Array Arguments - complex(qp), intent(inout) :: zx(*) + complex(${ck}$), intent(inout) :: zx(*) ! ===================================================================== ! Local Scalars integer(ilp) :: i, nincx @@ -309,20 +314,20 @@ module stdlib_linalg_blas_w if (incx==1) then ! code for increment equal to 1 do i = 1,n - zx(i) = cmplx(da,0.0_qp,KIND=qp)*zx(i) + zx(i) = cmplx(da,0.0_${ck}$,KIND=${ck}$)*zx(i) end do else ! code for increment not equal to 1 nincx = n*incx do i = 1,nincx,incx - zx(i) = cmplx(da,0.0_qp,KIND=qp)*zx(i) + zx(i) = cmplx(da,0.0_${ck}$,KIND=${ck}$)*zx(i) end do end if return - end subroutine stdlib_wdscal + end subroutine stdlib_${ci}$dscal - pure subroutine stdlib_wgbmv(trans,m,n,kl,ku,alpha,a,lda,x,incx,beta,y,incy) + pure subroutine stdlib_${ci}$gbmv(trans,m,n,kl,ku,alpha,a,lda,x,incx,beta,y,incy) !! ZGBMV: performs one of the matrix-vector operations !! y := alpha*A*x + beta*y, or y := alpha*A**T*x + beta*y, or !! y := alpha*A**H*x + beta*y, @@ -332,17 +337,17 @@ module stdlib_linalg_blas_w ! -- reference blas is a software package provided by univ. of tennessee, -- ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments - complex(qp), intent(in) :: alpha, beta + complex(${ck}$), intent(in) :: alpha, beta integer(ilp), intent(in) :: incx, incy, kl, ku, lda, m, n character, intent(in) :: trans ! Array Arguments - complex(qp), intent(in) :: a(lda,*), x(*) - complex(qp), intent(inout) :: y(*) + complex(${ck}$), intent(in) :: a(lda,*), x(*) + complex(${ck}$), intent(inout) :: y(*) ! ===================================================================== ! Local Scalars - complex(qp) :: temp + complex(${ck}$) :: temp integer(ilp) :: i, info, ix, iy, j, jx, jy, k, kup1, kx, ky, lenx, leny logical(lk) :: noconj ! Intrinsic Functions @@ -491,10 +496,10 @@ module stdlib_linalg_blas_w end if end if return - end subroutine stdlib_wgbmv + end subroutine stdlib_${ci}$gbmv - pure subroutine stdlib_wgemm(transa,transb,m,n,k,alpha,a,lda,b,ldb,beta,c,ldc) + pure subroutine stdlib_${ci}$gemm(transa,transb,m,n,k,alpha,a,lda,b,ldb,beta,c,ldc) !! ZGEMM: performs one of the matrix-matrix operations !! C := alpha*op( A )*op( B ) + beta*C, !! where op( X ) is one of @@ -505,17 +510,17 @@ module stdlib_linalg_blas_w ! -- reference blas is a software package provided by univ. of tennessee, -- ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments - complex(qp), intent(in) :: alpha, beta + complex(${ck}$), intent(in) :: alpha, beta integer(ilp), intent(in) :: k, lda, ldb, ldc, m, n character, intent(in) :: transa, transb ! Array Arguments - complex(qp), intent(in) :: a(lda,*), b(ldb,*) - complex(qp), intent(inout) :: c(ldc,*) + complex(${ck}$), intent(in) :: a(lda,*), b(ldb,*) + complex(${ck}$), intent(inout) :: c(ldc,*) ! ===================================================================== ! Intrinsic Functions intrinsic :: conjg,max ! Local Scalars - complex(qp) :: temp + complex(${ck}$) :: temp integer(ilp) :: i, info, j, l, nrowa, nrowb logical(lk) :: conja, conjb, nota, notb @@ -740,10 +745,10 @@ module stdlib_linalg_blas_w end if end if return - end subroutine stdlib_wgemm + end subroutine stdlib_${ci}$gemm - pure subroutine stdlib_wgemv(trans,m,n,alpha,a,lda,x,incx,beta,y,incy) + pure subroutine stdlib_${ci}$gemv(trans,m,n,alpha,a,lda,x,incx,beta,y,incy) !! ZGEMV: performs one of the matrix-vector operations !! y := alpha*A*x + beta*y, or y := alpha*A**T*x + beta*y, or !! y := alpha*A**H*x + beta*y, @@ -753,17 +758,17 @@ module stdlib_linalg_blas_w ! -- reference blas is a software package provided by univ. of tennessee, -- ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments - complex(qp), intent(in) :: alpha, beta + complex(${ck}$), intent(in) :: alpha, beta integer(ilp), intent(in) :: incx, incy, lda, m, n character, intent(in) :: trans ! Array Arguments - complex(qp), intent(in) :: a(lda,*), x(*) - complex(qp), intent(inout) :: y(*) + complex(${ck}$), intent(in) :: a(lda,*), x(*) + complex(${ck}$), intent(inout) :: y(*) ! ===================================================================== ! Local Scalars - complex(qp) :: temp + complex(${ck}$) :: temp integer(ilp) :: i, info, ix, iy, j, jx, jy, kx, ky, lenx, leny logical(lk) :: noconj ! Intrinsic Functions @@ -901,10 +906,10 @@ module stdlib_linalg_blas_w end if end if return - end subroutine stdlib_wgemv + end subroutine stdlib_${ci}$gemv - pure subroutine stdlib_wgerc(m,n,alpha,x,incx,y,incy,a,lda) + pure subroutine stdlib_${ci}$gerc(m,n,alpha,x,incx,y,incy,a,lda) !! ZGERC: performs the rank 1 operation !! A := alpha*x*y**H + A, !! where alpha is a scalar, x is an m element vector, y is an n element @@ -913,15 +918,15 @@ module stdlib_linalg_blas_w ! -- reference blas is a software package provided by univ. of tennessee, -- ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments - complex(qp), intent(in) :: alpha + complex(${ck}$), intent(in) :: alpha integer(ilp), intent(in) :: incx, incy, lda, m, n ! Array Arguments - complex(qp), intent(inout) :: a(lda,*) - complex(qp), intent(in) :: x(*), y(*) + complex(${ck}$), intent(inout) :: a(lda,*) + complex(${ck}$), intent(in) :: x(*), y(*) ! ===================================================================== ! Local Scalars - complex(qp) :: temp + complex(${ck}$) :: temp integer(ilp) :: i, info, ix, j, jy, kx ! Intrinsic Functions intrinsic :: conjg,max @@ -980,10 +985,10 @@ module stdlib_linalg_blas_w end do end if return - end subroutine stdlib_wgerc + end subroutine stdlib_${ci}$gerc - pure subroutine stdlib_wgeru(m,n,alpha,x,incx,y,incy,a,lda) + pure subroutine stdlib_${ci}$geru(m,n,alpha,x,incx,y,incy,a,lda) !! ZGERU: performs the rank 1 operation !! A := alpha*x*y**T + A, !! where alpha is a scalar, x is an m element vector, y is an n element @@ -992,15 +997,15 @@ module stdlib_linalg_blas_w ! -- reference blas is a software package provided by univ. of tennessee, -- ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments - complex(qp), intent(in) :: alpha + complex(${ck}$), intent(in) :: alpha integer(ilp), intent(in) :: incx, incy, lda, m, n ! Array Arguments - complex(qp), intent(inout) :: a(lda,*) - complex(qp), intent(in) :: x(*), y(*) + complex(${ck}$), intent(inout) :: a(lda,*) + complex(${ck}$), intent(in) :: x(*), y(*) ! ===================================================================== ! Local Scalars - complex(qp) :: temp + complex(${ck}$) :: temp integer(ilp) :: i, info, ix, j, jy, kx ! Intrinsic Functions intrinsic :: max @@ -1059,10 +1064,10 @@ module stdlib_linalg_blas_w end do end if return - end subroutine stdlib_wgeru + end subroutine stdlib_${ci}$geru - pure subroutine stdlib_whbmv(uplo,n,k,alpha,a,lda,x,incx,beta,y,incy) + pure subroutine stdlib_${ci}$hbmv(uplo,n,k,alpha,a,lda,x,incx,beta,y,incy) !! ZHBMV: performs the matrix-vector operation !! y := alpha*A*x + beta*y, !! where alpha and beta are scalars, x and y are n element vectors and @@ -1071,17 +1076,17 @@ module stdlib_linalg_blas_w ! -- reference blas is a software package provided by univ. of tennessee, -- ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments - complex(qp), intent(in) :: alpha, beta + complex(${ck}$), intent(in) :: alpha, beta integer(ilp), intent(in) :: incx, incy, k, lda, n character, intent(in) :: uplo ! Array Arguments - complex(qp), intent(in) :: a(lda,*), x(*) - complex(qp), intent(inout) :: y(*) + complex(${ck}$), intent(in) :: a(lda,*), x(*) + complex(${ck}$), intent(inout) :: y(*) ! ===================================================================== ! Local Scalars - complex(qp) :: temp1, temp2 + complex(${ck}$) :: temp1, temp2 integer(ilp) :: i, info, ix, iy, j, jx, jy, kplus1, kx, ky, l ! Intrinsic Functions intrinsic :: real,conjg,max,min @@ -1159,7 +1164,7 @@ module stdlib_linalg_blas_w y(i) = y(i) + temp1*a(l+i,j) temp2 = temp2 + conjg(a(l+i,j))*x(i) end do - y(j) = y(j) + temp1*real(a(kplus1,j),KIND=qp) + alpha*temp2 + y(j) = y(j) + temp1*real(a(kplus1,j),KIND=${ck}$) + alpha*temp2 end do else jx = kx @@ -1176,7 +1181,7 @@ module stdlib_linalg_blas_w ix = ix + incx iy = iy + incy end do - y(jy) = y(jy) + temp1*real(a(kplus1,j),KIND=qp) + alpha*temp2 + y(jy) = y(jy) + temp1*real(a(kplus1,j),KIND=${ck}$) + alpha*temp2 jx = jx + incx jy = jy + incy if (j>k) then @@ -1191,7 +1196,7 @@ module stdlib_linalg_blas_w do j = 1,n temp1 = alpha*x(j) temp2 = czero - y(j) = y(j) + temp1*real(a(1,j),KIND=qp) + y(j) = y(j) + temp1*real(a(1,j),KIND=${ck}$) l = 1 - j do i = j + 1,min(n,j+k) y(i) = y(i) + temp1*a(l+i,j) @@ -1205,7 +1210,7 @@ module stdlib_linalg_blas_w do j = 1,n temp1 = alpha*x(jx) temp2 = czero - y(jy) = y(jy) + temp1*real(a(1,j),KIND=qp) + y(jy) = y(jy) + temp1*real(a(1,j),KIND=${ck}$) l = 1 - j ix = jx iy = jy @@ -1222,10 +1227,10 @@ module stdlib_linalg_blas_w end if end if return - end subroutine stdlib_whbmv + end subroutine stdlib_${ci}$hbmv - pure subroutine stdlib_whemm(side,uplo,m,n,alpha,a,lda,b,ldb,beta,c,ldc) + pure subroutine stdlib_${ci}$hemm(side,uplo,m,n,alpha,a,lda,b,ldb,beta,c,ldc) !! ZHEMM: performs one of the matrix-matrix operations !! C := alpha*A*B + beta*C, !! or @@ -1236,17 +1241,17 @@ module stdlib_linalg_blas_w ! -- reference blas is a software package provided by univ. of tennessee, -- ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments - complex(qp), intent(in) :: alpha, beta + complex(${ck}$), intent(in) :: alpha, beta integer(ilp), intent(in) :: lda, ldb, ldc, m, n character, intent(in) :: side, uplo ! Array Arguments - complex(qp), intent(in) :: a(lda,*), b(ldb,*) - complex(qp), intent(inout) :: c(ldc,*) + complex(${ck}$), intent(in) :: a(lda,*), b(ldb,*) + complex(${ck}$), intent(inout) :: c(ldc,*) ! ===================================================================== ! Intrinsic Functions intrinsic :: real,conjg,max ! Local Scalars - complex(qp) :: temp1, temp2 + complex(${ck}$) :: temp1, temp2 integer(ilp) :: i, info, j, k, nrowa logical(lk) :: upper @@ -1311,9 +1316,9 @@ module stdlib_linalg_blas_w temp2 = temp2 + b(k,j)*conjg(a(k,i)) end do if (beta==czero) then - c(i,j) = temp1*real(a(i,i),KIND=qp) + alpha*temp2 + c(i,j) = temp1*real(a(i,i),KIND=${ck}$) + alpha*temp2 else - c(i,j) = beta*c(i,j) + temp1*real(a(i,i),KIND=qp) +& + c(i,j) = beta*c(i,j) + temp1*real(a(i,i),KIND=${ck}$) +& alpha*temp2 end if end do @@ -1328,9 +1333,9 @@ module stdlib_linalg_blas_w temp2 = temp2 + b(k,j)*conjg(a(k,i)) end do if (beta==czero) then - c(i,j) = temp1*real(a(i,i),KIND=qp) + alpha*temp2 + c(i,j) = temp1*real(a(i,i),KIND=${ck}$) + alpha*temp2 else - c(i,j) = beta*c(i,j) + temp1*real(a(i,i),KIND=qp) +& + c(i,j) = beta*c(i,j) + temp1*real(a(i,i),KIND=${ck}$) +& alpha*temp2 end if end do @@ -1339,7 +1344,7 @@ module stdlib_linalg_blas_w else ! form c := alpha*b*a + beta*c. loop_170: do j = 1,n - temp1 = alpha*real(a(j,j),KIND=qp) + temp1 = alpha*real(a(j,j),KIND=${ck}$) if (beta==czero) then do i = 1,m c(i,j) = temp1*b(i,j) @@ -1372,10 +1377,10 @@ module stdlib_linalg_blas_w end do loop_170 end if return - end subroutine stdlib_whemm + end subroutine stdlib_${ci}$hemm - pure subroutine stdlib_whemv(uplo,n,alpha,a,lda,x,incx,beta,y,incy) + pure subroutine stdlib_${ci}$hemv(uplo,n,alpha,a,lda,x,incx,beta,y,incy) !! ZHEMV: performs the matrix-vector operation !! y := alpha*A*x + beta*y, !! where alpha and beta are scalars, x and y are n element vectors and @@ -1384,17 +1389,17 @@ module stdlib_linalg_blas_w ! -- reference blas is a software package provided by univ. of tennessee, -- ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments - complex(qp), intent(in) :: alpha, beta + complex(${ck}$), intent(in) :: alpha, beta integer(ilp), intent(in) :: incx, incy, lda, n character, intent(in) :: uplo ! Array Arguments - complex(qp), intent(in) :: a(lda,*), x(*) - complex(qp), intent(inout) :: y(*) + complex(${ck}$), intent(in) :: a(lda,*), x(*) + complex(${ck}$), intent(inout) :: y(*) ! ===================================================================== ! Local Scalars - complex(qp) :: temp1, temp2 + complex(${ck}$) :: temp1, temp2 integer(ilp) :: i, info, ix, iy, j, jx, jy, kx, ky ! Intrinsic Functions intrinsic :: real,conjg,max @@ -1469,7 +1474,7 @@ module stdlib_linalg_blas_w y(i) = y(i) + temp1*a(i,j) temp2 = temp2 + conjg(a(i,j))*x(i) end do - y(j) = y(j) + temp1*real(a(j,j),KIND=qp) + alpha*temp2 + y(j) = y(j) + temp1*real(a(j,j),KIND=${ck}$) + alpha*temp2 end do else jx = kx @@ -1485,7 +1490,7 @@ module stdlib_linalg_blas_w ix = ix + incx iy = iy + incy end do - y(jy) = y(jy) + temp1*real(a(j,j),KIND=qp) + alpha*temp2 + y(jy) = y(jy) + temp1*real(a(j,j),KIND=${ck}$) + alpha*temp2 jx = jx + incx jy = jy + incy end do @@ -1496,7 +1501,7 @@ module stdlib_linalg_blas_w do j = 1,n temp1 = alpha*x(j) temp2 = czero - y(j) = y(j) + temp1*real(a(j,j),KIND=qp) + y(j) = y(j) + temp1*real(a(j,j),KIND=${ck}$) do i = j + 1,n y(i) = y(i) + temp1*a(i,j) temp2 = temp2 + conjg(a(i,j))*x(i) @@ -1509,7 +1514,7 @@ module stdlib_linalg_blas_w do j = 1,n temp1 = alpha*x(jx) temp2 = czero - y(jy) = y(jy) + temp1*real(a(j,j),KIND=qp) + y(jy) = y(jy) + temp1*real(a(j,j),KIND=${ck}$) ix = jx iy = jy do i = j + 1,n @@ -1525,10 +1530,10 @@ module stdlib_linalg_blas_w end if end if return - end subroutine stdlib_whemv + end subroutine stdlib_${ci}$hemv - pure subroutine stdlib_wher(uplo,n,alpha,x,incx,a,lda) + pure subroutine stdlib_${ci}$her(uplo,n,alpha,x,incx,a,lda) !! ZHER: performs the hermitian rank 1 operation !! A := alpha*x*x**H + A, !! where alpha is a real scalar, x is an n element vector and A is an @@ -1537,16 +1542,16 @@ module stdlib_linalg_blas_w ! -- reference blas is a software package provided by univ. of tennessee, -- ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments - real(qp), intent(in) :: alpha + real(${ck}$), intent(in) :: alpha integer(ilp), intent(in) :: incx, lda, n character, intent(in) :: uplo ! Array Arguments - complex(qp), intent(inout) :: a(lda,*) - complex(qp), intent(in) :: x(*) + complex(${ck}$), intent(inout) :: a(lda,*) + complex(${ck}$), intent(in) :: x(*) ! ===================================================================== ! Local Scalars - complex(qp) :: temp + complex(${ck}$) :: temp integer(ilp) :: i, info, ix, j, jx, kx ! Intrinsic Functions intrinsic :: real,conjg,max @@ -1566,7 +1571,7 @@ module stdlib_linalg_blas_w return end if ! quick return if possible. - if ((n==0) .or. (alpha==real(czero,KIND=qp))) return + if ((n==0) .or. (alpha==real(czero,KIND=${ck}$))) return ! set the start point in x if the increment is not unity. if (incx<=0) then kx = 1 - (n-1)*incx @@ -1585,9 +1590,9 @@ module stdlib_linalg_blas_w do i = 1,j - 1 a(i,j) = a(i,j) + x(i)*temp end do - a(j,j) = real(a(j,j),KIND=qp) + real(x(j)*temp,KIND=qp) + a(j,j) = real(a(j,j),KIND=${ck}$) + real(x(j)*temp,KIND=${ck}$) else - a(j,j) = real(a(j,j),KIND=qp) + a(j,j) = real(a(j,j),KIND=${ck}$) end if end do else @@ -1600,9 +1605,9 @@ module stdlib_linalg_blas_w a(i,j) = a(i,j) + x(ix)*temp ix = ix + incx end do - a(j,j) = real(a(j,j),KIND=qp) + real(x(jx)*temp,KIND=qp) + a(j,j) = real(a(j,j),KIND=${ck}$) + real(x(jx)*temp,KIND=${ck}$) else - a(j,j) = real(a(j,j),KIND=qp) + a(j,j) = real(a(j,j),KIND=${ck}$) end if jx = jx + incx end do @@ -1613,12 +1618,12 @@ module stdlib_linalg_blas_w do j = 1,n if (x(j)/=czero) then temp = alpha*conjg(x(j)) - a(j,j) = real(a(j,j),KIND=qp) + real(temp*x(j),KIND=qp) + a(j,j) = real(a(j,j),KIND=${ck}$) + real(temp*x(j),KIND=${ck}$) do i = j + 1,n a(i,j) = a(i,j) + x(i)*temp end do else - a(j,j) = real(a(j,j),KIND=qp) + a(j,j) = real(a(j,j),KIND=${ck}$) end if end do else @@ -1626,24 +1631,24 @@ module stdlib_linalg_blas_w do j = 1,n if (x(jx)/=czero) then temp = alpha*conjg(x(jx)) - a(j,j) = real(a(j,j),KIND=qp) + real(temp*x(jx),KIND=qp) + a(j,j) = real(a(j,j),KIND=${ck}$) + real(temp*x(jx),KIND=${ck}$) ix = jx do i = j + 1,n ix = ix + incx a(i,j) = a(i,j) + x(ix)*temp end do else - a(j,j) = real(a(j,j),KIND=qp) + a(j,j) = real(a(j,j),KIND=${ck}$) end if jx = jx + incx end do end if end if return - end subroutine stdlib_wher + end subroutine stdlib_${ci}$her - pure subroutine stdlib_wher2(uplo,n,alpha,x,incx,y,incy,a,lda) + pure subroutine stdlib_${ci}$her2(uplo,n,alpha,x,incx,y,incy,a,lda) !! ZHER2: performs the hermitian rank 2 operation !! A := alpha*x*y**H + conjg( alpha )*y*x**H + A, !! where alpha is a scalar, x and y are n element vectors and A is an n @@ -1652,16 +1657,16 @@ module stdlib_linalg_blas_w ! -- reference blas is a software package provided by univ. of tennessee, -- ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments - complex(qp), intent(in) :: alpha + complex(${ck}$), intent(in) :: alpha integer(ilp), intent(in) :: incx, incy, lda, n character, intent(in) :: uplo ! Array Arguments - complex(qp), intent(inout) :: a(lda,*) - complex(qp), intent(in) :: x(*), y(*) + complex(${ck}$), intent(inout) :: a(lda,*) + complex(${ck}$), intent(in) :: x(*), y(*) ! ===================================================================== ! Local Scalars - complex(qp) :: temp1, temp2 + complex(${ck}$) :: temp1, temp2 integer(ilp) :: i, info, ix, iy, j, jx, jy, kx, ky ! Intrinsic Functions intrinsic :: real,conjg,max @@ -1713,10 +1718,10 @@ module stdlib_linalg_blas_w do i = 1,j - 1 a(i,j) = a(i,j) + x(i)*temp1 + y(i)*temp2 end do - a(j,j) = real(a(j,j),KIND=qp) +real(x(j)*temp1+y(j)*temp2,KIND=qp) + a(j,j) = real(a(j,j),KIND=${ck}$) +real(x(j)*temp1+y(j)*temp2,KIND=${ck}$) else - a(j,j) = real(a(j,j),KIND=qp) + a(j,j) = real(a(j,j),KIND=${ck}$) end if end do else @@ -1731,10 +1736,10 @@ module stdlib_linalg_blas_w ix = ix + incx iy = iy + incy end do - a(j,j) = real(a(j,j),KIND=qp) +real(x(jx)*temp1+y(jy)*temp2,KIND=qp) + a(j,j) = real(a(j,j),KIND=${ck}$) +real(x(jx)*temp1+y(jy)*temp2,KIND=${ck}$) else - a(j,j) = real(a(j,j),KIND=qp) + a(j,j) = real(a(j,j),KIND=${ck}$) end if jx = jx + incx jy = jy + incy @@ -1747,13 +1752,13 @@ module stdlib_linalg_blas_w if ((x(j)/=czero) .or. (y(j)/=czero)) then temp1 = alpha*conjg(y(j)) temp2 = conjg(alpha*x(j)) - a(j,j) = real(a(j,j),KIND=qp) +real(x(j)*temp1+y(j)*temp2,KIND=qp) + a(j,j) = real(a(j,j),KIND=${ck}$) +real(x(j)*temp1+y(j)*temp2,KIND=${ck}$) do i = j + 1,n a(i,j) = a(i,j) + x(i)*temp1 + y(i)*temp2 end do else - a(j,j) = real(a(j,j),KIND=qp) + a(j,j) = real(a(j,j),KIND=${ck}$) end if end do else @@ -1761,7 +1766,7 @@ module stdlib_linalg_blas_w if ((x(jx)/=czero) .or. (y(jy)/=czero)) then temp1 = alpha*conjg(y(jy)) temp2 = conjg(alpha*x(jx)) - a(j,j) = real(a(j,j),KIND=qp) +real(x(jx)*temp1+y(jy)*temp2,KIND=qp) + a(j,j) = real(a(j,j),KIND=${ck}$) +real(x(jx)*temp1+y(jy)*temp2,KIND=${ck}$) ix = jx iy = jy @@ -1771,7 +1776,7 @@ module stdlib_linalg_blas_w a(i,j) = a(i,j) + x(ix)*temp1 + y(iy)*temp2 end do else - a(j,j) = real(a(j,j),KIND=qp) + a(j,j) = real(a(j,j),KIND=${ck}$) end if jx = jx + incx jy = jy + incy @@ -1779,10 +1784,10 @@ module stdlib_linalg_blas_w end if end if return - end subroutine stdlib_wher2 + end subroutine stdlib_${ci}$her2 - pure subroutine stdlib_wher2k(uplo,trans,n,k,alpha,a,lda,b,ldb,beta,c,ldc) + pure subroutine stdlib_${ci}$her2k(uplo,trans,n,k,alpha,a,lda,b,ldb,beta,c,ldc) !! ZHER2K: performs one of the hermitian rank 2k operations !! C := alpha*A*B**H + conjg( alpha )*B*A**H + beta*C, !! or @@ -1794,18 +1799,18 @@ module stdlib_linalg_blas_w ! -- reference blas is a software package provided by univ. of tennessee, -- ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments - complex(qp), intent(in) :: alpha - real(qp), intent(in) :: beta + complex(${ck}$), intent(in) :: alpha + real(${ck}$), intent(in) :: beta integer(ilp), intent(in) :: k, lda, ldb, ldc, n character, intent(in) :: trans, uplo ! Array Arguments - complex(qp), intent(in) :: a(lda,*), b(ldb,*) - complex(qp), intent(inout) :: c(ldc,*) + complex(${ck}$), intent(in) :: a(lda,*), b(ldb,*) + complex(${ck}$), intent(inout) :: c(ldc,*) ! ===================================================================== ! Intrinsic Functions intrinsic :: real,conjg,max ! Local Scalars - complex(qp) :: temp1, temp2 + complex(${ck}$) :: temp1, temp2 integer(ilp) :: i, info, j, l, nrowa logical(lk) :: upper @@ -1843,7 +1848,7 @@ module stdlib_linalg_blas_w ! and when alpha.eq.czero. if (alpha==czero) then if (upper) then - if (beta==real(czero,KIND=qp)) then + if (beta==real(czero,KIND=${ck}$)) then do j = 1,n do i = 1,j c(i,j) = czero @@ -1854,11 +1859,11 @@ module stdlib_linalg_blas_w do i = 1,j - 1 c(i,j) = beta*c(i,j) end do - c(j,j) = beta*real(c(j,j),KIND=qp) + c(j,j) = beta*real(c(j,j),KIND=${ck}$) end do end if else - if (beta==real(czero,KIND=qp)) then + if (beta==real(czero,KIND=${ck}$)) then do j = 1,n do i = j,n c(i,j) = czero @@ -1866,7 +1871,7 @@ module stdlib_linalg_blas_w end do else do j = 1,n - c(j,j) = beta*real(c(j,j),KIND=qp) + c(j,j) = beta*real(c(j,j),KIND=${ck}$) do i = j + 1,n c(i,j) = beta*c(i,j) end do @@ -1881,7 +1886,7 @@ module stdlib_linalg_blas_w ! c. if (upper) then do j = 1,n - if (beta==real(czero,KIND=qp)) then + if (beta==real(czero,KIND=${ck}$)) then do i = 1,j c(i,j) = czero end do @@ -1889,9 +1894,9 @@ module stdlib_linalg_blas_w do i = 1,j - 1 c(i,j) = beta*c(i,j) end do - c(j,j) = beta*real(c(j,j),KIND=qp) + c(j,j) = beta*real(c(j,j),KIND=${ck}$) else - c(j,j) = real(c(j,j),KIND=qp) + c(j,j) = real(c(j,j),KIND=${ck}$) end if do l = 1,k if ((a(j,l)/=czero) .or. (b(j,l)/=czero)) then @@ -1900,14 +1905,14 @@ module stdlib_linalg_blas_w do i = 1,j - 1 c(i,j) = c(i,j) + a(i,l)*temp1 +b(i,l)*temp2 end do - c(j,j) = real(c(j,j),KIND=qp) +real(a(j,l)*temp1+b(j,l)*temp2,& - KIND=qp) + c(j,j) = real(c(j,j),KIND=${ck}$) +real(a(j,l)*temp1+b(j,l)*temp2,& + KIND=${ck}$) end if end do end do else do j = 1,n - if (beta==real(czero,KIND=qp)) then + if (beta==real(czero,KIND=${ck}$)) then do i = j,n c(i,j) = czero end do @@ -1915,9 +1920,9 @@ module stdlib_linalg_blas_w do i = j + 1,n c(i,j) = beta*c(i,j) end do - c(j,j) = beta*real(c(j,j),KIND=qp) + c(j,j) = beta*real(c(j,j),KIND=${ck}$) else - c(j,j) = real(c(j,j),KIND=qp) + c(j,j) = real(c(j,j),KIND=${ck}$) end if do l = 1,k if ((a(j,l)/=czero) .or. (b(j,l)/=czero)) then @@ -1926,8 +1931,8 @@ module stdlib_linalg_blas_w do i = j + 1,n c(i,j) = c(i,j) + a(i,l)*temp1 +b(i,l)*temp2 end do - c(j,j) = real(c(j,j),KIND=qp) +real(a(j,l)*temp1+b(j,l)*temp2,& - KIND=qp) + c(j,j) = real(c(j,j),KIND=${ck}$) +real(a(j,l)*temp1+b(j,l)*temp2,& + KIND=${ck}$) end if end do end do @@ -1945,14 +1950,14 @@ module stdlib_linalg_blas_w temp2 = temp2 + conjg(b(l,i))*a(l,j) end do if (i==j) then - if (beta==real(czero,KIND=qp)) then - c(j,j) = real(alpha*temp1+conjg(alpha)*temp2,KIND=qp) + if (beta==real(czero,KIND=${ck}$)) then + c(j,j) = real(alpha*temp1+conjg(alpha)*temp2,KIND=${ck}$) else - c(j,j) = beta*real(c(j,j),KIND=qp) +real(alpha*temp1+conjg(& - alpha)*temp2,KIND=qp) + c(j,j) = beta*real(c(j,j),KIND=${ck}$) +real(alpha*temp1+conjg(& + alpha)*temp2,KIND=${ck}$) end if else - if (beta==real(czero,KIND=qp)) then + if (beta==real(czero,KIND=${ck}$)) then c(i,j) = alpha*temp1 + conjg(alpha)*temp2 else c(i,j) = beta*c(i,j) + alpha*temp1 +conjg(alpha)*temp2 @@ -1970,14 +1975,14 @@ module stdlib_linalg_blas_w temp2 = temp2 + conjg(b(l,i))*a(l,j) end do if (i==j) then - if (beta==real(czero,KIND=qp)) then - c(j,j) = real(alpha*temp1+conjg(alpha)*temp2,KIND=qp) + if (beta==real(czero,KIND=${ck}$)) then + c(j,j) = real(alpha*temp1+conjg(alpha)*temp2,KIND=${ck}$) else - c(j,j) = beta*real(c(j,j),KIND=qp) +real(alpha*temp1+conjg(& - alpha)*temp2,KIND=qp) + c(j,j) = beta*real(c(j,j),KIND=${ck}$) +real(alpha*temp1+conjg(& + alpha)*temp2,KIND=${ck}$) end if else - if (beta==real(czero,KIND=qp)) then + if (beta==real(czero,KIND=${ck}$)) then c(i,j) = alpha*temp1 + conjg(alpha)*temp2 else c(i,j) = beta*c(i,j) + alpha*temp1 +conjg(alpha)*temp2 @@ -1988,10 +1993,10 @@ module stdlib_linalg_blas_w end if end if return - end subroutine stdlib_wher2k + end subroutine stdlib_${ci}$her2k - pure subroutine stdlib_wherk(uplo,trans,n,k,alpha,a,lda,beta,c,ldc) + pure subroutine stdlib_${ci}$herk(uplo,trans,n,k,alpha,a,lda,beta,c,ldc) !! ZHERK: performs one of the hermitian rank k operations !! C := alpha*A*A**H + beta*C, !! or @@ -2003,18 +2008,18 @@ module stdlib_linalg_blas_w ! -- reference blas is a software package provided by univ. of tennessee, -- ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments - real(qp), intent(in) :: alpha, beta + real(${ck}$), intent(in) :: alpha, beta integer(ilp), intent(in) :: k, lda, ldc, n character, intent(in) :: trans, uplo ! Array Arguments - complex(qp), intent(in) :: a(lda,*) - complex(qp), intent(inout) :: c(ldc,*) + complex(${ck}$), intent(in) :: a(lda,*) + complex(${ck}$), intent(inout) :: c(ldc,*) ! ===================================================================== ! Intrinsic Functions intrinsic :: real,cmplx,conjg,max ! Local Scalars - complex(qp) :: temp - real(qp) :: rtemp + complex(${ck}$) :: temp + real(${ck}$) :: rtemp integer(ilp) :: i, info, j, l, nrowa logical(lk) :: upper @@ -2060,7 +2065,7 @@ module stdlib_linalg_blas_w do i = 1,j - 1 c(i,j) = beta*c(i,j) end do - c(j,j) = beta*real(c(j,j),KIND=qp) + c(j,j) = beta*real(c(j,j),KIND=${ck}$) end do end if else @@ -2072,7 +2077,7 @@ module stdlib_linalg_blas_w end do else do j = 1,n - c(j,j) = beta*real(c(j,j),KIND=qp) + c(j,j) = beta*real(c(j,j),KIND=${ck}$) do i = j + 1,n c(i,j) = beta*c(i,j) end do @@ -2094,17 +2099,17 @@ module stdlib_linalg_blas_w do i = 1,j - 1 c(i,j) = beta*c(i,j) end do - c(j,j) = beta*real(c(j,j),KIND=qp) + c(j,j) = beta*real(c(j,j),KIND=${ck}$) else - c(j,j) = real(c(j,j),KIND=qp) + c(j,j) = real(c(j,j),KIND=${ck}$) end if do l = 1,k - if (a(j,l)/=cmplx(zero,KIND=qp)) then + if (a(j,l)/=cmplx(zero,KIND=${ck}$)) then temp = alpha*conjg(a(j,l)) do i = 1,j - 1 c(i,j) = c(i,j) + temp*a(i,l) end do - c(j,j) = real(c(j,j),KIND=qp) + real(temp*a(i,l),KIND=qp) + c(j,j) = real(c(j,j),KIND=${ck}$) + real(temp*a(i,l),KIND=${ck}$) end if end do end do @@ -2115,17 +2120,17 @@ module stdlib_linalg_blas_w c(i,j) = zero end do else if (beta/=one) then - c(j,j) = beta*real(c(j,j),KIND=qp) + c(j,j) = beta*real(c(j,j),KIND=${ck}$) do i = j + 1,n c(i,j) = beta*c(i,j) end do else - c(j,j) = real(c(j,j),KIND=qp) + c(j,j) = real(c(j,j),KIND=${ck}$) end if do l = 1,k - if (a(j,l)/=cmplx(zero,KIND=qp)) then + if (a(j,l)/=cmplx(zero,KIND=${ck}$)) then temp = alpha*conjg(a(j,l)) - c(j,j) = real(c(j,j),KIND=qp) + real(temp*a(j,l),KIND=qp) + c(j,j) = real(c(j,j),KIND=${ck}$) + real(temp*a(j,l),KIND=${ck}$) do i = j + 1,n c(i,j) = c(i,j) + temp*a(i,l) end do @@ -2155,7 +2160,7 @@ module stdlib_linalg_blas_w if (beta==zero) then c(j,j) = alpha*rtemp else - c(j,j) = alpha*rtemp + beta*real(c(j,j),KIND=qp) + c(j,j) = alpha*rtemp + beta*real(c(j,j),KIND=${ck}$) end if end do else @@ -2167,7 +2172,7 @@ module stdlib_linalg_blas_w if (beta==zero) then c(j,j) = alpha*rtemp else - c(j,j) = alpha*rtemp + beta*real(c(j,j),KIND=qp) + c(j,j) = alpha*rtemp + beta*real(c(j,j),KIND=${ck}$) end if do i = j + 1,n temp = zero @@ -2184,10 +2189,10 @@ module stdlib_linalg_blas_w end if end if return - end subroutine stdlib_wherk + end subroutine stdlib_${ci}$herk - pure subroutine stdlib_whpmv(uplo,n,alpha,ap,x,incx,beta,y,incy) + pure subroutine stdlib_${ci}$hpmv(uplo,n,alpha,ap,x,incx,beta,y,incy) !! ZHPMV: performs the matrix-vector operation !! y := alpha*A*x + beta*y, !! where alpha and beta are scalars, x and y are n element vectors and @@ -2196,17 +2201,17 @@ module stdlib_linalg_blas_w ! -- reference blas is a software package provided by univ. of tennessee, -- ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments - complex(qp), intent(in) :: alpha, beta + complex(${ck}$), intent(in) :: alpha, beta integer(ilp), intent(in) :: incx, incy, n character, intent(in) :: uplo ! Array Arguments - complex(qp), intent(in) :: ap(*), x(*) - complex(qp), intent(inout) :: y(*) + complex(${ck}$), intent(in) :: ap(*), x(*) + complex(${ck}$), intent(inout) :: y(*) ! ===================================================================== ! Local Scalars - complex(qp) :: temp1, temp2 + complex(${ck}$) :: temp1, temp2 integer(ilp) :: i, info, ix, iy, j, jx, jy, k, kk, kx, ky ! Intrinsic Functions intrinsic :: real,conjg @@ -2281,7 +2286,7 @@ module stdlib_linalg_blas_w temp2 = temp2 + conjg(ap(k))*x(i) k = k + 1 end do - y(j) = y(j) + temp1*real(ap(kk+j-1),KIND=qp) + alpha*temp2 + y(j) = y(j) + temp1*real(ap(kk+j-1),KIND=${ck}$) + alpha*temp2 kk = kk + j end do else @@ -2298,7 +2303,7 @@ module stdlib_linalg_blas_w ix = ix + incx iy = iy + incy end do - y(jy) = y(jy) + temp1*real(ap(kk+j-1),KIND=qp) + alpha*temp2 + y(jy) = y(jy) + temp1*real(ap(kk+j-1),KIND=${ck}$) + alpha*temp2 jx = jx + incx jy = jy + incy kk = kk + j @@ -2310,7 +2315,7 @@ module stdlib_linalg_blas_w do j = 1,n temp1 = alpha*x(j) temp2 = czero - y(j) = y(j) + temp1*real(ap(kk),KIND=qp) + y(j) = y(j) + temp1*real(ap(kk),KIND=${ck}$) k = kk + 1 do i = j + 1,n y(i) = y(i) + temp1*ap(k) @@ -2326,7 +2331,7 @@ module stdlib_linalg_blas_w do j = 1,n temp1 = alpha*x(jx) temp2 = czero - y(jy) = y(jy) + temp1*real(ap(kk),KIND=qp) + y(jy) = y(jy) + temp1*real(ap(kk),KIND=${ck}$) ix = jx iy = jy do k = kk + 1,kk + n - j @@ -2343,10 +2348,10 @@ module stdlib_linalg_blas_w end if end if return - end subroutine stdlib_whpmv + end subroutine stdlib_${ci}$hpmv - pure subroutine stdlib_whpr(uplo,n,alpha,x,incx,ap) + pure subroutine stdlib_${ci}$hpr(uplo,n,alpha,x,incx,ap) !! ZHPR: performs the hermitian rank 1 operation !! A := alpha*x*x**H + A, !! where alpha is a real scalar, x is an n element vector and A is an @@ -2355,16 +2360,16 @@ module stdlib_linalg_blas_w ! -- reference blas is a software package provided by univ. of tennessee, -- ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments - real(qp), intent(in) :: alpha + real(${ck}$), intent(in) :: alpha integer(ilp), intent(in) :: incx, n character, intent(in) :: uplo ! Array Arguments - complex(qp), intent(inout) :: ap(*) - complex(qp), intent(in) :: x(*) + complex(${ck}$), intent(inout) :: ap(*) + complex(${ck}$), intent(in) :: x(*) ! ===================================================================== ! Local Scalars - complex(qp) :: temp + complex(${ck}$) :: temp integer(ilp) :: i, info, ix, j, jx, k, kk, kx ! Intrinsic Functions intrinsic :: real,conjg @@ -2382,7 +2387,7 @@ module stdlib_linalg_blas_w return end if ! quick return if possible. - if ((n==0) .or. (alpha==real(czero,KIND=qp))) return + if ((n==0) .or. (alpha==real(czero,KIND=${ck}$))) return ! set the start point in x if the increment is not unity. if (incx<=0) then kx = 1 - (n-1)*incx @@ -2403,9 +2408,9 @@ module stdlib_linalg_blas_w ap(k) = ap(k) + x(i)*temp k = k + 1 end do - ap(kk+j-1) = real(ap(kk+j-1),KIND=qp) + real(x(j)*temp,KIND=qp) + ap(kk+j-1) = real(ap(kk+j-1),KIND=${ck}$) + real(x(j)*temp,KIND=${ck}$) else - ap(kk+j-1) = real(ap(kk+j-1),KIND=qp) + ap(kk+j-1) = real(ap(kk+j-1),KIND=${ck}$) end if kk = kk + j end do @@ -2419,10 +2424,10 @@ module stdlib_linalg_blas_w ap(k) = ap(k) + x(ix)*temp ix = ix + incx end do - ap(kk+j-1) = real(ap(kk+j-1),KIND=qp) + real(x(jx)*temp,KIND=qp) + ap(kk+j-1) = real(ap(kk+j-1),KIND=${ck}$) + real(x(jx)*temp,KIND=${ck}$) else - ap(kk+j-1) = real(ap(kk+j-1),KIND=qp) + ap(kk+j-1) = real(ap(kk+j-1),KIND=${ck}$) end if jx = jx + incx kk = kk + j @@ -2434,14 +2439,14 @@ module stdlib_linalg_blas_w do j = 1,n if (x(j)/=czero) then temp = alpha*conjg(x(j)) - ap(kk) = real(ap(kk),KIND=qp) + real(temp*x(j),KIND=qp) + ap(kk) = real(ap(kk),KIND=${ck}$) + real(temp*x(j),KIND=${ck}$) k = kk + 1 do i = j + 1,n ap(k) = ap(k) + x(i)*temp k = k + 1 end do else - ap(kk) = real(ap(kk),KIND=qp) + ap(kk) = real(ap(kk),KIND=${ck}$) end if kk = kk + n - j + 1 end do @@ -2450,14 +2455,14 @@ module stdlib_linalg_blas_w do j = 1,n if (x(jx)/=czero) then temp = alpha*conjg(x(jx)) - ap(kk) = real(ap(kk),KIND=qp) + real(temp*x(jx),KIND=qp) + ap(kk) = real(ap(kk),KIND=${ck}$) + real(temp*x(jx),KIND=${ck}$) ix = jx do k = kk + 1,kk + n - j ix = ix + incx ap(k) = ap(k) + x(ix)*temp end do else - ap(kk) = real(ap(kk),KIND=qp) + ap(kk) = real(ap(kk),KIND=${ck}$) end if jx = jx + incx kk = kk + n - j + 1 @@ -2465,10 +2470,10 @@ module stdlib_linalg_blas_w end if end if return - end subroutine stdlib_whpr + end subroutine stdlib_${ci}$hpr - pure subroutine stdlib_whpr2(uplo,n,alpha,x,incx,y,incy,ap) + pure subroutine stdlib_${ci}$hpr2(uplo,n,alpha,x,incx,y,incy,ap) !! ZHPR2: performs the hermitian rank 2 operation !! A := alpha*x*y**H + conjg( alpha )*y*x**H + A, !! where alpha is a scalar, x and y are n element vectors and A is an @@ -2477,16 +2482,16 @@ module stdlib_linalg_blas_w ! -- reference blas is a software package provided by univ. of tennessee, -- ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments - complex(qp), intent(in) :: alpha + complex(${ck}$), intent(in) :: alpha integer(ilp), intent(in) :: incx, incy, n character, intent(in) :: uplo ! Array Arguments - complex(qp), intent(inout) :: ap(*) - complex(qp), intent(in) :: x(*), y(*) + complex(${ck}$), intent(inout) :: ap(*) + complex(${ck}$), intent(in) :: x(*), y(*) ! ===================================================================== ! Local Scalars - complex(qp) :: temp1, temp2 + complex(${ck}$) :: temp1, temp2 integer(ilp) :: i, info, ix, iy, j, jx, jy, k, kk, kx, ky ! Intrinsic Functions intrinsic :: real,conjg @@ -2538,10 +2543,10 @@ module stdlib_linalg_blas_w ap(k) = ap(k) + x(i)*temp1 + y(i)*temp2 k = k + 1 end do - ap(kk+j-1) = real(ap(kk+j-1),KIND=qp) +real(x(j)*temp1+y(j)*temp2,& - KIND=qp) + ap(kk+j-1) = real(ap(kk+j-1),KIND=${ck}$) +real(x(j)*temp1+y(j)*temp2,& + KIND=${ck}$) else - ap(kk+j-1) = real(ap(kk+j-1),KIND=qp) + ap(kk+j-1) = real(ap(kk+j-1),KIND=${ck}$) end if kk = kk + j end do @@ -2557,10 +2562,10 @@ module stdlib_linalg_blas_w ix = ix + incx iy = iy + incy end do - ap(kk+j-1) = real(ap(kk+j-1),KIND=qp) +real(x(jx)*temp1+y(jy)*temp2,& - KIND=qp) + ap(kk+j-1) = real(ap(kk+j-1),KIND=${ck}$) +real(x(jx)*temp1+y(jy)*temp2,& + KIND=${ck}$) else - ap(kk+j-1) = real(ap(kk+j-1),KIND=qp) + ap(kk+j-1) = real(ap(kk+j-1),KIND=${ck}$) end if jx = jx + incx jy = jy + incy @@ -2574,7 +2579,7 @@ module stdlib_linalg_blas_w if ((x(j)/=czero) .or. (y(j)/=czero)) then temp1 = alpha*conjg(y(j)) temp2 = conjg(alpha*x(j)) - ap(kk) = real(ap(kk),KIND=qp) +real(x(j)*temp1+y(j)*temp2,KIND=qp) + ap(kk) = real(ap(kk),KIND=${ck}$) +real(x(j)*temp1+y(j)*temp2,KIND=${ck}$) k = kk + 1 do i = j + 1,n @@ -2582,7 +2587,7 @@ module stdlib_linalg_blas_w k = k + 1 end do else - ap(kk) = real(ap(kk),KIND=qp) + ap(kk) = real(ap(kk),KIND=${ck}$) end if kk = kk + n - j + 1 end do @@ -2591,7 +2596,7 @@ module stdlib_linalg_blas_w if ((x(jx)/=czero) .or. (y(jy)/=czero)) then temp1 = alpha*conjg(y(jy)) temp2 = conjg(alpha*x(jx)) - ap(kk) = real(ap(kk),KIND=qp) +real(x(jx)*temp1+y(jy)*temp2,KIND=qp) + ap(kk) = real(ap(kk),KIND=${ck}$) +real(x(jx)*temp1+y(jy)*temp2,KIND=${ck}$) ix = jx iy = jy @@ -2601,7 +2606,7 @@ module stdlib_linalg_blas_w ap(k) = ap(k) + x(ix)*temp1 + y(iy)*temp2 end do else - ap(kk) = real(ap(kk),KIND=qp) + ap(kk) = real(ap(kk),KIND=${ck}$) end if jx = jx + incx jy = jy + incy @@ -2610,10 +2615,10 @@ module stdlib_linalg_blas_w end if end if return - end subroutine stdlib_whpr2 + end subroutine stdlib_${ci}$hpr2 - pure subroutine stdlib_wrotg( a, b, c, s ) + pure subroutine stdlib_${ci}$rotg( a, b, c, s ) !! The computation uses the formulas !! |x| = sqrt( Re(x)**2 + Im(x)**2 ) !! sgn(x) = x / |x| if x /= 0 @@ -2631,22 +2636,22 @@ module stdlib_linalg_blas_w ! -- reference blas is a software package provided by univ. of tennessee, -- ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Constants - integer, parameter :: wp = kind(1._qp) + integer, parameter :: wp = kind(1._${ck}$) ! Scaling Constants ! Scalar Arguments - real(qp), intent(out) :: c - complex(qp), intent(inout) :: a - complex(qp), intent(in) :: b - complex(qp), intent(out) :: s + real(${ck}$), intent(out) :: c + complex(${ck}$), intent(inout) :: a + complex(${ck}$), intent(in) :: b + complex(${ck}$), intent(out) :: s ! Local Scalars - real(qp) :: d, f1, f2, g1, g2, h2, p, u, uu, v, vv, w - complex(qp) :: f, fs, g, gs, r, t + real(${ck}$) :: d, f1, f2, g1, g2, h2, p, u, uu, v, vv, w + complex(${ck}$) :: f, fs, g, gs, r, t ! Intrinsic Functions intrinsic :: abs,aimag,conjg,max,min,real,sqrt ! Statement Functions - real(qp) :: abssq + real(${ck}$) :: abssq ! Statement Function Definitions - abssq( t ) = real( t,KIND=qp)**2 + aimag( t )**2 + abssq( t ) = real( t,KIND=${ck}$)**2 + aimag( t )**2 ! Executable Statements f = a g = b @@ -2656,7 +2661,7 @@ module stdlib_linalg_blas_w r = f else if( f == czero ) then c = zero - g1 = max( abs(real(g,KIND=qp)), abs(aimag(g)) ) + g1 = max( abs(real(g,KIND=${ck}$)), abs(aimag(g)) ) if( g1 > rtmin .and. g1 < rtmax ) then ! use unscaled algorithm g2 = abssq( g ) @@ -2674,8 +2679,8 @@ module stdlib_linalg_blas_w r = d*u end if else - f1 = max( abs(real(f,KIND=qp)), abs(aimag(f)) ) - g1 = max( abs(real(g,KIND=qp)), abs(aimag(g)) ) + f1 = max( abs(real(f,KIND=${ck}$)), abs(aimag(f)) ) + g1 = max( abs(real(g,KIND=${ck}$)), abs(aimag(g)) ) if( f1 > rtmin .and. f1 < rtmax .and. g1 > rtmin .and. g1 < rtmax ) then ! use unscaled algorithm f2 = abssq( f ) @@ -2725,19 +2730,19 @@ module stdlib_linalg_blas_w end if a = r return - end subroutine stdlib_wrotg + end subroutine stdlib_${ci}$rotg - pure subroutine stdlib_wscal(n,za,zx,incx) + pure subroutine stdlib_${ci}$scal(n,za,zx,incx) !! ZSCAL: scales a vector by a constant. ! -- reference blas level1 routine -- ! -- reference blas is a software package provided by univ. of tennessee, -- ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments - complex(qp), intent(in) :: za + complex(${ck}$), intent(in) :: za integer(ilp), intent(in) :: incx, n ! Array Arguments - complex(qp), intent(inout) :: zx(*) + complex(${ck}$), intent(inout) :: zx(*) ! ===================================================================== ! Local Scalars integer(ilp) :: i, nincx @@ -2755,10 +2760,10 @@ module stdlib_linalg_blas_w end do end if return - end subroutine stdlib_wscal + end subroutine stdlib_${ci}$scal - pure subroutine stdlib_wswap(n,zx,incx,zy,incy) + pure subroutine stdlib_${ci}$swap(n,zx,incx,zy,incy) !! ZSWAP: interchanges two vectors. ! -- reference blas level1 routine -- ! -- reference blas is a software package provided by univ. of tennessee, -- @@ -2766,10 +2771,10 @@ module stdlib_linalg_blas_w ! Scalar Arguments integer(ilp), intent(in) :: incx, incy, n ! Array Arguments - complex(qp), intent(inout) :: zx(*), zy(*) + complex(${ck}$), intent(inout) :: zx(*), zy(*) ! ===================================================================== ! Local Scalars - complex(qp) :: ztemp + complex(${ck}$) :: ztemp integer(ilp) :: i, ix, iy if (n<=0) return if (incx==1 .and. incy==1) then @@ -2795,10 +2800,10 @@ module stdlib_linalg_blas_w end do end if return - end subroutine stdlib_wswap + end subroutine stdlib_${ci}$swap - pure subroutine stdlib_wsymm(side,uplo,m,n,alpha,a,lda,b,ldb,beta,c,ldc) + pure subroutine stdlib_${ci}$symm(side,uplo,m,n,alpha,a,lda,b,ldb,beta,c,ldc) !! ZSYMM: performs one of the matrix-matrix operations !! C := alpha*A*B + beta*C, !! or @@ -2809,17 +2814,17 @@ module stdlib_linalg_blas_w ! -- reference blas is a software package provided by univ. of tennessee, -- ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments - complex(qp), intent(in) :: alpha, beta + complex(${ck}$), intent(in) :: alpha, beta integer(ilp), intent(in) :: lda, ldb, ldc, m, n character, intent(in) :: side, uplo ! Array Arguments - complex(qp), intent(in) :: a(lda,*), b(ldb,*) - complex(qp), intent(inout) :: c(ldc,*) + complex(${ck}$), intent(in) :: a(lda,*), b(ldb,*) + complex(${ck}$), intent(inout) :: c(ldc,*) ! ===================================================================== ! Intrinsic Functions intrinsic :: max ! Local Scalars - complex(qp) :: temp1, temp2 + complex(${ck}$) :: temp1, temp2 integer(ilp) :: i, info, j, k, nrowa logical(lk) :: upper @@ -2943,10 +2948,10 @@ module stdlib_linalg_blas_w end do loop_170 end if return - end subroutine stdlib_wsymm + end subroutine stdlib_${ci}$symm - pure subroutine stdlib_wsyr2k(uplo,trans,n,k,alpha,a,lda,b,ldb,beta,c,ldc) + pure subroutine stdlib_${ci}$syr2k(uplo,trans,n,k,alpha,a,lda,b,ldb,beta,c,ldc) !! ZSYR2K: performs one of the symmetric rank 2k operations !! C := alpha*A*B**T + alpha*B*A**T + beta*C, !! or @@ -2958,17 +2963,17 @@ module stdlib_linalg_blas_w ! -- reference blas is a software package provided by univ. of tennessee, -- ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments - complex(qp), intent(in) :: alpha, beta + complex(${ck}$), intent(in) :: alpha, beta integer(ilp), intent(in) :: k, lda, ldb, ldc, n character, intent(in) :: trans, uplo ! Array Arguments - complex(qp), intent(in) :: a(lda,*), b(ldb,*) - complex(qp), intent(inout) :: c(ldc,*) + complex(${ck}$), intent(in) :: a(lda,*), b(ldb,*) + complex(${ck}$), intent(inout) :: c(ldc,*) ! ===================================================================== ! Intrinsic Functions intrinsic :: max ! Local Scalars - complex(qp) :: temp1, temp2 + complex(${ck}$) :: temp1, temp2 integer(ilp) :: i, info, j, l, nrowa logical(lk) :: upper @@ -3119,10 +3124,10 @@ module stdlib_linalg_blas_w end if end if return - end subroutine stdlib_wsyr2k + end subroutine stdlib_${ci}$syr2k - pure subroutine stdlib_wsyrk(uplo,trans,n,k,alpha,a,lda,beta,c,ldc) + pure subroutine stdlib_${ci}$syrk(uplo,trans,n,k,alpha,a,lda,beta,c,ldc) !! ZSYRK: performs one of the symmetric rank k operations !! C := alpha*A*A**T + beta*C, !! or @@ -3134,17 +3139,17 @@ module stdlib_linalg_blas_w ! -- reference blas is a software package provided by univ. of tennessee, -- ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments - complex(qp), intent(in) :: alpha, beta + complex(${ck}$), intent(in) :: alpha, beta integer(ilp), intent(in) :: k, lda, ldc, n character, intent(in) :: trans, uplo ! Array Arguments - complex(qp), intent(in) :: a(lda,*) - complex(qp), intent(inout) :: c(ldc,*) + complex(${ck}$), intent(in) :: a(lda,*) + complex(${ck}$), intent(inout) :: c(ldc,*) ! ===================================================================== ! Intrinsic Functions intrinsic :: max ! Local Scalars - complex(qp) :: temp + complex(${ck}$) :: temp integer(ilp) :: i, info, j, l, nrowa logical(lk) :: upper @@ -3287,10 +3292,10 @@ module stdlib_linalg_blas_w end if end if return - end subroutine stdlib_wsyrk + end subroutine stdlib_${ci}$syrk - pure subroutine stdlib_wtbmv(uplo,trans,diag,n,k,a,lda,x,incx) + pure subroutine stdlib_${ci}$tbmv(uplo,trans,diag,n,k,a,lda,x,incx) !! ZTBMV: performs one of the matrix-vector operations !! x := A*x, or x := A**T*x, or x := A**H*x, !! where x is an n element vector and A is an n by n unit, or non-unit, @@ -3302,12 +3307,12 @@ module stdlib_linalg_blas_w integer(ilp), intent(in) :: incx, k, lda, n character, intent(in) :: diag, trans, uplo ! Array Arguments - complex(qp), intent(in) :: a(lda,*) - complex(qp), intent(inout) :: x(*) + complex(${ck}$), intent(in) :: a(lda,*) + complex(${ck}$), intent(inout) :: x(*) ! ===================================================================== ! Local Scalars - complex(qp) :: temp + complex(${ck}$) :: temp integer(ilp) :: i, info, ix, j, jx, kplus1, kx, l logical(lk) :: noconj, nounit ! Intrinsic Functions @@ -3501,10 +3506,10 @@ module stdlib_linalg_blas_w end if end if return - end subroutine stdlib_wtbmv + end subroutine stdlib_${ci}$tbmv - pure subroutine stdlib_wtbsv(uplo,trans,diag,n,k,a,lda,x,incx) + pure subroutine stdlib_${ci}$tbsv(uplo,trans,diag,n,k,a,lda,x,incx) !! ZTBSV: solves one of the systems of equations !! A*x = b, or A**T*x = b, or A**H*x = b, !! where b and x are n element vectors and A is an n by n unit, or @@ -3519,12 +3524,12 @@ module stdlib_linalg_blas_w integer(ilp), intent(in) :: incx, k, lda, n character, intent(in) :: diag, trans, uplo ! Array Arguments - complex(qp), intent(in) :: a(lda,*) - complex(qp), intent(inout) :: x(*) + complex(${ck}$), intent(in) :: a(lda,*) + complex(${ck}$), intent(inout) :: x(*) ! ===================================================================== ! Local Scalars - complex(qp) :: temp + complex(${ck}$) :: temp integer(ilp) :: i, info, ix, j, jx, kplus1, kx, l logical(lk) :: noconj, nounit ! Intrinsic Functions @@ -3718,10 +3723,10 @@ module stdlib_linalg_blas_w end if end if return - end subroutine stdlib_wtbsv + end subroutine stdlib_${ci}$tbsv - pure subroutine stdlib_wtpmv(uplo,trans,diag,n,ap,x,incx) + pure subroutine stdlib_${ci}$tpmv(uplo,trans,diag,n,ap,x,incx) !! ZTPMV: performs one of the matrix-vector operations !! x := A*x, or x := A**T*x, or x := A**H*x, !! where x is an n element vector and A is an n by n unit, or non-unit, @@ -3733,12 +3738,12 @@ module stdlib_linalg_blas_w integer(ilp), intent(in) :: incx, n character, intent(in) :: diag, trans, uplo ! Array Arguments - complex(qp), intent(in) :: ap(*) - complex(qp), intent(inout) :: x(*) + complex(${ck}$), intent(in) :: ap(*) + complex(${ck}$), intent(inout) :: x(*) ! ===================================================================== ! Local Scalars - complex(qp) :: temp + complex(${ck}$) :: temp integer(ilp) :: i, info, ix, j, jx, k, kk, kx logical(lk) :: noconj, nounit ! Intrinsic Functions @@ -3935,10 +3940,10 @@ module stdlib_linalg_blas_w end if end if return - end subroutine stdlib_wtpmv + end subroutine stdlib_${ci}$tpmv - pure subroutine stdlib_wtpsv(uplo,trans,diag,n,ap,x,incx) + pure subroutine stdlib_${ci}$tpsv(uplo,trans,diag,n,ap,x,incx) !! ZTPSV: solves one of the systems of equations !! A*x = b, or A**T*x = b, or A**H*x = b, !! where b and x are n element vectors and A is an n by n unit, or @@ -3952,12 +3957,12 @@ module stdlib_linalg_blas_w integer(ilp), intent(in) :: incx, n character, intent(in) :: diag, trans, uplo ! Array Arguments - complex(qp), intent(in) :: ap(*) - complex(qp), intent(inout) :: x(*) + complex(${ck}$), intent(in) :: ap(*) + complex(${ck}$), intent(inout) :: x(*) ! ===================================================================== ! Local Scalars - complex(qp) :: temp + complex(${ck}$) :: temp integer(ilp) :: i, info, ix, j, jx, k, kk, kx logical(lk) :: noconj, nounit ! Intrinsic Functions @@ -4154,10 +4159,10 @@ module stdlib_linalg_blas_w end if end if return - end subroutine stdlib_wtpsv + end subroutine stdlib_${ci}$tpsv - pure subroutine stdlib_wtrmm(side,uplo,transa,diag,m,n,alpha,a,lda,b,ldb) + pure subroutine stdlib_${ci}$trmm(side,uplo,transa,diag,m,n,alpha,a,lda,b,ldb) !! ZTRMM: performs one of the matrix-matrix operations !! B := alpha*op( A )*B, or B := alpha*B*op( A ) !! where alpha is a scalar, B is an m by n matrix, A is a unit, or @@ -4167,17 +4172,17 @@ module stdlib_linalg_blas_w ! -- reference blas is a software package provided by univ. of tennessee, -- ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments - complex(qp), intent(in) :: alpha + complex(${ck}$), intent(in) :: alpha integer(ilp), intent(in) :: lda, ldb, m, n character, intent(in) :: diag, side, transa, uplo ! Array Arguments - complex(qp), intent(in) :: a(lda,*) - complex(qp), intent(inout) :: b(ldb,*) + complex(${ck}$), intent(in) :: a(lda,*) + complex(${ck}$), intent(inout) :: b(ldb,*) ! ===================================================================== ! Intrinsic Functions intrinsic :: conjg,max ! Local Scalars - complex(qp) :: temp + complex(${ck}$) :: temp integer(ilp) :: i, info, j, k, nrowa logical(lk) :: lside, noconj, nounit, upper @@ -4396,10 +4401,10 @@ module stdlib_linalg_blas_w end if end if return - end subroutine stdlib_wtrmm + end subroutine stdlib_${ci}$trmm - pure subroutine stdlib_wtrmv(uplo,trans,diag,n,a,lda,x,incx) + pure subroutine stdlib_${ci}$trmv(uplo,trans,diag,n,a,lda,x,incx) !! ZTRMV: performs one of the matrix-vector operations !! x := A*x, or x := A**T*x, or x := A**H*x, !! where x is an n element vector and A is an n by n unit, or non-unit, @@ -4411,12 +4416,12 @@ module stdlib_linalg_blas_w integer(ilp), intent(in) :: incx, lda, n character, intent(in) :: diag, trans, uplo ! Array Arguments - complex(qp), intent(in) :: a(lda,*) - complex(qp), intent(inout) :: x(*) + complex(${ck}$), intent(in) :: a(lda,*) + complex(${ck}$), intent(inout) :: x(*) ! ===================================================================== ! Local Scalars - complex(qp) :: temp + complex(${ck}$) :: temp integer(ilp) :: i, info, ix, j, jx, kx logical(lk) :: noconj, nounit ! Intrinsic Functions @@ -4593,10 +4598,10 @@ module stdlib_linalg_blas_w end if end if return - end subroutine stdlib_wtrmv + end subroutine stdlib_${ci}$trmv - pure subroutine stdlib_wtrsm(side,uplo,transa,diag,m,n,alpha,a,lda,b,ldb) + pure subroutine stdlib_${ci}$trsm(side,uplo,transa,diag,m,n,alpha,a,lda,b,ldb) !! ZTRSM: solves one of the matrix equations !! op( A )*X = alpha*B, or X*op( A ) = alpha*B, !! where alpha is a scalar, X and B are m by n matrices, A is a unit, or @@ -4607,17 +4612,17 @@ module stdlib_linalg_blas_w ! -- reference blas is a software package provided by univ. of tennessee, -- ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments - complex(qp), intent(in) :: alpha + complex(${ck}$), intent(in) :: alpha integer(ilp), intent(in) :: lda, ldb, m, n character, intent(in) :: diag, side, transa, uplo ! Array Arguments - complex(qp), intent(in) :: a(lda,*) - complex(qp), intent(inout) :: b(ldb,*) + complex(${ck}$), intent(in) :: a(lda,*) + complex(${ck}$), intent(inout) :: b(ldb,*) ! ===================================================================== ! Intrinsic Functions intrinsic :: conjg,max ! Local Scalars - complex(qp) :: temp + complex(${ck}$) :: temp integer(ilp) :: i, info, j, k, nrowa logical(lk) :: lside, noconj, nounit, upper @@ -4858,10 +4863,10 @@ module stdlib_linalg_blas_w end if end if return - end subroutine stdlib_wtrsm + end subroutine stdlib_${ci}$trsm - pure subroutine stdlib_wtrsv(uplo,trans,diag,n,a,lda,x,incx) + pure subroutine stdlib_${ci}$trsv(uplo,trans,diag,n,a,lda,x,incx) !! ZTRSV: solves one of the systems of equations !! A*x = b, or A**T*x = b, or A**H*x = b, !! where b and x are n element vectors and A is an n by n unit, or @@ -4875,12 +4880,12 @@ module stdlib_linalg_blas_w integer(ilp), intent(in) :: incx, lda, n character, intent(in) :: diag, trans, uplo ! Array Arguments - complex(qp), intent(in) :: a(lda,*) - complex(qp), intent(inout) :: x(*) + complex(${ck}$), intent(in) :: a(lda,*) + complex(${ck}$), intent(inout) :: x(*) ! ===================================================================== ! Local Scalars - complex(qp) :: temp + complex(${ck}$) :: temp integer(ilp) :: i, info, ix, j, jx, kx logical(lk) :: noconj, nounit ! Intrinsic Functions @@ -5057,9 +5062,11 @@ module stdlib_linalg_blas_w end if end if return - end subroutine stdlib_wtrsv + end subroutine stdlib_${ci}$trsv -end module stdlib_linalg_blas_w +end module stdlib_linalg_blas_${ci}$ + #:endif +#:endfor diff --git a/src/stdlib_linalg_blas_z.fypp b/src/stdlib_linalg_blas_z.fypp index 5711d23b3..066220be1 100644 --- a/src/stdlib_linalg_blas_z.fypp +++ b/src/stdlib_linalg_blas_z.fypp @@ -102,7 +102,7 @@ module stdlib_linalg_blas_z ! Local Scalars integer(ilp) :: i, ix, iy if (n<=0) return - if (stdlib_dcabs1(za)==0.0_dp) return + if (stdlib_cabs1(za)==0.0_dp) return if (incx==1 .and. incy==1) then ! code for both increments equal to 1 do i = 1,n diff --git a/src/stdlib_linalg_constants.fypp b/src/stdlib_linalg_constants.fypp index 0e24c657e..4f9d565b6 100644 --- a/src/stdlib_linalg_constants.fypp +++ b/src/stdlib_linalg_constants.fypp @@ -1,6 +1,6 @@ #:include "common.fypp" module stdlib_linalg_constants - use stdlib_kinds, only: sp, dp, qp, int32, int64, lk + use stdlib_kinds, only: sp, dp, xdp, qp, int32, int64, lk use, intrinsic :: ieee_arithmetic, only: ieee_is_nan !$ use omp_lib implicit none(type,external) diff --git a/src/stdlib_linalg_lapack.fypp b/src/stdlib_linalg_lapack.fypp index eb4c53c7d..e24eb5496 100644 --- a/src/stdlib_linalg_lapack.fypp +++ b/src/stdlib_linalg_lapack.fypp @@ -1,18 +1,12 @@ #:include "common.fypp" +#:set RC_KINDS_TYPES = REAL_KINDS_TYPES + CMPLX_KINDS_TYPES module stdlib_linalg_lapack use stdlib_linalg_constants use stdlib_linalg_blas use stdlib_linalg_lapack_aux - use stdlib_linalg_lapack_s - use stdlib_linalg_lapack_d -#:if WITH_QP - use stdlib_linalg_lapack_q -#:endif - use stdlib_linalg_lapack_c - use stdlib_linalg_lapack_z -#:if WITH_QP - use stdlib_linalg_lapack_w -#:endif + #:for rk,rt,ri in RC_KINDS_TYPES + use stdlib_linalg_lapack_${ri}$ + #:endfor implicit none(type,external) public @@ -73,9 +67,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dbbcsd #endif -#:if WITH_QP - module procedure stdlib_qbbcsd +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$bbcsd + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine sbbcsd( jobu1, jobu2, jobv1t, jobv2t, trans, m, p, q,theta, phi, & u1, ldu1, u2, ldu2, v1t, ldv1t,v2t, ldv2t, b11d, b11e, b12d, b12e, b21d, b21e,b22d,& @@ -93,9 +90,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_sbbcsd #endif -#:if WITH_QP - module procedure stdlib_wbbcsd +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$bbcsd + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zbbcsd( jobu1, jobu2, jobv1t, jobv2t, trans, m, p, q,theta, phi, & u1, ldu1, u2, ldu2, v1t, ldv1t,v2t, ldv2t, b11d, b11e, b12d, b12e, b21d, b21e,b22d,& @@ -149,9 +149,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dbdsdc #endif -#:if WITH_QP - module procedure stdlib_qbdsdc +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$bdsdc + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine sbdsdc( uplo, compq, n, d, e, u, ldu, vt, ldvt, q, iq,work, iwork, & info ) @@ -224,9 +227,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dbdsqr #endif -#:if WITH_QP - module procedure stdlib_qbdsqr +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$bdsqr + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine sbdsqr( uplo, n, ncvt, nru, ncc, d, e, vt, ldvt, u,ldu, c, ldc, & work, info ) @@ -241,9 +247,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_sbdsqr #endif -#:if WITH_QP - module procedure stdlib_wbdsqr +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$bdsqr + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zbdsqr( uplo, n, ncvt, nru, ncc, d, e, vt, ldvt, u,ldu, c, ldc, & rwork, info ) @@ -290,9 +299,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_ddisna #endif -#:if WITH_QP - module procedure stdlib_qdisna +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$disna + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine sdisna( job, m, n, d, sep, info ) import sp,dp,qp,ilp,lk @@ -344,9 +356,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dgbbrd #endif -#:if WITH_QP - module procedure stdlib_qgbbrd +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$gbbrd + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine sgbbrd( vect, m, n, ncc, kl, ku, ab, ldab, d, e, q,ldq, pt, ldpt, & c, ldc, work, info ) @@ -361,9 +376,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_sgbbrd #endif -#:if WITH_QP - module procedure stdlib_wgbbrd +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$gbbrd + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zgbbrd( vect, m, n, ncc, kl, ku, ab, ldab, d, e, q,ldq, pt, ldpt, & c, ldc, work, rwork, info ) @@ -420,9 +438,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dgbcon #endif -#:if WITH_QP - module procedure stdlib_qgbcon +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$gbcon + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine sgbcon( norm, n, kl, ku, ab, ldab, ipiv, anorm, rcond,work, iwork, & info ) @@ -437,9 +458,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_sgbcon #endif -#:if WITH_QP - module procedure stdlib_wgbcon +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$gbcon + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zgbcon( norm, n, kl, ku, ab, ldab, ipiv, anorm, rcond,work, rwork, & info ) @@ -496,9 +520,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dgbequ #endif -#:if WITH_QP - module procedure stdlib_qgbequ +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$gbequ + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine sgbequ( m, n, kl, ku, ab, ldab, r, c, rowcnd, colcnd,amax, info ) @@ -512,9 +539,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_sgbequ #endif -#:if WITH_QP - module procedure stdlib_wgbequ +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$gbequ + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zgbequ( m, n, kl, ku, ab, ldab, r, c, rowcnd, colcnd,amax, info ) @@ -574,9 +604,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dgbequb #endif -#:if WITH_QP - module procedure stdlib_qgbequb +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$gbequb + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine sgbequb( m, n, kl, ku, ab, ldab, r, c, rowcnd, colcnd,amax, info ) @@ -590,9 +623,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_sgbequb #endif -#:if WITH_QP - module procedure stdlib_wgbequb +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$gbequb + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zgbequb( m, n, kl, ku, ab, ldab, r, c, rowcnd, colcnd,amax, info ) @@ -645,9 +681,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dgbrfs #endif -#:if WITH_QP - module procedure stdlib_qgbrfs +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$gbrfs + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine sgbrfs( trans, n, kl, ku, nrhs, ab, ldab, afb, ldafb,ipiv, b, ldb, & x, ldx, ferr, berr, work, iwork,info ) @@ -663,9 +702,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_sgbrfs #endif -#:if WITH_QP - module procedure stdlib_wgbrfs +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$gbrfs + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zgbrfs( trans, n, kl, ku, nrhs, ab, ldab, afb, ldafb,ipiv, b, ldb, & x, ldx, ferr, berr, work, rwork,info ) @@ -717,9 +759,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dgbsv #endif -#:if WITH_QP - module procedure stdlib_qgbsv +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$gbsv + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine sgbsv( n, kl, ku, nrhs, ab, ldab, ipiv, b, ldb, info ) import sp,dp,qp,ilp,lk @@ -731,9 +776,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_sgbsv #endif -#:if WITH_QP - module procedure stdlib_wgbsv +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$gbsv + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zgbsv( n, kl, ku, nrhs, ab, ldab, ipiv, b, ldb, info ) import sp,dp,qp,ilp,lk @@ -775,9 +823,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dgbtrf #endif -#:if WITH_QP - module procedure stdlib_qgbtrf +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$gbtrf + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine sgbtrf( m, n, kl, ku, ab, ldab, ipiv, info ) import sp,dp,qp,ilp,lk @@ -789,9 +840,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_sgbtrf #endif -#:if WITH_QP - module procedure stdlib_wgbtrf +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$gbtrf + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zgbtrf( m, n, kl, ku, ab, ldab, ipiv, info ) import sp,dp,qp,ilp,lk @@ -840,9 +894,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dgbtrs #endif -#:if WITH_QP - module procedure stdlib_qgbtrs +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$gbtrs + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine sgbtrs( trans, n, kl, ku, nrhs, ab, ldab, ipiv, b, ldb,info ) @@ -857,9 +914,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_sgbtrs #endif -#:if WITH_QP - module procedure stdlib_wgbtrs +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$gbtrs + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zgbtrs( trans, n, kl, ku, nrhs, ab, ldab, ipiv, b, ldb,info ) @@ -908,9 +968,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dgebak #endif -#:if WITH_QP - module procedure stdlib_qgebak +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$gebak + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine sgebak( job, side, n, ilo, ihi, scale, m, v, ldv,info ) import sp,dp,qp,ilp,lk @@ -924,9 +987,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_sgebak #endif -#:if WITH_QP - module procedure stdlib_wgebak +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$gebak + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zgebak( job, side, n, ilo, ihi, scale, m, v, ldv,info ) import sp,dp,qp,ilp,lk @@ -979,9 +1045,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dgebal #endif -#:if WITH_QP - module procedure stdlib_qgebal +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$gebal + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine sgebal( job, n, a, lda, ilo, ihi, scale, info ) import sp,dp,qp,ilp,lk @@ -995,9 +1064,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_sgebal #endif -#:if WITH_QP - module procedure stdlib_wgebal +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$gebal + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zgebal( job, n, a, lda, ilo, ihi, scale, info ) import sp,dp,qp,ilp,lk @@ -1044,9 +1116,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dgebrd #endif -#:if WITH_QP - module procedure stdlib_qgebrd +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$gebrd + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine sgebrd( m, n, a, lda, d, e, tauq, taup, work, lwork,info ) import sp,dp,qp,ilp,lk @@ -1059,9 +1134,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_sgebrd #endif -#:if WITH_QP - module procedure stdlib_wgebrd +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$gebrd + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zgebrd( m, n, a, lda, d, e, tauq, taup, work, lwork,info ) import sp,dp,qp,ilp,lk @@ -1115,9 +1193,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dgecon #endif -#:if WITH_QP - module procedure stdlib_qgecon +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$gecon + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine sgecon( norm, n, a, lda, anorm, rcond, work, iwork,info ) import sp,dp,qp,ilp,lk @@ -1132,9 +1213,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_sgecon #endif -#:if WITH_QP - module procedure stdlib_wgecon +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$gecon + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zgecon( norm, n, a, lda, anorm, rcond, work, rwork,info ) import sp,dp,qp,ilp,lk @@ -1188,9 +1272,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dgeequ #endif -#:if WITH_QP - module procedure stdlib_qgeequ +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$geequ + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine sgeequ( m, n, a, lda, r, c, rowcnd, colcnd, amax,info ) import sp,dp,qp,ilp,lk @@ -1203,9 +1290,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_sgeequ #endif -#:if WITH_QP - module procedure stdlib_wgeequ +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$geequ + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zgeequ( m, n, a, lda, r, c, rowcnd, colcnd, amax,info ) import sp,dp,qp,ilp,lk @@ -1262,9 +1352,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dgeequb #endif -#:if WITH_QP - module procedure stdlib_qgeequb +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$geequb + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine sgeequb( m, n, a, lda, r, c, rowcnd, colcnd, amax,info ) import sp,dp,qp,ilp,lk @@ -1277,9 +1370,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_sgeequb #endif -#:if WITH_QP - module procedure stdlib_wgeequb +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$geequb + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zgeequb( m, n, a, lda, r, c, rowcnd, colcnd, amax,info ) import sp,dp,qp,ilp,lk @@ -1338,9 +1434,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dgees #endif -#:if WITH_QP - module procedure stdlib_qgees +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$gees + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK subroutine sgees( jobvs, sort, select, n, a, lda, sdim, wr, wi,vs, ldvs, work, & lwork, bwork, info ) @@ -1357,9 +1456,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_sgees #endif -#:if WITH_QP - module procedure stdlib_wgees +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$gees + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK subroutine zgees( jobvs, sort, select, n, a, lda, sdim, w, vs,ldvs, work, lwork, & rwork, bwork, info ) @@ -1421,9 +1523,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dgeev #endif -#:if WITH_QP - module procedure stdlib_qgeev +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$geev + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK subroutine sgeev( jobvl, jobvr, n, a, lda, wr, wi, vl, ldvl, vr,ldvr, work, lwork, & info ) @@ -1438,9 +1543,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_sgeev #endif -#:if WITH_QP - module procedure stdlib_wgeev +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$geev + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK subroutine zgeev( jobvl, jobvr, n, a, lda, w, vl, ldvl, vr, ldvr,work, lwork, & rwork, info ) @@ -1487,9 +1595,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dgehrd #endif -#:if WITH_QP - module procedure stdlib_qgehrd +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$gehrd + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine sgehrd( n, ilo, ihi, a, lda, tau, work, lwork, info ) import sp,dp,qp,ilp,lk @@ -1502,9 +1613,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_sgehrd #endif -#:if WITH_QP - module procedure stdlib_wgehrd +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$gehrd + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zgehrd( n, ilo, ihi, a, lda, tau, work, lwork, info ) import sp,dp,qp,ilp,lk @@ -1561,9 +1675,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dgejsv #endif -#:if WITH_QP - module procedure stdlib_qgejsv +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$gejsv + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine sgejsv( joba, jobu, jobv, jobr, jobt, jobp,m, n, a, lda, sva, u, & ldu, v, ldv,work, lwork, iwork, info ) @@ -1578,9 +1695,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_sgejsv #endif -#:if WITH_QP - module procedure stdlib_wgejsv +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$gejsv + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zgejsv( joba, jobu, jobv, jobr, jobt, jobp,m, n, a, lda, sva, u, & ldu, v, ldv,cwork, lwork, rwork, lrwork, iwork, info ) @@ -1631,9 +1751,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dgelq #endif -#:if WITH_QP - module procedure stdlib_qgelq +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$gelq + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine sgelq( m, n, a, lda, t, tsize, work, lwork,info ) import sp,dp,qp,ilp,lk @@ -1646,9 +1769,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_sgelq #endif -#:if WITH_QP - module procedure stdlib_wgelq +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$gelq + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zgelq( m, n, a, lda, t, tsize, work, lwork,info ) import sp,dp,qp,ilp,lk @@ -1696,9 +1822,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dgelqf #endif -#:if WITH_QP - module procedure stdlib_qgelqf +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$gelqf + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine sgelqf( m, n, a, lda, tau, work, lwork, info ) import sp,dp,qp,ilp,lk @@ -1711,9 +1840,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_sgelqf #endif -#:if WITH_QP - module procedure stdlib_wgelqf +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$gelqf + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zgelqf( m, n, a, lda, tau, work, lwork, info ) import sp,dp,qp,ilp,lk @@ -1757,9 +1889,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dgelqt #endif -#:if WITH_QP - module procedure stdlib_qgelqt +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$gelqt + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine sgelqt( m, n, mb, a, lda, t, ldt, work, info ) import sp,dp,qp,ilp,lk @@ -1772,9 +1907,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_sgelqt #endif -#:if WITH_QP - module procedure stdlib_wgelqt +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$gelqt + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zgelqt( m, n, mb, a, lda, t, ldt, work, info ) import sp,dp,qp,ilp,lk @@ -1820,9 +1958,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dgelqt3 #endif -#:if WITH_QP - module procedure stdlib_qgelqt3 +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$gelqt3 + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure recursive subroutine sgelqt3( m, n, a, lda, t, ldt, info ) import sp,dp,qp,ilp,lk @@ -1835,9 +1976,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_sgelqt3 #endif -#:if WITH_QP - module procedure stdlib_wgelqt3 +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$gelqt3 + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure recursive subroutine zgelqt3( m, n, a, lda, t, ldt, info ) import sp,dp,qp,ilp,lk @@ -1899,9 +2043,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dgels #endif -#:if WITH_QP - module procedure stdlib_qgels +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$gels + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK subroutine sgels( trans, m, n, nrhs, a, lda, b, ldb, work, lwork,info ) import sp,dp,qp,ilp,lk @@ -1915,9 +2062,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_sgels #endif -#:if WITH_QP - module procedure stdlib_wgels +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$gels + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK subroutine zgels( trans, m, n, nrhs, a, lda, b, ldb, work, lwork,info ) import sp,dp,qp,ilp,lk @@ -1990,9 +2140,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dgelsd #endif -#:if WITH_QP - module procedure stdlib_qgelsd +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$gelsd + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK subroutine sgelsd( m, n, nrhs, a, lda, b, ldb, s, rcond,rank, work, lwork, iwork, & info ) @@ -2007,9 +2160,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_sgelsd #endif -#:if WITH_QP - module procedure stdlib_wgelsd +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$gelsd + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK subroutine zgelsd( m, n, nrhs, a, lda, b, ldb, s, rcond, rank,work, lwork, rwork, & iwork, info ) @@ -2071,9 +2227,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dgelss #endif -#:if WITH_QP - module procedure stdlib_qgelss +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$gelss + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK subroutine sgelss( m, n, nrhs, a, lda, b, ldb, s, rcond, rank,work, lwork, info ) @@ -2088,9 +2247,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_sgelss #endif -#:if WITH_QP - module procedure stdlib_wgelss +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$gelss + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK subroutine zgelss( m, n, nrhs, a, lda, b, ldb, s, rcond, rank,work, lwork, rwork, & info ) @@ -2174,9 +2336,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dgelsy #endif -#:if WITH_QP - module procedure stdlib_qgelsy +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$gelsy + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK subroutine sgelsy( m, n, nrhs, a, lda, b, ldb, jpvt, rcond, rank,work, lwork, info & ) @@ -2192,9 +2357,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_sgelsy #endif -#:if WITH_QP - module procedure stdlib_wgelsy +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$gelsy + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK subroutine zgelsy( m, n, nrhs, a, lda, b, ldb, jpvt, rcond, rank,work, lwork, & rwork, info ) @@ -2253,9 +2421,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dgemlq #endif -#:if WITH_QP - module procedure stdlib_qgemlq +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$gemlq + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine sgemlq( side, trans, m, n, k, a, lda, t, tsize,c, ldc, work, lwork,& info ) @@ -2271,9 +2442,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_sgemlq #endif -#:if WITH_QP - module procedure stdlib_wgemlq +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$gemlq + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zgemlq( side, trans, m, n, k, a, lda, t, tsize,c, ldc, work, lwork,& info ) @@ -2333,9 +2507,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dgemlqt #endif -#:if WITH_QP - module procedure stdlib_qgemlqt +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$gemlqt + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine sgemlqt( side, trans, m, n, k, mb, v, ldv, t, ldt,c, ldc, work, & info ) @@ -2351,9 +2528,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_sgemlqt #endif -#:if WITH_QP - module procedure stdlib_wgemlqt +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$gemlqt + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zgemlqt( side, trans, m, n, k, mb, v, ldv, t, ldt,c, ldc, work, & info ) @@ -2411,9 +2591,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dgemqr #endif -#:if WITH_QP - module procedure stdlib_qgemqr +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$gemqr + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine sgemqr( side, trans, m, n, k, a, lda, t, tsize,c, ldc, work, lwork,& info ) @@ -2429,9 +2612,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_sgemqr #endif -#:if WITH_QP - module procedure stdlib_wgemqr +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$gemqr + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zgemqr( side, trans, m, n, k, a, lda, t, tsize,c, ldc, work, lwork,& info ) @@ -2491,9 +2677,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dgemqrt #endif -#:if WITH_QP - module procedure stdlib_qgemqrt +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$gemqrt + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine sgemqrt( side, trans, m, n, k, nb, v, ldv, t, ldt,c, ldc, work, & info ) @@ -2509,9 +2698,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_sgemqrt #endif -#:if WITH_QP - module procedure stdlib_wgemqrt +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$gemqrt + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zgemqrt( side, trans, m, n, k, nb, v, ldv, t, ldt,c, ldc, work, & info ) @@ -2558,9 +2750,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dgeqlf #endif -#:if WITH_QP - module procedure stdlib_qgeqlf +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$geqlf + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine sgeqlf( m, n, a, lda, tau, work, lwork, info ) import sp,dp,qp,ilp,lk @@ -2573,9 +2768,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_sgeqlf #endif -#:if WITH_QP - module procedure stdlib_wgeqlf +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$geqlf + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zgeqlf( m, n, a, lda, tau, work, lwork, info ) import sp,dp,qp,ilp,lk @@ -2624,9 +2822,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dgeqr #endif -#:if WITH_QP - module procedure stdlib_qgeqr +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$geqr + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine sgeqr( m, n, a, lda, t, tsize, work, lwork,info ) import sp,dp,qp,ilp,lk @@ -2639,9 +2840,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_sgeqr #endif -#:if WITH_QP - module procedure stdlib_wgeqr +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$geqr + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zgeqr( m, n, a, lda, t, tsize, work, lwork,info ) import sp,dp,qp,ilp,lk @@ -2691,9 +2895,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dgeqr2p #endif -#:if WITH_QP - module procedure stdlib_qgeqr2p +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$geqr2p + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK subroutine sgeqr2p( m, n, a, lda, tau, work, info ) import sp,dp,qp,ilp,lk @@ -2706,9 +2913,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_sgeqr2p #endif -#:if WITH_QP - module procedure stdlib_wgeqr2p +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$geqr2p + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK subroutine zgeqr2p( m, n, a, lda, tau, work, info ) import sp,dp,qp,ilp,lk @@ -2757,9 +2967,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dgeqrf #endif -#:if WITH_QP - module procedure stdlib_qgeqrf +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$geqrf + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine sgeqrf( m, n, a, lda, tau, work, lwork, info ) import sp,dp,qp,ilp,lk @@ -2772,9 +2985,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_sgeqrf #endif -#:if WITH_QP - module procedure stdlib_wgeqrf +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$geqrf + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zgeqrf( m, n, a, lda, tau, work, lwork, info ) import sp,dp,qp,ilp,lk @@ -2824,9 +3040,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dgeqrfp #endif -#:if WITH_QP - module procedure stdlib_qgeqrfp +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$geqrfp + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK subroutine sgeqrfp( m, n, a, lda, tau, work, lwork, info ) import sp,dp,qp,ilp,lk @@ -2839,9 +3058,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_sgeqrfp #endif -#:if WITH_QP - module procedure stdlib_wgeqrfp +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$geqrfp + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK subroutine zgeqrfp( m, n, a, lda, tau, work, lwork, info ) import sp,dp,qp,ilp,lk @@ -2885,9 +3107,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dgeqrt #endif -#:if WITH_QP - module procedure stdlib_qgeqrt +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$geqrt + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine sgeqrt( m, n, nb, a, lda, t, ldt, work, info ) import sp,dp,qp,ilp,lk @@ -2900,9 +3125,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_sgeqrt #endif -#:if WITH_QP - module procedure stdlib_wgeqrt +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$geqrt + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zgeqrt( m, n, nb, a, lda, t, ldt, work, info ) import sp,dp,qp,ilp,lk @@ -2946,9 +3174,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dgeqrt2 #endif -#:if WITH_QP - module procedure stdlib_qgeqrt2 +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$geqrt2 + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine sgeqrt2( m, n, a, lda, t, ldt, info ) import sp,dp,qp,ilp,lk @@ -2961,9 +3192,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_sgeqrt2 #endif -#:if WITH_QP - module procedure stdlib_wgeqrt2 +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$geqrt2 + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zgeqrt2( m, n, a, lda, t, ldt, info ) import sp,dp,qp,ilp,lk @@ -3009,9 +3243,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dgeqrt3 #endif -#:if WITH_QP - module procedure stdlib_qgeqrt3 +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$geqrt3 + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure recursive subroutine sgeqrt3( m, n, a, lda, t, ldt, info ) import sp,dp,qp,ilp,lk @@ -3024,9 +3261,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_sgeqrt3 #endif -#:if WITH_QP - module procedure stdlib_wgeqrt3 +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$geqrt3 + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure recursive subroutine zgeqrt3( m, n, a, lda, t, ldt, info ) import sp,dp,qp,ilp,lk @@ -3078,9 +3318,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dgerfs #endif -#:if WITH_QP - module procedure stdlib_qgerfs +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$gerfs + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine sgerfs( trans, n, nrhs, a, lda, af, ldaf, ipiv, b, ldb,x, ldx, & ferr, berr, work, iwork, info ) @@ -3096,9 +3339,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_sgerfs #endif -#:if WITH_QP - module procedure stdlib_wgerfs +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$gerfs + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zgerfs( trans, n, nrhs, a, lda, af, ldaf, ipiv, b, ldb,x, ldx, & ferr, berr, work, rwork, info ) @@ -3146,9 +3392,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dgerqf #endif -#:if WITH_QP - module procedure stdlib_qgerqf +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$gerqf + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine sgerqf( m, n, a, lda, tau, work, lwork, info ) import sp,dp,qp,ilp,lk @@ -3161,9 +3410,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_sgerqf #endif -#:if WITH_QP - module procedure stdlib_wgerqf +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$gerqf + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zgerqf( m, n, a, lda, tau, work, lwork, info ) import sp,dp,qp,ilp,lk @@ -3227,9 +3479,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dgesdd #endif -#:if WITH_QP - module procedure stdlib_qgesdd +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$gesdd + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK subroutine sgesdd( jobz, m, n, a, lda, s, u, ldu, vt, ldvt,work, lwork, iwork, & info ) @@ -3244,9 +3499,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_sgesdd #endif -#:if WITH_QP - module procedure stdlib_wgesdd +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$gesdd + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK subroutine zgesdd( jobz, m, n, a, lda, s, u, ldu, vt, ldvt,work, lwork, rwork, & iwork, info ) @@ -3298,9 +3556,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dgesv #endif -#:if WITH_QP - module procedure stdlib_qgesv +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$gesv + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine sgesv( n, nrhs, a, lda, ipiv, b, ldb, info ) import sp,dp,qp,ilp,lk @@ -3312,9 +3573,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_sgesv #endif -#:if WITH_QP - module procedure stdlib_wgesv +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$gesv + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zgesv( n, nrhs, a, lda, ipiv, b, ldb, info ) import sp,dp,qp,ilp,lk @@ -3371,9 +3635,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dgesvd #endif -#:if WITH_QP - module procedure stdlib_qgesvd +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$gesvd + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK subroutine sgesvd( jobu, jobvt, m, n, a, lda, s, u, ldu, vt, ldvt,work, lwork, & info ) @@ -3388,9 +3655,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_sgesvd #endif -#:if WITH_QP - module procedure stdlib_wgesvd +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$gesvd + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK subroutine zgesvd( jobu, jobvt, m, n, a, lda, s, u, ldu,vt, ldvt, work, lwork, & rwork, info ) @@ -3451,9 +3721,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dgesvdq #endif -#:if WITH_QP - module procedure stdlib_qgesvdq +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$gesvdq + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK subroutine sgesvdq( joba, jobp, jobr, jobu, jobv, m, n, a, lda,s, u, ldu, v, ldv, & numrank, iwork, liwork,work, lwork, rwork, lrwork, info ) @@ -3469,9 +3742,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_sgesvdq #endif -#:if WITH_QP - module procedure stdlib_wgesvdq +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$gesvdq + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK subroutine zgesvdq( joba, jobp, jobr, jobu, jobv, m, n, a, lda,s, u, ldu, v, ldv, & numrank, iwork, liwork,cwork, lcwork, rwork, lrwork, info ) @@ -3531,9 +3807,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dgesvj #endif -#:if WITH_QP - module procedure stdlib_qgesvj +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$gesvj + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine sgesvj( joba, jobu, jobv, m, n, a, lda, sva, mv, v,ldv, work, & lwork, info ) @@ -3548,9 +3827,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_sgesvj #endif -#:if WITH_QP - module procedure stdlib_wgesvj +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$gesvj + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zgesvj( joba, jobu, jobv, m, n, a, lda, sva, mv, v,ldv, cwork, & lwork, rwork, lrwork, info ) @@ -3601,9 +3883,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dgetrf #endif -#:if WITH_QP - module procedure stdlib_qgetrf +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$getrf + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine sgetrf( m, n, a, lda, ipiv, info ) import sp,dp,qp,ilp,lk @@ -3615,9 +3900,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_sgetrf #endif -#:if WITH_QP - module procedure stdlib_wgetrf +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$getrf + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zgetrf( m, n, a, lda, ipiv, info ) import sp,dp,qp,ilp,lk @@ -3675,9 +3963,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dgetrf2 #endif -#:if WITH_QP - module procedure stdlib_qgetrf2 +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$getrf2 + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure recursive subroutine sgetrf2( m, n, a, lda, ipiv, info ) import sp,dp,qp,ilp,lk @@ -3689,9 +3980,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_sgetrf2 #endif -#:if WITH_QP - module procedure stdlib_wgetrf2 +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$getrf2 + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure recursive subroutine zgetrf2( m, n, a, lda, ipiv, info ) import sp,dp,qp,ilp,lk @@ -3736,9 +4030,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dgetri #endif -#:if WITH_QP - module procedure stdlib_qgetri +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$getri + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine sgetri( n, a, lda, ipiv, work, lwork, info ) import sp,dp,qp,ilp,lk @@ -3751,9 +4048,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_sgetri #endif -#:if WITH_QP - module procedure stdlib_wgetri +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$getri + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zgetri( n, a, lda, ipiv, work, lwork, info ) import sp,dp,qp,ilp,lk @@ -3801,9 +4101,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dgetrs #endif -#:if WITH_QP - module procedure stdlib_qgetrs +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$getrs + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine sgetrs( trans, n, nrhs, a, lda, ipiv, b, ldb, info ) import sp,dp,qp,ilp,lk @@ -3817,9 +4120,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_sgetrs #endif -#:if WITH_QP - module procedure stdlib_wgetrs +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$getrs + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zgetrs( trans, n, nrhs, a, lda, ipiv, b, ldb, info ) import sp,dp,qp,ilp,lk @@ -3882,9 +4188,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dgetsls #endif -#:if WITH_QP - module procedure stdlib_qgetsls +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$getsls + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK subroutine sgetsls( trans, m, n, nrhs, a, lda, b, ldb,work, lwork, info ) import sp,dp,qp,ilp,lk @@ -3898,9 +4207,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_sgetsls #endif -#:if WITH_QP - module procedure stdlib_wgetsls +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$getsls + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK subroutine zgetsls( trans, m, n, nrhs, a, lda, b, ldb,work, lwork, info ) import sp,dp,qp,ilp,lk @@ -3957,9 +4269,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dgetsqrhrt #endif -#:if WITH_QP - module procedure stdlib_qgetsqrhrt +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$getsqrhrt + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine sgetsqrhrt( m, n, mb1, nb1, nb2, a, lda, t, ldt, work,lwork, info ) @@ -3973,9 +4288,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_sgetsqrhrt #endif -#:if WITH_QP - module procedure stdlib_wgetsqrhrt +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$getsqrhrt + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zgetsqrhrt( m, n, mb1, nb1, nb2, a, lda, t, ldt, work,lwork, info ) @@ -4026,9 +4344,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dggbak #endif -#:if WITH_QP - module procedure stdlib_qggbak +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$ggbak + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine sggbak( job, side, n, ilo, ihi, lscale, rscale, m, v,ldv, info ) @@ -4043,9 +4364,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_sggbak #endif -#:if WITH_QP - module procedure stdlib_wggbak +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$ggbak + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zggbak( job, side, n, ilo, ihi, lscale, rscale, m, v,ldv, info ) @@ -4102,9 +4426,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dggbal #endif -#:if WITH_QP - module procedure stdlib_qggbal +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$ggbal + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine sggbal( job, n, a, lda, b, ldb, ilo, ihi, lscale,rscale, work, & info ) @@ -4119,9 +4446,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_sggbal #endif -#:if WITH_QP - module procedure stdlib_wggbal +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$ggbal + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zggbal( job, n, a, lda, b, ldb, ilo, ihi, lscale,rscale, work, & info ) @@ -4196,9 +4526,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dgges #endif -#:if WITH_QP - module procedure stdlib_qgges +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$gges + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK subroutine sgges( jobvsl, jobvsr, sort, selctg, n, a, lda, b, ldb,sdim, alphar, & alphai, beta, vsl, ldvsl, vsr,ldvsr, work, lwork, bwork, info ) @@ -4216,9 +4549,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_sgges #endif -#:if WITH_QP - module procedure stdlib_wgges +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$gges + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK subroutine zgges( jobvsl, jobvsr, sort, selctg, n, a, lda, b, ldb,sdim, alpha, & beta, vsl, ldvsl, vsr, ldvsr, work,lwork, rwork, bwork, info ) @@ -4288,9 +4624,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dggev #endif -#:if WITH_QP - module procedure stdlib_qggev +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$ggev + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK subroutine sggev( jobvl, jobvr, n, a, lda, b, ldb, alphar, alphai,beta, vl, ldvl, & vr, ldvr, work, lwork, info ) @@ -4306,9 +4645,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_sggev #endif -#:if WITH_QP - module procedure stdlib_wggev +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$ggev + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK subroutine zggev( jobvl, jobvr, n, a, lda, b, ldb, alpha, beta,vl, ldvl, vr, ldvr, & work, lwork, rwork, info ) @@ -4374,9 +4716,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dggglm #endif -#:if WITH_QP - module procedure stdlib_qggglm +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$ggglm + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine sggglm( n, m, p, a, lda, b, ldb, d, x, y, work, lwork,info ) @@ -4390,9 +4735,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_sggglm #endif -#:if WITH_QP - module procedure stdlib_wggglm +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$ggglm + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zggglm( n, m, p, a, lda, b, ldb, d, x, y, work, lwork,info ) @@ -4460,9 +4808,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dgghrd #endif -#:if WITH_QP - module procedure stdlib_qgghrd +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$gghrd + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine sgghrd( compq, compz, n, ilo, ihi, a, lda, b, ldb, q,ldq, z, ldz, & info ) @@ -4476,9 +4827,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_sgghrd #endif -#:if WITH_QP - module procedure stdlib_wgghrd +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$gghrd + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zgghrd( compq, compz, n, ilo, ihi, a, lda, b, ldb, q,ldq, z, ldz, & info ) @@ -4535,9 +4889,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dgglse #endif -#:if WITH_QP - module procedure stdlib_qgglse +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$gglse + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine sgglse( m, n, p, a, lda, b, ldb, c, d, x, work, lwork,info ) @@ -4551,9 +4908,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_sgglse #endif -#:if WITH_QP - module procedure stdlib_wgglse +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$gglse + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zgglse( m, n, p, a, lda, b, ldb, c, d, x, work, lwork,info ) @@ -4616,9 +4976,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dggqrf #endif -#:if WITH_QP - module procedure stdlib_qggqrf +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$ggqrf + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine sggqrf( n, m, p, a, lda, taua, b, ldb, taub, work,lwork, info ) @@ -4632,9 +4995,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_sggqrf #endif -#:if WITH_QP - module procedure stdlib_wggqrf +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$ggqrf + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zggqrf( n, m, p, a, lda, taua, b, ldb, taub, work,lwork, info ) @@ -4697,9 +5063,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dggrqf #endif -#:if WITH_QP - module procedure stdlib_qggrqf +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$ggrqf + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine sggrqf( m, p, n, a, lda, taua, b, ldb, taub, work,lwork, info ) @@ -4713,9 +5082,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_sggrqf #endif -#:if WITH_QP - module procedure stdlib_wggrqf +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$ggrqf + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zggrqf( m, p, n, a, lda, taua, b, ldb, taub, work,lwork, info ) @@ -4769,9 +5141,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dgsvj0 #endif -#:if WITH_QP - module procedure stdlib_qgsvj0 +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$gsvj0 + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine sgsvj0( jobv, m, n, a, lda, d, sva, mv, v, ldv, eps,sfmin, tol, & nsweep, work, lwork, info ) @@ -4787,9 +5162,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_sgsvj0 #endif -#:if WITH_QP - module procedure stdlib_wgsvj0 +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$gsvj0 + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zgsvj0( jobv, m, n, a, lda, d, sva, mv, v, ldv, eps,sfmin, tol, & nsweep, work, lwork, info ) @@ -4866,9 +5244,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dgsvj1 #endif -#:if WITH_QP - module procedure stdlib_qgsvj1 +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$gsvj1 + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine sgsvj1( jobv, m, n, n1, a, lda, d, sva, mv, v, ldv,eps, sfmin, tol,& nsweep, work, lwork, info ) @@ -4884,9 +5265,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_sgsvj1 #endif -#:if WITH_QP - module procedure stdlib_wgsvj1 +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$gsvj1 + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zgsvj1( jobv, m, n, n1, a, lda, d, sva, mv, v, ldv,eps, sfmin, tol,& nsweep, work, lwork, info ) @@ -4943,9 +5327,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dgtcon #endif -#:if WITH_QP - module procedure stdlib_qgtcon +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$gtcon + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine sgtcon( norm, n, dl, d, du, du2, ipiv, anorm, rcond,work, iwork, & info ) @@ -4960,9 +5347,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_sgtcon #endif -#:if WITH_QP - module procedure stdlib_wgtcon +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$gtcon + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zgtcon( norm, n, dl, d, du, du2, ipiv, anorm, rcond,work, info ) @@ -5020,9 +5410,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dgtrfs #endif -#:if WITH_QP - module procedure stdlib_qgtrfs +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$gtrfs + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine sgtrfs( trans, n, nrhs, dl, d, du, dlf, df, duf, du2,ipiv, b, ldb, & x, ldx, ferr, berr, work, iwork,info ) @@ -5039,9 +5432,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_sgtrfs #endif -#:if WITH_QP - module procedure stdlib_wgtrfs +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$gtrfs + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zgtrfs( trans, n, nrhs, dl, d, du, dlf, df, duf, du2,ipiv, b, ldb, & x, ldx, ferr, berr, work, rwork,info ) @@ -5092,9 +5488,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dgtsv #endif -#:if WITH_QP - module procedure stdlib_qgtsv +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$gtsv + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine sgtsv( n, nrhs, dl, d, du, b, ldb, info ) import sp,dp,qp,ilp,lk @@ -5106,9 +5505,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_sgtsv #endif -#:if WITH_QP - module procedure stdlib_wgtsv +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$gtsv + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zgtsv( n, nrhs, dl, d, du, b, ldb, info ) import sp,dp,qp,ilp,lk @@ -5156,9 +5558,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dgttrf #endif -#:if WITH_QP - module procedure stdlib_qgttrf +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$gttrf + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine sgttrf( n, dl, d, du, du2, ipiv, info ) import sp,dp,qp,ilp,lk @@ -5171,9 +5576,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_sgttrf #endif -#:if WITH_QP - module procedure stdlib_wgttrf +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$gttrf + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zgttrf( n, dl, d, du, du2, ipiv, info ) import sp,dp,qp,ilp,lk @@ -5221,9 +5629,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dgttrs #endif -#:if WITH_QP - module procedure stdlib_qgttrs +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$gttrs + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine sgttrs( trans, n, nrhs, dl, d, du, du2, ipiv, b, ldb,info ) import sp,dp,qp,ilp,lk @@ -5237,9 +5648,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_sgttrs #endif -#:if WITH_QP - module procedure stdlib_wgttrs +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$gttrs + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zgttrs( trans, n, nrhs, dl, d, du, du2, ipiv, b, ldb,info ) import sp,dp,qp,ilp,lk @@ -5274,9 +5688,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_chb2st_kernels #endif -#:if WITH_QP - module procedure stdlib_whb2st_kernels +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$hb2st_kernels + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zhb2st_kernels( uplo, wantz, ttype,st, ed, sweep, n, nb, ib,a, & lda, v, tau, ldvt, work) @@ -5313,9 +5730,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_chbev #endif -#:if WITH_QP - module procedure stdlib_whbev +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$hbev + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK subroutine zhbev( jobz, uplo, n, kd, ab, ldab, w, z, ldz, work,rwork, info ) @@ -5360,9 +5780,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_chbevd #endif -#:if WITH_QP - module procedure stdlib_whbevd +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$hbevd + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK subroutine zhbevd( jobz, uplo, n, kd, ab, ldab, w, z, ldz, work,lwork, rwork, & lrwork, iwork, liwork, info ) @@ -5406,9 +5829,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_chbgst #endif -#:if WITH_QP - module procedure stdlib_whbgst +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$hbgst + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zhbgst( vect, uplo, n, ka, kb, ab, ldab, bb, ldbb, x,ldx, work, & rwork, info ) @@ -5449,9 +5875,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_chbgv #endif -#:if WITH_QP - module procedure stdlib_whbgv +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$hbgv + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zhbgv( jobz, uplo, n, ka, kb, ab, ldab, bb, ldbb, w, z,ldz, work, & rwork, info ) @@ -5498,9 +5927,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_chbgvd #endif -#:if WITH_QP - module procedure stdlib_whbgvd +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$hbgvd + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zhbgvd( jobz, uplo, n, ka, kb, ab, ldab, bb, ldbb, w,z, ldz, work, & lwork, rwork, lrwork, iwork,liwork, info ) @@ -5539,9 +5971,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_chbtrd #endif -#:if WITH_QP - module procedure stdlib_whbtrd +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$hbtrd + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zhbtrd( vect, uplo, n, kd, ab, ldab, d, e, q, ldq,work, info ) @@ -5582,9 +6017,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_checon #endif -#:if WITH_QP - module procedure stdlib_whecon +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$hecon + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zhecon( uplo, n, a, lda, ipiv, anorm, rcond, work,info ) import sp,dp,qp,ilp,lk @@ -5626,9 +6064,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_checon_rook #endif -#:if WITH_QP - module procedure stdlib_whecon_rook +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$hecon_rook + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zhecon_rook( uplo, n, a, lda, ipiv, anorm, rcond, work,info ) @@ -5671,9 +6112,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_cheequb #endif -#:if WITH_QP - module procedure stdlib_wheequb +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$heequb + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zheequb( uplo, n, a, lda, s, scond, amax, work, info ) import sp,dp,qp,ilp,lk @@ -5709,9 +6153,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_cheev #endif -#:if WITH_QP - module procedure stdlib_wheev +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$heev + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK subroutine zheev( jobz, uplo, n, a, lda, w, work, lwork, rwork,info ) import sp,dp,qp,ilp,lk @@ -5755,9 +6202,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_cheevd #endif -#:if WITH_QP - module procedure stdlib_wheevd +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$heevd + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK subroutine zheevd( jobz, uplo, n, a, lda, w, work, lwork, rwork,lrwork, iwork, & liwork, info ) @@ -5844,9 +6294,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_cheevr #endif -#:if WITH_QP - module procedure stdlib_wheevr +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$heevr + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK subroutine zheevr( jobz, range, uplo, n, a, lda, vl, vu, il, iu,abstol, m, w, z, & ldz, isuppz, work, lwork,rwork, lrwork, iwork, liwork, info ) @@ -5887,9 +6340,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_chegst #endif -#:if WITH_QP - module procedure stdlib_whegst +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$hegst + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zhegst( itype, uplo, n, a, lda, b, ldb, info ) import sp,dp,qp,ilp,lk @@ -5927,9 +6383,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_chegv #endif -#:if WITH_QP - module procedure stdlib_whegv +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$hegv + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK subroutine zhegv( itype, jobz, uplo, n, a, lda, b, ldb, w, work,lwork, rwork, info & ) @@ -5976,9 +6435,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_chegvd #endif -#:if WITH_QP - module procedure stdlib_whegvd +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$hegvd + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK subroutine zhegvd( itype, jobz, uplo, n, a, lda, b, ldb, w, work,lwork, rwork, & lrwork, iwork, liwork, info ) @@ -6018,9 +6480,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_cherfs #endif -#:if WITH_QP - module procedure stdlib_wherfs +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$herfs + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zherfs( uplo, n, nrhs, a, lda, af, ldaf, ipiv, b, ldb,x, ldx, ferr,& berr, work, rwork, info ) @@ -6067,9 +6532,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_chesv #endif -#:if WITH_QP - module procedure stdlib_whesv +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$hesv + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zhesv( uplo, n, nrhs, a, lda, ipiv, b, ldb, work,lwork, info ) @@ -6113,9 +6581,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_chesv_aa #endif -#:if WITH_QP - module procedure stdlib_whesv_aa +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$hesv_aa + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zhesv_aa( uplo, n, nrhs, a, lda, ipiv, b, ldb, work,lwork, info ) @@ -6163,9 +6634,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_chesv_rk #endif -#:if WITH_QP - module procedure stdlib_whesv_rk +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$hesv_rk + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zhesv_rk( uplo, n, nrhs, a, lda, e, ipiv, b, ldb, work,lwork, info & ) @@ -6215,9 +6689,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_chesv_rook #endif -#:if WITH_QP - module procedure stdlib_whesv_rook +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$hesv_rook + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zhesv_rook( uplo, n, nrhs, a, lda, ipiv, b, ldb, work,lwork, info ) @@ -6250,9 +6727,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_cheswapr #endif -#:if WITH_QP - module procedure stdlib_wheswapr +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$heswapr + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zheswapr( uplo, n, a, lda, i1, i2) import sp,dp,qp,ilp,lk @@ -6291,9 +6771,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_chetf2_rk #endif -#:if WITH_QP - module procedure stdlib_whetf2_rk +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$hetf2_rk + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zhetf2_rk( uplo, n, a, lda, e, ipiv, info ) import sp,dp,qp,ilp,lk @@ -6331,9 +6814,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_chetf2_rook #endif -#:if WITH_QP - module procedure stdlib_whetf2_rook +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$hetf2_rook + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zhetf2_rook( uplo, n, a, lda, ipiv, info ) import sp,dp,qp,ilp,lk @@ -6368,9 +6854,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_chetrd #endif -#:if WITH_QP - module procedure stdlib_whetrd +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$hetrd + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zhetrd( uplo, n, a, lda, d, e, tau, work, lwork, info ) import sp,dp,qp,ilp,lk @@ -6408,9 +6897,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_chetrd_hb2st #endif -#:if WITH_QP - module procedure stdlib_whetrd_hb2st +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$hetrd_hb2st + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK subroutine zhetrd_hb2st( stage1, vect, uplo, n, kd, ab, ldab,d, e, hous, & lhous, work, lwork, info ) @@ -6448,9 +6940,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_chetrd_he2hb #endif -#:if WITH_QP - module procedure stdlib_whetrd_he2hb +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$hetrd_he2hb + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK subroutine zhetrd_he2hb( uplo, n, kd, a, lda, ab, ldab, tau,work, lwork, info & ) @@ -6491,9 +6986,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_chetrf #endif -#:if WITH_QP - module procedure stdlib_whetrf +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$hetrf + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zhetrf( uplo, n, a, lda, ipiv, work, lwork, info ) import sp,dp,qp,ilp,lk @@ -6531,9 +7029,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_chetrf_aa #endif -#:if WITH_QP - module procedure stdlib_whetrf_aa +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$hetrf_aa + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zhetrf_aa( uplo, n, a, lda, ipiv, work, lwork, info) import sp,dp,qp,ilp,lk @@ -6574,9 +7075,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_chetrf_rk #endif -#:if WITH_QP - module procedure stdlib_whetrf_rk +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$hetrf_rk + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zhetrf_rk( uplo, n, a, lda, e, ipiv, work, lwork,info ) import sp,dp,qp,ilp,lk @@ -6616,9 +7120,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_chetrf_rook #endif -#:if WITH_QP - module procedure stdlib_whetrf_rook +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$hetrf_rook + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zhetrf_rook( uplo, n, a, lda, ipiv, work, lwork, info ) import sp,dp,qp,ilp,lk @@ -6653,9 +7160,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_chetri #endif -#:if WITH_QP - module procedure stdlib_whetri +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$hetri + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zhetri( uplo, n, a, lda, ipiv, work, info ) import sp,dp,qp,ilp,lk @@ -6690,9 +7200,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_chetri_rook #endif -#:if WITH_QP - module procedure stdlib_whetri_rook +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$hetri_rook + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zhetri_rook( uplo, n, a, lda, ipiv, work, info ) import sp,dp,qp,ilp,lk @@ -6727,9 +7240,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_chetrs #endif -#:if WITH_QP - module procedure stdlib_whetrs +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$hetrs + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zhetrs( uplo, n, nrhs, a, lda, ipiv, b, ldb, info ) import sp,dp,qp,ilp,lk @@ -6764,9 +7280,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_chetrs2 #endif -#:if WITH_QP - module procedure stdlib_whetrs2 +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$hetrs2 + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zhetrs2( uplo, n, nrhs, a, lda, ipiv, b, ldb,work, info ) import sp,dp,qp,ilp,lk @@ -6807,9 +7326,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_chetrs_3 #endif -#:if WITH_QP - module procedure stdlib_whetrs_3 +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$hetrs_3 + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zhetrs_3( uplo, n, nrhs, a, lda, e, ipiv, b, ldb,info ) import sp,dp,qp,ilp,lk @@ -6846,9 +7368,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_chetrs_aa #endif -#:if WITH_QP - module procedure stdlib_whetrs_aa +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$hetrs_aa + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zhetrs_aa( uplo, n, nrhs, a, lda, ipiv, b, ldb,work, lwork, info ) @@ -6885,9 +7410,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_chetrs_rook #endif -#:if WITH_QP - module procedure stdlib_whetrs_rook +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$hetrs_rook + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zhetrs_rook( uplo, n, nrhs, a, lda, ipiv, b, ldb,info ) import sp,dp,qp,ilp,lk @@ -6927,9 +7455,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_chfrk #endif -#:if WITH_QP - module procedure stdlib_whfrk +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$hfrk + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zhfrk( transr, uplo, trans, n, k, alpha, a, lda, beta,c ) import sp,dp,qp,ilp,lk @@ -7010,9 +7541,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dhgeqz #endif -#:if WITH_QP - module procedure stdlib_qhgeqz +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$hgeqz + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK subroutine shgeqz( job, compq, compz, n, ilo, ihi, h, ldh, t, ldt,alphar, alphai, & beta, q, ldq, z, ldz, work,lwork, info ) @@ -7027,9 +7561,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_shgeqz #endif -#:if WITH_QP - module procedure stdlib_whgeqz +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$hgeqz + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK subroutine zhgeqz( job, compq, compz, n, ilo, ihi, h, ldh, t, ldt,alpha, beta, q, & ldq, z, ldz, work, lwork,rwork, info ) @@ -7070,9 +7607,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_chpcon #endif -#:if WITH_QP - module procedure stdlib_whpcon +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$hpcon + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zhpcon( uplo, n, ap, ipiv, anorm, rcond, work, info ) import sp,dp,qp,ilp,lk @@ -7109,9 +7649,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_chpev #endif -#:if WITH_QP - module procedure stdlib_whpev +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$hpev + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK subroutine zhpev( jobz, uplo, n, ap, w, z, ldz, work, rwork,info ) import sp,dp,qp,ilp,lk @@ -7155,9 +7698,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_chpevd #endif -#:if WITH_QP - module procedure stdlib_whpevd +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$hpevd + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK subroutine zhpevd( jobz, uplo, n, ap, w, z, ldz, work, lwork,rwork, lrwork, iwork, & liwork, info ) @@ -7198,9 +7744,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_chpgst #endif -#:if WITH_QP - module procedure stdlib_whpgst +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$hpgst + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zhpgst( itype, uplo, n, ap, bp, info ) import sp,dp,qp,ilp,lk @@ -7239,9 +7788,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_chpgv #endif -#:if WITH_QP - module procedure stdlib_whpgv +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$hpgv + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK subroutine zhpgv( itype, jobz, uplo, n, ap, bp, w, z, ldz, work,rwork, info ) @@ -7289,9 +7841,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_chpgvd #endif -#:if WITH_QP - module procedure stdlib_whpgvd +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$hpgvd + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK subroutine zhpgvd( itype, jobz, uplo, n, ap, bp, w, z, ldz, work,lwork, rwork, & lrwork, iwork, liwork, info ) @@ -7332,9 +7887,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_chprfs #endif -#:if WITH_QP - module procedure stdlib_whprfs +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$hprfs + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zhprfs( uplo, n, nrhs, ap, afp, ipiv, b, ldb, x, ldx,ferr, berr, & work, rwork, info ) @@ -7379,9 +7937,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_chpsv #endif -#:if WITH_QP - module procedure stdlib_whpsv +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$hpsv + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zhpsv( uplo, n, nrhs, ap, ipiv, b, ldb, info ) import sp,dp,qp,ilp,lk @@ -7416,9 +7977,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_chptrd #endif -#:if WITH_QP - module procedure stdlib_whptrd +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$hptrd + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zhptrd( uplo, n, ap, d, e, tau, info ) import sp,dp,qp,ilp,lk @@ -7456,9 +8020,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_chptrf #endif -#:if WITH_QP - module procedure stdlib_whptrf +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$hptrf + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zhptrf( uplo, n, ap, ipiv, info ) import sp,dp,qp,ilp,lk @@ -7492,9 +8059,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_chptri #endif -#:if WITH_QP - module procedure stdlib_whptri +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$hptri + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zhptri( uplo, n, ap, ipiv, work, info ) import sp,dp,qp,ilp,lk @@ -7529,9 +8099,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_chptrs #endif -#:if WITH_QP - module procedure stdlib_whptrs +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$hptrs + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zhptrs( uplo, n, nrhs, ap, ipiv, b, ldb, info ) import sp,dp,qp,ilp,lk @@ -7589,9 +8162,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dhsein #endif -#:if WITH_QP - module procedure stdlib_qhsein +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$hsein + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK subroutine shsein( side, eigsrc, initv, select, n, h, ldh, wr, wi,vl, ldvl, vr, & ldvr, mm, m, work, ifaill,ifailr, info ) @@ -7608,9 +8184,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_shsein #endif -#:if WITH_QP - module procedure stdlib_whsein +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$hsein + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK subroutine zhsein( side, eigsrc, initv, select, n, h, ldh, w, vl,ldvl, vr, ldvr, & mm, m, work, rwork, ifaill,ifailr, info ) @@ -7669,9 +8248,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dhseqr #endif -#:if WITH_QP - module procedure stdlib_qhseqr +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$hseqr + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK subroutine shseqr( job, compz, n, ilo, ihi, h, ldh, wr, wi, z,ldz, work, lwork, & info ) @@ -7686,9 +8268,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_shseqr #endif -#:if WITH_QP - module procedure stdlib_whseqr +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$hseqr + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zhseqr( job, compz, n, ilo, ihi, h, ldh, w, z, ldz,work, lwork, & info ) @@ -7720,9 +8305,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_disnan #endif -#:if WITH_QP - module procedure stdlib_qisnan +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$isnan + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure logical(lk) function sisnan( sin ) import sp,dp,qp,ilp,lk @@ -7775,9 +8363,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dla_gbamv #endif -#:if WITH_QP - module procedure stdlib_qla_gbamv +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$la_gbamv + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK subroutine sla_gbamv( trans, m, n, kl, ku, alpha, ab, ldab, x,incx, beta, y, incy ) @@ -7790,9 +8381,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_sla_gbamv #endif -#:if WITH_QP - module procedure stdlib_wla_gbamv +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$la_gbamv + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK subroutine zla_gbamv( trans, m, n, kl, ku, alpha, ab, ldab, x,incx, beta, y, incy ) @@ -7834,9 +8428,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dla_gbrcond #endif -#:if WITH_QP - module procedure stdlib_qla_gbrcond +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$la_gbrcond + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK real(sp) function sla_gbrcond( trans, n, kl, ku, ab, ldab, afb, ldafb,ipiv, cmode, & c, info, work, iwork ) @@ -7875,9 +8472,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_cla_gbrcond_c #endif -#:if WITH_QP - module procedure stdlib_wla_gbrcond_c +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$la_gbrcond_c + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK real(dp) function zla_gbrcond_c( trans, n, kl, ku, ab,ldab, afb, ldafb, ipiv,c, & capply, info, work,rwork ) @@ -7928,9 +8528,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dla_gbrpvgrw #endif -#:if WITH_QP - module procedure stdlib_qla_gbrpvgrw +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$la_gbrpvgrw + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure real(sp) function sla_gbrpvgrw( n, kl, ku, ncols, ab, ldab, afb,ldafb ) @@ -7942,9 +8545,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_sla_gbrpvgrw #endif -#:if WITH_QP - module procedure stdlib_wla_gbrpvgrw +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$la_gbrpvgrw + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure real(dp) function zla_gbrpvgrw( n, kl, ku, ncols, ab,ldab, afb, ldafb ) @@ -7997,9 +8603,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dla_geamv #endif -#:if WITH_QP - module procedure stdlib_qla_geamv +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$la_geamv + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK subroutine sla_geamv( trans, m, n, alpha, a, lda, x, incx, beta,y, incy ) import sp,dp,qp,ilp,lk @@ -8011,9 +8620,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_sla_geamv #endif -#:if WITH_QP - module procedure stdlib_wla_geamv +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$la_geamv + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK subroutine zla_geamv( trans, m, n, alpha, a, lda, x, incx, beta,y, incy ) import sp,dp,qp,ilp,lk @@ -8054,9 +8666,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dla_gercond #endif -#:if WITH_QP - module procedure stdlib_qla_gercond +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$la_gercond + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK real(sp) function sla_gercond( trans, n, a, lda, af, ldaf, ipiv,cmode, c, info, & work, iwork ) @@ -8095,9 +8710,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_cla_gercond_c #endif -#:if WITH_QP - module procedure stdlib_wla_gercond_c +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$la_gercond_c + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK real(dp) function zla_gercond_c( trans, n, a, lda, af,ldaf, ipiv, c, capply,info, & work, rwork ) @@ -8146,9 +8764,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dla_gerpvgrw #endif -#:if WITH_QP - module procedure stdlib_qla_gerpvgrw +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$la_gerpvgrw + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure real(sp) function sla_gerpvgrw( n, ncols, a, lda, af, ldaf ) import sp,dp,qp,ilp,lk @@ -8159,9 +8780,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_sla_gerpvgrw #endif -#:if WITH_QP - module procedure stdlib_wla_gerpvgrw +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$la_gerpvgrw + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure real(dp) function zla_gerpvgrw( n, ncols, a, lda, af,ldaf ) import sp,dp,qp,ilp,lk @@ -8201,9 +8825,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_cla_heamv #endif -#:if WITH_QP - module procedure stdlib_wla_heamv +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$la_heamv + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK subroutine zla_heamv( uplo, n, alpha, a, lda, x, incx, beta, y,incy ) import sp,dp,qp,ilp,lk @@ -8240,9 +8867,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_cla_hercond_c #endif -#:if WITH_QP - module procedure stdlib_wla_hercond_c +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$la_hercond_c + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK real(dp) function zla_hercond_c( uplo, n, a, lda, af,ldaf, ipiv, c, capply,info, & work, rwork ) @@ -8284,9 +8914,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_cla_herpvgrw #endif -#:if WITH_QP - module procedure stdlib_wla_herpvgrw +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$la_herpvgrw + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK real(dp) function zla_herpvgrw( uplo, n, info, a, lda, af,ldaf, ipiv, work ) @@ -8333,9 +8966,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dla_lin_berr #endif -#:if WITH_QP - module procedure stdlib_qla_lin_berr +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$la_lin_berr + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine sla_lin_berr( n, nz, nrhs, res, ayb, berr ) import sp,dp,qp,ilp,lk @@ -8347,9 +8983,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_sla_lin_berr #endif -#:if WITH_QP - module procedure stdlib_wla_lin_berr +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$la_lin_berr + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zla_lin_berr( n, nz, nrhs, res, ayb, berr ) import sp,dp,qp,ilp,lk @@ -8390,9 +9029,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dla_porcond #endif -#:if WITH_QP - module procedure stdlib_qla_porcond +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$la_porcond + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK real(sp) function sla_porcond( uplo, n, a, lda, af, ldaf, cmode, c,info, work, & iwork ) @@ -8431,9 +9073,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_cla_porcond_c #endif -#:if WITH_QP - module procedure stdlib_wla_porcond_c +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$la_porcond_c + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK real(dp) function zla_porcond_c( uplo, n, a, lda, af,ldaf, c, capply, info,work, & rwork ) @@ -8486,9 +9131,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dla_porpvgrw #endif -#:if WITH_QP - module procedure stdlib_qla_porpvgrw +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$la_porpvgrw + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK real(sp) function sla_porpvgrw( uplo, ncols, a, lda, af, ldaf, work ) import sp,dp,qp,ilp,lk @@ -8501,9 +9149,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_sla_porpvgrw #endif -#:if WITH_QP - module procedure stdlib_wla_porpvgrw +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$la_porpvgrw + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK real(dp) function zla_porpvgrw( uplo, ncols, a, lda, af,ldaf, work ) import sp,dp,qp,ilp,lk @@ -8556,9 +9207,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dla_syamv #endif -#:if WITH_QP - module procedure stdlib_qla_syamv +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$la_syamv + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK subroutine sla_syamv( uplo, n, alpha, a, lda, x, incx, beta, y,incy ) import sp,dp,qp,ilp,lk @@ -8570,9 +9224,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_sla_syamv #endif -#:if WITH_QP - module procedure stdlib_wla_syamv +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$la_syamv + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK subroutine zla_syamv( uplo, n, alpha, a, lda, x, incx, beta, y,incy ) import sp,dp,qp,ilp,lk @@ -8613,9 +9270,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dla_syrcond #endif -#:if WITH_QP - module procedure stdlib_qla_syrcond +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$la_syrcond + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK real(sp) function sla_syrcond( uplo, n, a, lda, af, ldaf, ipiv, cmode,c, info, & work, iwork ) @@ -8654,9 +9314,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_cla_syrcond_c #endif -#:if WITH_QP - module procedure stdlib_wla_syrcond_c +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$la_syrcond_c + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK real(dp) function zla_syrcond_c( uplo, n, a, lda, af,ldaf, ipiv, c, capply,info, & work, rwork ) @@ -8711,9 +9374,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dla_syrpvgrw #endif -#:if WITH_QP - module procedure stdlib_qla_syrpvgrw +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$la_syrpvgrw + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK real(sp) function sla_syrpvgrw( uplo, n, info, a, lda, af, ldaf, ipiv,work ) @@ -8727,9 +9393,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_sla_syrpvgrw #endif -#:if WITH_QP - module procedure stdlib_wla_syrpvgrw +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$la_syrpvgrw + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK real(dp) function zla_syrpvgrw( uplo, n, info, a, lda, af,ldaf, ipiv, work ) @@ -8773,9 +9442,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dla_wwaddw #endif -#:if WITH_QP - module procedure stdlib_qla_wwaddw +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$la_wwaddw + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine sla_wwaddw( n, x, y, w ) import sp,dp,qp,ilp,lk @@ -8787,9 +9459,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_sla_wwaddw #endif -#:if WITH_QP - module procedure stdlib_wla_wwaddw +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$la_wwaddw + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zla_wwaddw( n, x, y, w ) import sp,dp,qp,ilp,lk @@ -8823,9 +9498,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dlabad #endif -#:if WITH_QP - module procedure stdlib_qlabad +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$labad + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine slabad( small, large ) import sp,dp,qp,ilp,lk @@ -8870,9 +9548,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dlabrd #endif -#:if WITH_QP - module procedure stdlib_qlabrd +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$labrd + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine slabrd( m, n, nb, a, lda, d, e, tauq, taup, x, ldx, y,ldy ) import sp,dp,qp,ilp,lk @@ -8884,9 +9565,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_slabrd #endif -#:if WITH_QP - module procedure stdlib_wlabrd +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$labrd + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zlabrd( m, n, nb, a, lda, d, e, tauq, taup, x, ldx, y,ldy ) import sp,dp,qp,ilp,lk @@ -8915,9 +9599,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_clacgv #endif -#:if WITH_QP - module procedure stdlib_wlacgv +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$lacgv + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zlacgv( n, x, incx ) import sp,dp,qp,ilp,lk @@ -8961,9 +9648,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dlacon #endif -#:if WITH_QP - module procedure stdlib_qlacon +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$lacon + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK subroutine slacon( n, v, x, isgn, est, kase ) import sp,dp,qp,ilp,lk @@ -8977,9 +9667,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_slacon #endif -#:if WITH_QP - module procedure stdlib_wlacon +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$lacon + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK subroutine zlacon( n, v, x, est, kase ) import sp,dp,qp,ilp,lk @@ -9024,9 +9717,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dlacpy #endif -#:if WITH_QP - module procedure stdlib_qlacpy +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$lacpy + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine slacpy( uplo, m, n, a, lda, b, ldb ) import sp,dp,qp,ilp,lk @@ -9039,9 +9735,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_slacpy #endif -#:if WITH_QP - module procedure stdlib_wlacpy +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$lacpy + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zlacpy( uplo, m, n, a, lda, b, ldb ) import sp,dp,qp,ilp,lk @@ -9076,9 +9775,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_clacrm #endif -#:if WITH_QP - module procedure stdlib_wlacrm +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$lacrm + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zlacrm( m, n, a, lda, b, ldb, c, ldc, rwork ) import sp,dp,qp,ilp,lk @@ -9112,9 +9814,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_clacrt #endif -#:if WITH_QP - module procedure stdlib_wlacrt +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$lacrt + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zlacrt( n, cx, incx, cy, incy, c, s ) import sp,dp,qp,ilp,lk @@ -9143,9 +9848,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_cladiv #endif -#:if WITH_QP - module procedure stdlib_wladiv +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$ladiv + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure complex(dp) function zladiv( x, y ) import sp,dp,qp,ilp,lk @@ -9177,9 +9885,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dladiv #endif -#:if WITH_QP - module procedure stdlib_qladiv +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$ladiv + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine sladiv( a, b, c, d, p, q ) import sp,dp,qp,ilp,lk @@ -9206,9 +9917,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dladiv1 #endif -#:if WITH_QP - module procedure stdlib_qladiv1 +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$ladiv1 + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine sladiv1( a, b, c, d, p, q ) import sp,dp,qp,ilp,lk @@ -9234,9 +9948,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dladiv2 #endif -#:if WITH_QP - module procedure stdlib_qladiv2 +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$ladiv2 + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure real(sp) function sladiv2( a, b, c, d, r, t ) import sp,dp,qp,ilp,lk @@ -9297,9 +10014,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dlaebz #endif -#:if WITH_QP - module procedure stdlib_qlaebz +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$laebz + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine slaebz( ijob, nitmax, n, mmax, minp, nbmin, abstol,reltol, pivmin, & d, e, e2, nval, ab, c, mout,nab, work, iwork, info ) @@ -9352,9 +10072,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dlaed0 #endif -#:if WITH_QP - module procedure stdlib_qlaed0 +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$laed0 + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine slaed0( icompq, qsiz, n, d, e, q, ldq, qstore, ldqs,work, iwork, & info ) @@ -9368,9 +10091,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_slaed0 #endif -#:if WITH_QP - module procedure stdlib_wlaed0 +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$laed0 + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zlaed0( qsiz, n, d, e, q, ldq, qstore, ldqs, rwork,iwork, info ) @@ -9431,9 +10157,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dlaed1 #endif -#:if WITH_QP - module procedure stdlib_qlaed1 +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$laed1 + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine slaed1( n, d, q, ldq, indxq, rho, cutpnt, work, iwork,info ) @@ -9475,9 +10204,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dlaed4 #endif -#:if WITH_QP - module procedure stdlib_qlaed4 +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$laed4 + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine slaed4( n, i, d, z, delta, rho, dlam, info ) import sp,dp,qp,ilp,lk @@ -9513,9 +10245,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dlaed5 #endif -#:if WITH_QP - module procedure stdlib_qlaed5 +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$laed5 + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine slaed5( i, d, z, delta, rho, dlam ) import sp,dp,qp,ilp,lk @@ -9556,9 +10291,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dlaed6 #endif -#:if WITH_QP - module procedure stdlib_qlaed6 +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$laed6 + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine slaed6( kniter, orgati, rho, d, z, finit, tau, info ) import sp,dp,qp,ilp,lk @@ -9636,9 +10374,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dlaed7 #endif -#:if WITH_QP - module procedure stdlib_qlaed7 +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$laed7 + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine slaed7( icompq, n, qsiz, tlvls, curlvl, curpbm, d, q,ldq, indxq, & rho, cutpnt, qstore, qptr, prmptr,perm, givptr, givcol, givnum, work, iwork,info ) @@ -9656,9 +10397,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_slaed7 #endif -#:if WITH_QP - module procedure stdlib_wlaed7 +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$laed7 + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zlaed7( n, cutpnt, qsiz, tlvls, curlvl, curpbm, d, q,ldq, rho, & indxq, qstore, qptr, prmptr, perm,givptr, givcol, givnum, work, rwork, iwork,info ) @@ -9720,9 +10464,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dlaed8 #endif -#:if WITH_QP - module procedure stdlib_qlaed8 +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$laed8 + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine slaed8( icompq, k, n, qsiz, d, q, ldq, indxq, rho,cutpnt, z, & dlamda, q2, ldq2, w, perm, givptr,givcol, givnum, indxp, indx, info ) @@ -9738,9 +10485,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_slaed8 #endif -#:if WITH_QP - module procedure stdlib_wlaed8 +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$laed8 + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zlaed8( k, n, qsiz, q, ldq, d, rho, cutpnt, z, dlamda,q2, ldq2, w, & indxp, indx, indxq, perm, givptr,givcol, givnum, info ) @@ -9781,9 +10531,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dlaed9 #endif -#:if WITH_QP - module procedure stdlib_qlaed9 +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$laed9 + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine slaed9( k, kstart, kstop, n, d, q, ldq, rho, dlamda, w,s, lds, & info ) @@ -9820,9 +10573,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dlaeda #endif -#:if WITH_QP - module procedure stdlib_qlaeda +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$laeda + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine slaeda( n, tlvls, curlvl, curpbm, prmptr, perm, givptr,givcol, & givnum, q, qptr, z, ztemp, info ) @@ -9877,9 +10633,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dlaein #endif -#:if WITH_QP - module procedure stdlib_qlaein +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$laein + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine slaein( rightv, noinit, n, h, ldh, wr, wi, vr, vi, b,ldb, work, & eps3, smlnum, bignum, info ) @@ -9895,9 +10654,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_slaein #endif -#:if WITH_QP - module procedure stdlib_wlaein +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$laein + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zlaein( rightv, noinit, n, h, ldh, w, v, b, ldb, rwork,eps3, & smlnum, info ) @@ -9939,9 +10701,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_claesy #endif -#:if WITH_QP - module procedure stdlib_wlaesy +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$laesy + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zlaesy( a, b, c, rt1, rt2, evscal, cs1, sn1 ) import sp,dp,qp,ilp,lk @@ -9977,9 +10742,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dlaexc #endif -#:if WITH_QP - module procedure stdlib_qlaexc +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$laexc + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK subroutine slaexc( wantq, n, t, ldt, q, ldq, j1, n1, n2, work,info ) import sp,dp,qp,ilp,lk @@ -10023,9 +10791,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dlagtf #endif -#:if WITH_QP - module procedure stdlib_qlagtf +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$lagtf + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine slagtf( n, a, lambda, b, c, tol, d, in, info ) import sp,dp,qp,ilp,lk @@ -10076,9 +10847,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dlagtm #endif -#:if WITH_QP - module procedure stdlib_qlagtm +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$lagtm + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine slagtm( trans, n, nrhs, alpha, dl, d, du, x, ldx, beta,b, ldb ) @@ -10092,9 +10866,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_slagtm #endif -#:if WITH_QP - module procedure stdlib_wlagtm +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$lagtm + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zlagtm( trans, n, nrhs, alpha, dl, d, du, x, ldx, beta,b, ldb ) @@ -10135,9 +10912,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dlagts #endif -#:if WITH_QP - module procedure stdlib_qlagts +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$lagts + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine slagts( job, n, a, b, c, d, in, y, tol, info ) import sp,dp,qp,ilp,lk @@ -10181,9 +10961,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_clahef #endif -#:if WITH_QP - module procedure stdlib_wlahef +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$lahef + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zlahef( uplo, n, nb, kb, a, lda, ipiv, w, ldw, info ) import sp,dp,qp,ilp,lk @@ -10225,9 +11008,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_clahef_aa #endif -#:if WITH_QP - module procedure stdlib_wlahef_aa +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$lahef_aa + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zlahef_aa( uplo, j1, m, nb, a, lda, ipiv,h, ldh, work ) import sp,dp,qp,ilp,lk @@ -10271,9 +11057,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_clahef_rk #endif -#:if WITH_QP - module procedure stdlib_wlahef_rk +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$lahef_rk + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zlahef_rk( uplo, n, nb, kb, a, lda, e, ipiv, w, ldw,info ) import sp,dp,qp,ilp,lk @@ -10318,9 +11107,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_clahef_rook #endif -#:if WITH_QP - module procedure stdlib_wlahef_rook +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$lahef_rook + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zlahef_rook( uplo, n, nb, kb, a, lda, ipiv, w, ldw,info ) import sp,dp,qp,ilp,lk @@ -10371,9 +11163,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dlahqr #endif -#:if WITH_QP - module procedure stdlib_qlahqr +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$lahqr + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine slahqr( wantt, wantz, n, ilo, ihi, h, ldh, wr, wi,iloz, ihiz, z, & ldz, info ) @@ -10388,9 +11183,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_slahqr #endif -#:if WITH_QP - module procedure stdlib_wlahqr +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$lahqr + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zlahqr( wantt, wantz, n, ilo, ihi, h, ldh, w, iloz,ihiz, z, ldz, & info ) @@ -10454,9 +11252,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dlaic1 #endif -#:if WITH_QP - module procedure stdlib_qlaic1 +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$laic1 + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine slaic1( job, j, x, sest, w, gamma, sestpr, s, c ) import sp,dp,qp,ilp,lk @@ -10468,9 +11269,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_slaic1 #endif -#:if WITH_QP - module procedure stdlib_wlaic1 +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$laic1 + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zlaic1( job, j, x, sest, w, gamma, sestpr, s, c ) import sp,dp,qp,ilp,lk @@ -10509,9 +11313,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dlaisnan #endif -#:if WITH_QP - module procedure stdlib_qlaisnan +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$laisnan + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure logical(lk) function slaisnan( sin1, sin2 ) import sp,dp,qp,ilp,lk @@ -10579,9 +11386,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dlals0 #endif -#:if WITH_QP - module procedure stdlib_qlals0 +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$lals0 + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine slals0( icompq, nl, nr, sqre, nrhs, b, ldb, bx, ldbx,perm, givptr, & givcol, ldgcol, givnum, ldgnum,poles, difl, difr, z, k, c, s, work, info ) @@ -10598,9 +11408,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_slals0 #endif -#:if WITH_QP - module procedure stdlib_wlals0 +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$lals0 + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zlals0( icompq, nl, nr, sqre, nrhs, b, ldb, bx, ldbx,perm, givptr, & givcol, ldgcol, givnum, ldgnum,poles, difl, difr, z, k, c, s, rwork, info ) @@ -10667,9 +11480,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dlalsa #endif -#:if WITH_QP - module procedure stdlib_qlalsa +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$lalsa + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine slalsa( icompq, smlsiz, n, nrhs, b, ldb, bx, ldbx, u,ldu, vt, k, & difl, difr, z, poles, givptr,givcol, ldgcol, perm, givnum, c, s, work,iwork, info ) @@ -10687,9 +11503,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_slalsa #endif -#:if WITH_QP - module procedure stdlib_wlalsa +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$lalsa + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zlalsa( icompq, smlsiz, n, nrhs, b, ldb, bx, ldbx, u,ldu, vt, k, & difl, difr, z, poles, givptr,givcol, ldgcol, perm, givnum, c, s, rwork,iwork, info & @@ -10759,9 +11578,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dlalsd #endif -#:if WITH_QP - module procedure stdlib_qlalsd +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$lalsd + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine slalsd( uplo, smlsiz, n, nrhs, d, e, b, ldb, rcond,rank, work, & iwork, info ) @@ -10777,9 +11599,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_slalsd #endif -#:if WITH_QP - module procedure stdlib_wlalsd +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$lalsd + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zlalsd( uplo, smlsiz, n, nrhs, d, e, b, ldb, rcond,rank, work, & rwork, iwork, info ) @@ -10816,9 +11641,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dlamrg #endif -#:if WITH_QP - module procedure stdlib_qlamrg +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$lamrg + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine slamrg( n1, n2, a, strd1, strd2, index ) import sp,dp,qp,ilp,lk @@ -10872,9 +11700,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dlamswlq #endif -#:if WITH_QP - module procedure stdlib_qlamswlq +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$lamswlq + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine slamswlq( side, trans, m, n, k, mb, nb, a, lda, t,ldt, c, ldc, & work, lwork, info ) @@ -10890,9 +11721,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_slamswlq #endif -#:if WITH_QP - module procedure stdlib_wlamswlq +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$lamswlq + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zlamswlq( side, trans, m, n, k, mb, nb, a, lda, t,ldt, c, ldc, & work, lwork, info ) @@ -10950,9 +11784,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dlamtsqr #endif -#:if WITH_QP - module procedure stdlib_qlamtsqr +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$lamtsqr + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine slamtsqr( side, trans, m, n, k, mb, nb, a, lda, t,ldt, c, ldc, & work, lwork, info ) @@ -10968,9 +11805,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_slamtsqr #endif -#:if WITH_QP - module procedure stdlib_wlamtsqr +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$lamtsqr + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zlamtsqr( side, trans, m, n, k, mb, nb, a, lda, t,ldt, c, ldc, & work, lwork, info ) @@ -11016,9 +11856,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dlaneg #endif -#:if WITH_QP - module procedure stdlib_qlaneg +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$laneg + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure integer(ilp) function slaneg( n, d, lld, sigma, pivmin, r ) import sp,dp,qp,ilp,lk @@ -11061,9 +11904,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dlangb #endif -#:if WITH_QP - module procedure stdlib_qlangb +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$langb + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK real(sp) function slangb( norm, n, kl, ku, ab, ldab,work ) import sp,dp,qp,ilp,lk @@ -11076,9 +11922,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_slangb #endif -#:if WITH_QP - module procedure stdlib_wlangb +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$langb + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK real(dp) function zlangb( norm, n, kl, ku, ab, ldab,work ) import sp,dp,qp,ilp,lk @@ -11123,9 +11972,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dlange #endif -#:if WITH_QP - module procedure stdlib_qlange +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$lange + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK real(sp) function slange( norm, m, n, a, lda, work ) import sp,dp,qp,ilp,lk @@ -11138,9 +11990,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_slange #endif -#:if WITH_QP - module procedure stdlib_wlange +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$lange + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK real(dp) function zlange( norm, m, n, a, lda, work ) import sp,dp,qp,ilp,lk @@ -11183,9 +12038,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dlangt #endif -#:if WITH_QP - module procedure stdlib_qlangt +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$langt + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure real(sp) function slangt( norm, n, dl, d, du ) import sp,dp,qp,ilp,lk @@ -11197,9 +12055,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_slangt #endif -#:if WITH_QP - module procedure stdlib_wlangt +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$langt + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure real(dp) function zlangt( norm, n, dl, d, du ) import sp,dp,qp,ilp,lk @@ -11231,9 +12092,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_clanhb #endif -#:if WITH_QP - module procedure stdlib_wlanhb +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$lanhb + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK real(dp) function zlanhb( norm, uplo, n, k, ab, ldab,work ) import sp,dp,qp,ilp,lk @@ -11266,9 +12130,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_clanhe #endif -#:if WITH_QP - module procedure stdlib_wlanhe +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$lanhe + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK real(dp) function zlanhe( norm, uplo, n, a, lda, work ) import sp,dp,qp,ilp,lk @@ -11301,9 +12168,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_clanhf #endif -#:if WITH_QP - module procedure stdlib_wlanhf +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$lanhf + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK real(dp) function zlanhf( norm, transr, uplo, n, a, work ) import sp,dp,qp,ilp,lk @@ -11336,9 +12206,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_clanhp #endif -#:if WITH_QP - module procedure stdlib_wlanhp +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$lanhp + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK real(dp) function zlanhp( norm, uplo, n, ap, work ) import sp,dp,qp,ilp,lk @@ -11383,9 +12256,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dlanhs #endif -#:if WITH_QP - module procedure stdlib_qlanhs +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$lanhs + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK real(sp) function slanhs( norm, n, a, lda, work ) import sp,dp,qp,ilp,lk @@ -11398,9 +12274,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_slanhs #endif -#:if WITH_QP - module procedure stdlib_wlanhs +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$lanhs + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK real(dp) function zlanhs( norm, n, a, lda, work ) import sp,dp,qp,ilp,lk @@ -11433,9 +12312,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_clanht #endif -#:if WITH_QP - module procedure stdlib_wlanht +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$lanht + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure real(dp) function zlanht( norm, n, d, e ) import sp,dp,qp,ilp,lk @@ -11480,9 +12362,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dlansb #endif -#:if WITH_QP - module procedure stdlib_qlansb +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$lansb + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK real(sp) function slansb( norm, uplo, n, k, ab, ldab,work ) import sp,dp,qp,ilp,lk @@ -11495,9 +12380,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_slansb #endif -#:if WITH_QP - module procedure stdlib_wlansb +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$lansb + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK real(dp) function zlansb( norm, uplo, n, k, ab, ldab,work ) import sp,dp,qp,ilp,lk @@ -11530,9 +12418,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dlansf #endif -#:if WITH_QP - module procedure stdlib_qlansf +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$lansf + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK real(sp) function slansf( norm, transr, uplo, n, a, work ) import sp,dp,qp,ilp,lk @@ -11577,9 +12468,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dlansp #endif -#:if WITH_QP - module procedure stdlib_qlansp +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$lansp + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK real(sp) function slansp( norm, uplo, n, ap, work ) import sp,dp,qp,ilp,lk @@ -11592,9 +12486,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_slansp #endif -#:if WITH_QP - module procedure stdlib_wlansp +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$lansp + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK real(dp) function zlansp( norm, uplo, n, ap, work ) import sp,dp,qp,ilp,lk @@ -11626,9 +12523,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dlanst #endif -#:if WITH_QP - module procedure stdlib_qlanst +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$lanst + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure real(sp) function slanst( norm, n, d, e ) import sp,dp,qp,ilp,lk @@ -11672,9 +12572,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dlansy #endif -#:if WITH_QP - module procedure stdlib_qlansy +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$lansy + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK real(sp) function slansy( norm, uplo, n, a, lda, work ) import sp,dp,qp,ilp,lk @@ -11687,9 +12590,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_slansy #endif -#:if WITH_QP - module procedure stdlib_wlansy +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$lansy + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK real(dp) function zlansy( norm, uplo, n, a, lda, work ) import sp,dp,qp,ilp,lk @@ -11735,9 +12641,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dlantb #endif -#:if WITH_QP - module procedure stdlib_qlantb +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$lantb + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK real(sp) function slantb( norm, uplo, diag, n, k, ab,ldab, work ) @@ -11751,9 +12660,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_slantb #endif -#:if WITH_QP - module procedure stdlib_wlantb +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$lantb + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK real(dp) function zlantb( norm, uplo, diag, n, k, ab,ldab, work ) import sp,dp,qp,ilp,lk @@ -11798,9 +12710,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dlantp #endif -#:if WITH_QP - module procedure stdlib_qlantp +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$lantp + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK real(sp) function slantp( norm, uplo, diag, n, ap, work ) import sp,dp,qp,ilp,lk @@ -11813,9 +12728,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_slantp #endif -#:if WITH_QP - module procedure stdlib_wlantp +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$lantp + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK real(dp) function zlantp( norm, uplo, diag, n, ap, work ) import sp,dp,qp,ilp,lk @@ -11860,9 +12778,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dlantr #endif -#:if WITH_QP - module procedure stdlib_qlantr +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$lantr + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK real(sp) function slantr( norm, uplo, diag, m, n, a, lda,work ) import sp,dp,qp,ilp,lk @@ -11875,9 +12796,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_slantr #endif -#:if WITH_QP - module procedure stdlib_wlantr +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$lantr + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK real(dp) function zlantr( norm, uplo, diag, m, n, a, lda,work ) import sp,dp,qp,ilp,lk @@ -11940,9 +12864,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dlaorhr_col_getrfnp #endif -#:if WITH_QP - module procedure stdlib_qlaorhr_col_getrfnp +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$laorhr_col_getrfnp + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine slaorhr_col_getrfnp( m, n, a, lda, d, info ) import sp,dp,qp,ilp,lk @@ -12020,9 +12947,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dlaorhr_col_getrfnp2 #endif -#:if WITH_QP - module procedure stdlib_qlaorhr_col_getrfnp2 +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$laorhr_col_getrfnp2 + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure recursive subroutine slaorhr_col_getrfnp2( m, n, a, lda, d, info ) import sp,dp,qp,ilp,lk @@ -12068,9 +12998,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dlapll #endif -#:if WITH_QP - module procedure stdlib_qlapll +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$lapll + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine slapll( n, x, incx, y, incy, ssmin ) import sp,dp,qp,ilp,lk @@ -12082,9 +13015,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_slapll #endif -#:if WITH_QP - module procedure stdlib_wlapll +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$lapll + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zlapll( n, x, incx, y, incy, ssmin ) import sp,dp,qp,ilp,lk @@ -12131,9 +13067,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dlapmr #endif -#:if WITH_QP - module procedure stdlib_qlapmr +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$lapmr + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine slapmr( forwrd, m, n, x, ldx, k ) import sp,dp,qp,ilp,lk @@ -12146,9 +13085,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_slapmr #endif -#:if WITH_QP - module procedure stdlib_wlapmr +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$lapmr + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zlapmr( forwrd, m, n, x, ldx, k ) import sp,dp,qp,ilp,lk @@ -12196,9 +13138,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dlapmt #endif -#:if WITH_QP - module procedure stdlib_qlapmt +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$lapmt + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine slapmt( forwrd, m, n, x, ldx, k ) import sp,dp,qp,ilp,lk @@ -12211,9 +13156,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_slapmt #endif -#:if WITH_QP - module procedure stdlib_wlapmt +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$lapmt + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zlapmt( forwrd, m, n, x, ldx, k ) import sp,dp,qp,ilp,lk @@ -12260,9 +13208,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dlaqgb #endif -#:if WITH_QP - module procedure stdlib_qlaqgb +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$laqgb + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine slaqgb( m, n, kl, ku, ab, ldab, r, c, rowcnd, colcnd,amax, equed ) @@ -12276,9 +13227,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_slaqgb #endif -#:if WITH_QP - module procedure stdlib_wlaqgb +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$laqgb + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zlaqgb( m, n, kl, ku, ab, ldab, r, c, rowcnd, colcnd,amax, equed ) @@ -12323,9 +13277,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dlaqge #endif -#:if WITH_QP - module procedure stdlib_qlaqge +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$laqge + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine slaqge( m, n, a, lda, r, c, rowcnd, colcnd, amax,equed ) import sp,dp,qp,ilp,lk @@ -12338,9 +13295,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_slaqge #endif -#:if WITH_QP - module procedure stdlib_wlaqge +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$laqge + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zlaqge( m, n, a, lda, r, c, rowcnd, colcnd, amax,equed ) import sp,dp,qp,ilp,lk @@ -12374,9 +13334,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_claqhb #endif -#:if WITH_QP - module procedure stdlib_wlaqhb +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$laqhb + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zlaqhb( uplo, n, kd, ab, ldab, s, scond, amax, equed ) import sp,dp,qp,ilp,lk @@ -12411,9 +13374,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_claqhe #endif -#:if WITH_QP - module procedure stdlib_wlaqhe +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$laqhe + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zlaqhe( uplo, n, a, lda, s, scond, amax, equed ) import sp,dp,qp,ilp,lk @@ -12447,9 +13413,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_claqhp #endif -#:if WITH_QP - module procedure stdlib_wlaqhp +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$laqhp + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zlaqhp( uplo, n, ap, s, scond, amax, equed ) import sp,dp,qp,ilp,lk @@ -12505,9 +13474,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dlaqps #endif -#:if WITH_QP - module procedure stdlib_qlaqps +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$laqps + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine slaqps( m, n, offset, nb, kb, a, lda, jpvt, tau, vn1,vn2, auxv, f, & ldf ) @@ -12522,9 +13494,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_slaqps #endif -#:if WITH_QP - module procedure stdlib_wlaqps +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$laqps + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zlaqps( m, n, offset, nb, kb, a, lda, jpvt, tau, vn1,vn2, auxv, f, & ldf ) @@ -12581,9 +13556,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dlaqr0 #endif -#:if WITH_QP - module procedure stdlib_qlaqr0 +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$laqr0 + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK subroutine slaqr0( wantt, wantz, n, ilo, ihi, h, ldh, wr, wi,iloz, ihiz, z, ldz, & work, lwork, info ) @@ -12598,9 +13576,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_slaqr0 #endif -#:if WITH_QP - module procedure stdlib_wlaqr0 +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$laqr0 + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zlaqr0( wantt, wantz, n, ilo, ihi, h, ldh, w, iloz,ihiz, z, ldz, & work, lwork, info ) @@ -12648,9 +13629,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dlaqr1 #endif -#:if WITH_QP - module procedure stdlib_qlaqr1 +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$laqr1 + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine slaqr1( n, h, ldh, sr1, si1, sr2, si2, v ) import sp,dp,qp,ilp,lk @@ -12662,9 +13646,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_slaqr1 #endif -#:if WITH_QP - module procedure stdlib_wlaqr1 +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$laqr1 + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zlaqr1( n, h, ldh, s1, s2, v ) import sp,dp,qp,ilp,lk @@ -12723,9 +13710,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dlaqr4 #endif -#:if WITH_QP - module procedure stdlib_qlaqr4 +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$laqr4 + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK subroutine slaqr4( wantt, wantz, n, ilo, ihi, h, ldh, wr, wi,iloz, ihiz, z, ldz, & work, lwork, info ) @@ -12740,9 +13730,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_slaqr4 #endif -#:if WITH_QP - module procedure stdlib_wlaqr4 +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$laqr4 + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zlaqr4( wantt, wantz, n, ilo, ihi, h, ldh, w, iloz,ihiz, z, ldz, & work, lwork, info ) @@ -12792,9 +13785,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dlaqr5 #endif -#:if WITH_QP - module procedure stdlib_qlaqr5 +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$laqr5 + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine slaqr5( wantt, wantz, kacc22, n, ktop, kbot, nshfts,sr, si, h, ldh,& iloz, ihiz, z, ldz, v, ldv, u,ldu, nv, wv, ldwv, nh, wh, ldwh ) @@ -12809,9 +13805,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_slaqr5 #endif -#:if WITH_QP - module procedure stdlib_wlaqr5 +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$laqr5 + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zlaqr5( wantt, wantz, kacc22, n, ktop, kbot, nshfts, s,h, ldh, & iloz, ihiz, z, ldz, v, ldv, u, ldu, nv,wv, ldwv, nh, wh, ldwh ) @@ -12859,9 +13858,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dlaqsb #endif -#:if WITH_QP - module procedure stdlib_qlaqsb +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$laqsb + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine slaqsb( uplo, n, kd, ab, ldab, s, scond, amax, equed ) import sp,dp,qp,ilp,lk @@ -12875,9 +13877,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_slaqsb #endif -#:if WITH_QP - module procedure stdlib_wlaqsb +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$laqsb + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zlaqsb( uplo, n, kd, ab, ldab, s, scond, amax, equed ) import sp,dp,qp,ilp,lk @@ -12924,9 +13929,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dlaqsp #endif -#:if WITH_QP - module procedure stdlib_qlaqsp +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$laqsp + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine slaqsp( uplo, n, ap, s, scond, amax, equed ) import sp,dp,qp,ilp,lk @@ -12940,9 +13948,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_slaqsp #endif -#:if WITH_QP - module procedure stdlib_wlaqsp +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$laqsp + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zlaqsp( uplo, n, ap, s, scond, amax, equed ) import sp,dp,qp,ilp,lk @@ -12989,9 +14000,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dlaqsy #endif -#:if WITH_QP - module procedure stdlib_qlaqsy +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$laqsy + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine slaqsy( uplo, n, a, lda, s, scond, amax, equed ) import sp,dp,qp,ilp,lk @@ -13005,9 +14019,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_slaqsy #endif -#:if WITH_QP - module procedure stdlib_wlaqsy +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$laqsy + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zlaqsy( uplo, n, a, lda, s, scond, amax, equed ) import sp,dp,qp,ilp,lk @@ -13058,9 +14075,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dlaqtr #endif -#:if WITH_QP - module procedure stdlib_qlaqtr +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$laqtr + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK subroutine slaqtr( ltran, lreal, n, t, ldt, b, w, scale, x, work,info ) import sp,dp,qp,ilp,lk @@ -13149,9 +14169,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dlaqz0 #endif -#:if WITH_QP - module procedure stdlib_qlaqz0 +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$laqz0 + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK recursive subroutine slaqz0( wants, wantq, wantz, n, ilo, ihi, a,lda, b, ldb, & alphar, alphai, beta,q, ldq, z, ldz, work, lwork, rec,info ) @@ -13166,9 +14189,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_slaqz0 #endif -#:if WITH_QP - module procedure stdlib_wlaqz0 +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$laqz0 + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK recursive subroutine zlaqz0( wants, wantq, wantz, n, ilo, ihi, a,lda, b, ldb, & alpha, beta, q, ldq, z,ldz, work, lwork, rwork, rec,info ) @@ -13214,9 +14240,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dlaqz1 #endif -#:if WITH_QP - module procedure stdlib_qlaqz1 +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$laqz1 + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine slaqz1( a, lda, b, ldb, sr1, sr2, si, beta1, beta2,v ) import sp,dp,qp,ilp,lk @@ -13228,9 +14257,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_slaqz1 #endif -#:if WITH_QP - module procedure stdlib_wlaqz1 +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$laqz1 + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zlaqz1( ilq, ilz, k, istartm, istopm, ihi, a, lda, b,ldb, nq, & qstart, q, ldq, nz, zstart, z, ldz ) @@ -13268,9 +14300,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dlaqz4 #endif -#:if WITH_QP - module procedure stdlib_qlaqz4 +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$laqz4 + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine slaqz4( ilschur, ilq, ilz, n, ilo, ihi, nshifts,nblock_desired, sr,& si, ss, a, lda, b, ldb, q,ldq, z, ldz, qc, ldqc, zc, ldzc, work, lwork,info ) @@ -13341,9 +14376,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dlar1v #endif -#:if WITH_QP - module procedure stdlib_qlar1v +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$lar1v + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine slar1v( n, b1, bn, lambda, d, l, ld, lld,pivmin, gaptol, z, wantnc,& negcnt, ztz, mingma,r, isuppz, nrminv, resid, rqcorr, work ) @@ -13360,9 +14398,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_slar1v #endif -#:if WITH_QP - module procedure stdlib_wlar1v +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$lar1v + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zlar1v( n, b1, bn, lambda, d, l, ld, lld,pivmin, gaptol, z, wantnc,& negcnt, ztz, mingma,r, isuppz, nrminv, resid, rqcorr, work ) @@ -13414,9 +14455,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dlar2v #endif -#:if WITH_QP - module procedure stdlib_qlar2v +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$lar2v + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine slar2v( n, x, y, z, incx, c, s, incc ) import sp,dp,qp,ilp,lk @@ -13428,9 +14472,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_slar2v #endif -#:if WITH_QP - module procedure stdlib_wlar2v +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$lar2v + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zlar2v( n, x, y, z, incx, c, s, incc ) import sp,dp,qp,ilp,lk @@ -13465,9 +14512,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_clarcm #endif -#:if WITH_QP - module procedure stdlib_wlarcm +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$larcm + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zlarcm( m, n, a, lda, b, ldb, c, ldc, rwork ) import sp,dp,qp,ilp,lk @@ -13520,9 +14570,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dlarf #endif -#:if WITH_QP - module procedure stdlib_qlarf +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$larf + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine slarf( side, m, n, v, incv, tau, c, ldc, work ) import sp,dp,qp,ilp,lk @@ -13536,9 +14589,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_slarf #endif -#:if WITH_QP - module procedure stdlib_wlarf +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$larf + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zlarf( side, m, n, v, incv, tau, c, ldc, work ) import sp,dp,qp,ilp,lk @@ -13587,9 +14643,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dlarfb #endif -#:if WITH_QP - module procedure stdlib_qlarfb +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$larfb + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine slarfb( side, trans, direct, storev, m, n, k, v, ldv,t, ldt, c, & ldc, work, ldwork ) @@ -13604,9 +14663,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_slarfb #endif -#:if WITH_QP - module procedure stdlib_wlarfb +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$larfb + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zlarfb( side, trans, direct, storev, m, n, k, v, ldv,t, ldt, c, & ldc, work, ldwork ) @@ -13661,9 +14723,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dlarfb_gett #endif -#:if WITH_QP - module procedure stdlib_qlarfb_gett +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$larfb_gett + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine slarfb_gett( ident, m, n, k, t, ldt, a, lda, b, ldb,work, ldwork ) @@ -13678,9 +14743,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_slarfb_gett #endif -#:if WITH_QP - module procedure stdlib_wlarfb_gett +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$larfb_gett + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zlarfb_gett( ident, m, n, k, t, ldt, a, lda, b, ldb,work, ldwork ) @@ -13735,9 +14803,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dlarfg #endif -#:if WITH_QP - module procedure stdlib_qlarfg +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$larfg + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine slarfg( n, alpha, x, incx, tau ) import sp,dp,qp,ilp,lk @@ -13749,9 +14820,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_slarfg #endif -#:if WITH_QP - module procedure stdlib_wlarfg +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$larfg + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zlarfg( n, alpha, x, incx, tau ) import sp,dp,qp,ilp,lk @@ -13802,9 +14876,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dlarfgp #endif -#:if WITH_QP - module procedure stdlib_qlarfgp +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$larfgp + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK subroutine slarfgp( n, alpha, x, incx, tau ) import sp,dp,qp,ilp,lk @@ -13816,9 +14893,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_slarfgp #endif -#:if WITH_QP - module procedure stdlib_wlarfgp +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$larfgp + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK subroutine zlarfgp( n, alpha, x, incx, tau ) import sp,dp,qp,ilp,lk @@ -13869,9 +14949,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dlarft #endif -#:if WITH_QP - module procedure stdlib_qlarft +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$larft + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine slarft( direct, storev, n, k, v, ldv, tau, t, ldt ) import sp,dp,qp,ilp,lk @@ -13884,9 +14967,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_slarft #endif -#:if WITH_QP - module procedure stdlib_wlarft +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$larft + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zlarft( direct, storev, n, k, v, ldv, tau, t, ldt ) import sp,dp,qp,ilp,lk @@ -13936,9 +15022,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dlarfy #endif -#:if WITH_QP - module procedure stdlib_qlarfy +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$larfy + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine slarfy( uplo, n, v, incv, tau, c, ldc, work ) import sp,dp,qp,ilp,lk @@ -13952,9 +15041,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_slarfy #endif -#:if WITH_QP - module procedure stdlib_wlarfy +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$larfy + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zlarfy( uplo, n, v, incv, tau, c, ldc, work ) import sp,dp,qp,ilp,lk @@ -14005,9 +15097,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dlargv #endif -#:if WITH_QP - module procedure stdlib_qlargv +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$largv + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine slargv( n, x, incx, y, incy, c, incc ) import sp,dp,qp,ilp,lk @@ -14019,9 +15114,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_slargv #endif -#:if WITH_QP - module procedure stdlib_wlargv +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$largv + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zlargv( n, x, incx, y, incy, c, incc ) import sp,dp,qp,ilp,lk @@ -14062,9 +15160,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dlarnv #endif -#:if WITH_QP - module procedure stdlib_qlarnv +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$larnv + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine slarnv( idist, iseed, n, x ) import sp,dp,qp,ilp,lk @@ -14076,9 +15177,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_slarnv #endif -#:if WITH_QP - module procedure stdlib_wlarnv +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$larnv + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zlarnv( idist, iseed, n, x ) import sp,dp,qp,ilp,lk @@ -14109,9 +15213,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dlarra #endif -#:if WITH_QP - module procedure stdlib_qlarra +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$larra + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine slarra( n, d, e, e2, spltol, tnrm,nsplit, isplit, info ) import sp,dp,qp,ilp,lk @@ -14151,9 +15258,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dlarrb #endif -#:if WITH_QP - module procedure stdlib_qlarrb +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$larrb + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine slarrb( n, d, lld, ifirst, ilast, rtol1,rtol2, offset, w, wgap, & werr, work, iwork,pivmin, spdiam, twist, info ) @@ -14189,9 +15299,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dlarrc #endif -#:if WITH_QP - module procedure stdlib_qlarrc +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$larrc + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine slarrc( jobt, n, vl, vu, d, e, pivmin,eigcnt, lcnt, rcnt, info ) @@ -14237,9 +15350,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dlarrd #endif -#:if WITH_QP - module procedure stdlib_qlarrd +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$larrd + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine slarrd( range, order, n, vl, vu, il, iu, gers,reltol, d, e, e2, & pivmin, nsplit, isplit,m, w, werr, wl, wu, iblock, indexw,work, iwork, info ) @@ -14290,9 +15406,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dlarre #endif -#:if WITH_QP - module procedure stdlib_qlarre +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$larre + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine slarre( range, n, vl, vu, il, iu, d, e, e2,rtol1, rtol2, spltol, & nsplit, isplit, m,w, werr, wgap, iblock, indexw, gers, pivmin,work, iwork, info ) @@ -14335,9 +15454,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dlarrf #endif -#:if WITH_QP - module procedure stdlib_qlarrf +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$larrf + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine slarrf( n, d, l, ld, clstrt, clend,w, wgap, werr,spdiam, clgapl, & clgapr, pivmin, sigma,dplus, lplus, work, info ) @@ -14379,9 +15501,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dlarrj #endif -#:if WITH_QP - module procedure stdlib_qlarrj +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$larrj + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine slarrj( n, d, e2, ifirst, ilast,rtol, offset, w, werr, work, iwork,& pivmin, spdiam, info ) @@ -14422,9 +15547,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dlarrk #endif -#:if WITH_QP - module procedure stdlib_qlarrk +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$larrk + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine slarrk( n, iw, gl, gu,d, e2, pivmin, reltol, w, werr, info) import sp,dp,qp,ilp,lk @@ -14457,9 +15585,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dlarrr #endif -#:if WITH_QP - module procedure stdlib_qlarrr +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$larrr + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine slarrr( n, d, e, info ) import sp,dp,qp,ilp,lk @@ -14513,9 +15644,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dlarrv #endif -#:if WITH_QP - module procedure stdlib_qlarrv +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$larrv + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine slarrv( n, vl, vu, d, l, pivmin,isplit, m, dol, dou, minrgp,rtol1, & rtol2, w, werr, wgap,iblock, indexw, gers, z, ldz, isuppz,work, iwork, info ) @@ -14532,9 +15666,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_slarrv #endif -#:if WITH_QP - module procedure stdlib_wlarrv +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$larrv + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zlarrv( n, vl, vu, d, l, pivmin,isplit, m, dol, dou, minrgp,rtol1, & rtol2, w, werr, wgap,iblock, indexw, gers, z, ldz, isuppz,work, iwork, info ) @@ -14600,9 +15737,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dlartg #endif -#:if WITH_QP - module procedure stdlib_qlartg +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$lartg + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine slartg( f, g, c, s, r ) import sp,dp,qp,ilp,lk @@ -14613,9 +15753,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_slartg #endif -#:if WITH_QP - module procedure stdlib_wlartg +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$lartg + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zlartg( f, g, c, s, r ) import sp,dp,qp,ilp,lk @@ -14651,9 +15794,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dlartgp #endif -#:if WITH_QP - module procedure stdlib_qlartgp +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$lartgp + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine slartgp( f, g, cs, sn, r ) import sp,dp,qp,ilp,lk @@ -14687,9 +15833,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dlartgs #endif -#:if WITH_QP - module procedure stdlib_qlartgs +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$lartgs + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine slartgs( x, y, sigma, cs, sn ) import sp,dp,qp,ilp,lk @@ -14732,9 +15881,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dlartv #endif -#:if WITH_QP - module procedure stdlib_qlartv +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$lartv + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine slartv( n, x, incx, y, incy, c, s, incc ) import sp,dp,qp,ilp,lk @@ -14746,9 +15898,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_slartv #endif -#:if WITH_QP - module procedure stdlib_wlartv +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$lartv + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zlartv( n, x, incx, y, incy, c, s, incc ) import sp,dp,qp,ilp,lk @@ -14780,9 +15935,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dlaruv #endif -#:if WITH_QP - module procedure stdlib_qlaruv +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$laruv + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine slaruv( iseed, n, x ) import sp,dp,qp,ilp,lk @@ -14834,9 +15992,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dlarz #endif -#:if WITH_QP - module procedure stdlib_qlarz +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$larz + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine slarz( side, m, n, l, v, incv, tau, c, ldc, work ) import sp,dp,qp,ilp,lk @@ -14850,9 +16011,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_slarz #endif -#:if WITH_QP - module procedure stdlib_wlarz +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$larz + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zlarz( side, m, n, l, v, incv, tau, c, ldc, work ) import sp,dp,qp,ilp,lk @@ -14900,9 +16064,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dlarzb #endif -#:if WITH_QP - module procedure stdlib_qlarzb +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$larzb + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine slarzb( side, trans, direct, storev, m, n, k, l, v,ldv, t, ldt, c, & ldc, work, ldwork ) @@ -14916,9 +16083,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_slarzb #endif -#:if WITH_QP - module procedure stdlib_wlarzb +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$larzb + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zlarzb( side, trans, direct, storev, m, n, k, l, v,ldv, t, ldt, c, & ldc, work, ldwork ) @@ -14975,9 +16145,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dlarzt #endif -#:if WITH_QP - module procedure stdlib_qlarzt +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$larzt + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine slarzt( direct, storev, n, k, v, ldv, tau, t, ldt ) import sp,dp,qp,ilp,lk @@ -14991,9 +16164,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_slarzt #endif -#:if WITH_QP - module procedure stdlib_wlarzt +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$larzt + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zlarzt( direct, storev, n, k, v, ldv, tau, t, ldt ) import sp,dp,qp,ilp,lk @@ -15043,9 +16219,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dlascl #endif -#:if WITH_QP - module procedure stdlib_qlascl +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$lascl + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine slascl( type, kl, ku, cfrom, cto, m, n, a, lda, info ) import sp,dp,qp,ilp,lk @@ -15059,9 +16238,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_slascl #endif -#:if WITH_QP - module procedure stdlib_wlascl +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$lascl + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zlascl( type, kl, ku, cfrom, cto, m, n, a, lda, info ) import sp,dp,qp,ilp,lk @@ -15100,9 +16282,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dlasd0 #endif -#:if WITH_QP - module procedure stdlib_qlasd0 +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$lasd0 + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine slasd0( n, sqre, d, e, u, ldu, vt, ldvt, smlsiz, iwork,work, info ) @@ -15164,9 +16349,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dlasd1 #endif -#:if WITH_QP - module procedure stdlib_qlasd1 +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$lasd1 + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine slasd1( nl, nr, sqre, d, alpha, beta, u, ldu, vt, ldvt,idxq, iwork,& work, info ) @@ -15209,9 +16397,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dlasd4 #endif -#:if WITH_QP - module procedure stdlib_qlasd4 +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$lasd4 + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine slasd4( n, i, d, z, delta, rho, sigma, work, info ) import sp,dp,qp,ilp,lk @@ -15248,9 +16439,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dlasd5 #endif -#:if WITH_QP - module procedure stdlib_qlasd5 +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$lasd5 + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine slasd5( i, d, z, delta, rho, dsigma, work ) import sp,dp,qp,ilp,lk @@ -15319,9 +16513,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dlasd6 #endif -#:if WITH_QP - module procedure stdlib_qlasd6 +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$lasd6 + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine slasd6( icompq, nl, nr, sqre, d, vf, vl, alpha, beta,idxq, perm, & givptr, givcol, ldgcol, givnum,ldgnum, poles, difl, difr, z, k, c, s, work,iwork, & @@ -15369,9 +16566,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dlasd7 #endif -#:if WITH_QP - module procedure stdlib_qlasd7 +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$lasd7 + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine slasd7( icompq, nl, nr, sqre, k, d, z, zw, vf, vfw, vl,vlw, alpha, & beta, dsigma, idx, idxp, idxq,perm, givptr, givcol, ldgcol, givnum, ldgnum,c, s, & @@ -15415,9 +16615,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dlasd8 #endif -#:if WITH_QP - module procedure stdlib_qlasd8 +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$lasd8 + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine slasd8( icompq, k, d, z, vf, vl, difl, difr, lddifr,dsigma, work, & info ) @@ -15459,9 +16662,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dlasda #endif -#:if WITH_QP - module procedure stdlib_qlasda +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$lasda + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine slasda( icompq, smlsiz, n, sqre, d, e, u, ldu, vt, k,difl, difr, z,& poles, givptr, givcol, ldgcol,perm, givnum, c, s, work, iwork, info ) @@ -15508,9 +16714,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dlasdq #endif -#:if WITH_QP - module procedure stdlib_qlasdq +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$lasdq + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine slasdq( uplo, sqre, n, ncvt, nru, ncc, d, e, vt, ldvt,u, ldu, c, & ldc, work, info ) @@ -15556,9 +16765,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dlaset #endif -#:if WITH_QP - module procedure stdlib_qlaset +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$laset + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine slaset( uplo, m, n, alpha, beta, a, lda ) import sp,dp,qp,ilp,lk @@ -15571,9 +16783,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_slaset #endif -#:if WITH_QP - module procedure stdlib_wlaset +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$laset + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zlaset( uplo, m, n, alpha, beta, a, lda ) import sp,dp,qp,ilp,lk @@ -15613,9 +16828,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dlasq1 #endif -#:if WITH_QP - module procedure stdlib_qlasq1 +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$lasq1 + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine slasq1( n, d, e, work, info ) import sp,dp,qp,ilp,lk @@ -15649,9 +16867,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dlasq4 #endif -#:if WITH_QP - module procedure stdlib_qlasq4 +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$lasq4 + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine slasq4( i0, n0, z, pp, n0in, dmin, dmin1, dmin2, dn,dn1, dn2, tau, & ttype, g ) @@ -15687,9 +16908,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dlasq5 #endif -#:if WITH_QP - module procedure stdlib_qlasq5 +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$lasq5 + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine slasq5( i0, n0, z, pp, tau, sigma, dmin, dmin1, dmin2,dn, dnm1, & dnm2, ieee, eps ) @@ -15722,9 +16946,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dlasq6 #endif -#:if WITH_QP - module procedure stdlib_qlasq6 +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$lasq6 + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine slasq6( i0, n0, z, pp, dmin, dmin1, dmin2, dn,dnm1, dnm2 ) import sp,dp,qp,ilp,lk @@ -15816,9 +17043,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dlasr #endif -#:if WITH_QP - module procedure stdlib_qlasr +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$lasr + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine slasr( side, pivot, direct, m, n, c, s, a, lda ) import sp,dp,qp,ilp,lk @@ -15831,9 +17061,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_slasr #endif -#:if WITH_QP - module procedure stdlib_wlasr +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$lasr + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zlasr( side, pivot, direct, m, n, c, s, a, lda ) import sp,dp,qp,ilp,lk @@ -15867,9 +17100,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dlasrt #endif -#:if WITH_QP - module procedure stdlib_qlasrt +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$lasrt + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine slasrt( id, n, d, info ) import sp,dp,qp,ilp,lk @@ -15927,9 +17163,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dlassq #endif -#:if WITH_QP - module procedure stdlib_qlassq +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$lassq + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine slassq( n, x, incx, scl, sumsq ) import sp,dp,qp,ilp,lk @@ -15941,9 +17180,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_slassq #endif -#:if WITH_QP - module procedure stdlib_wlassq +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$lassq + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zlassq( n, x, incx, scl, sumsq ) import sp,dp,qp,ilp,lk @@ -15994,9 +17236,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dlaswlq #endif -#:if WITH_QP - module procedure stdlib_qlaswlq +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$laswlq + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine slaswlq( m, n, mb, nb, a, lda, t, ldt, work, lwork,info) import sp,dp,qp,ilp,lk @@ -16009,9 +17254,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_slaswlq #endif -#:if WITH_QP - module procedure stdlib_wlaswlq +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$laswlq + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zlaswlq( m, n, mb, nb, a, lda, t, ldt, work, lwork,info) import sp,dp,qp,ilp,lk @@ -16051,9 +17299,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dlaswp #endif -#:if WITH_QP - module procedure stdlib_qlaswp +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$laswp + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine slaswp( n, a, lda, k1, k2, ipiv, incx ) import sp,dp,qp,ilp,lk @@ -16064,9 +17315,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_slaswp #endif -#:if WITH_QP - module procedure stdlib_wlaswp +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$laswp + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zlaswp( n, a, lda, k1, k2, ipiv, incx ) import sp,dp,qp,ilp,lk @@ -16121,9 +17375,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dlasyf #endif -#:if WITH_QP - module procedure stdlib_qlasyf +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$lasyf + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine slasyf( uplo, n, nb, kb, a, lda, ipiv, w, ldw, info ) import sp,dp,qp,ilp,lk @@ -16137,9 +17394,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_slasyf #endif -#:if WITH_QP - module procedure stdlib_wlasyf +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$lasyf + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zlasyf( uplo, n, nb, kb, a, lda, ipiv, w, ldw, info ) import sp,dp,qp,ilp,lk @@ -16194,9 +17454,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dlasyf_aa #endif -#:if WITH_QP - module procedure stdlib_qlasyf_aa +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$lasyf_aa + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine slasyf_aa( uplo, j1, m, nb, a, lda, ipiv,h, ldh, work ) import sp,dp,qp,ilp,lk @@ -16210,9 +17473,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_slasyf_aa #endif -#:if WITH_QP - module procedure stdlib_wlasyf_aa +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$lasyf_aa + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zlasyf_aa( uplo, j1, m, nb, a, lda, ipiv,h, ldh, work ) import sp,dp,qp,ilp,lk @@ -16269,9 +17535,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dlasyf_rk #endif -#:if WITH_QP - module procedure stdlib_qlasyf_rk +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$lasyf_rk + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine slasyf_rk( uplo, n, nb, kb, a, lda, e, ipiv, w, ldw,info ) import sp,dp,qp,ilp,lk @@ -16285,9 +17554,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_slasyf_rk #endif -#:if WITH_QP - module procedure stdlib_wlasyf_rk +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$lasyf_rk + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zlasyf_rk( uplo, n, nb, kb, a, lda, e, ipiv, w, ldw,info ) import sp,dp,qp,ilp,lk @@ -16344,9 +17616,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dlasyf_rook #endif -#:if WITH_QP - module procedure stdlib_qlasyf_rook +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$lasyf_rook + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine slasyf_rook( uplo, n, nb, kb, a, lda, ipiv, w, ldw,info ) import sp,dp,qp,ilp,lk @@ -16360,9 +17635,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_slasyf_rook #endif -#:if WITH_QP - module procedure stdlib_wlasyf_rook +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$lasyf_rook + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zlasyf_rook( uplo, n, nb, kb, a, lda, ipiv, w, ldw,info ) import sp,dp,qp,ilp,lk @@ -16422,9 +17700,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dlatbs #endif -#:if WITH_QP - module procedure stdlib_qlatbs +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$latbs + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine slatbs( uplo, trans, diag, normin, n, kd, ab, ldab, x,scale, cnorm,& info ) @@ -16440,9 +17721,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_slatbs #endif -#:if WITH_QP - module procedure stdlib_wlatbs +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$latbs + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zlatbs( uplo, trans, diag, normin, n, kd, ab, ldab, x,scale, cnorm,& info ) @@ -16493,9 +17777,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dlatdf #endif -#:if WITH_QP - module procedure stdlib_qlatdf +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$latdf + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine slatdf( ijob, n, z, ldz, rhs, rdsum, rdscal, ipiv,jpiv ) import sp,dp,qp,ilp,lk @@ -16506,9 +17793,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_slatdf #endif -#:if WITH_QP - module procedure stdlib_wlatdf +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$latdf + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zlatdf( ijob, n, z, ldz, rhs, rdsum, rdscal, ipiv,jpiv ) import sp,dp,qp,ilp,lk @@ -16567,9 +17857,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dlatps #endif -#:if WITH_QP - module procedure stdlib_qlatps +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$latps + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine slatps( uplo, trans, diag, normin, n, ap, x, scale,cnorm, info ) @@ -16585,9 +17878,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_slatps #endif -#:if WITH_QP - module procedure stdlib_wlatps +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$latps + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zlatps( uplo, trans, diag, normin, n, ap, x, scale,cnorm, info ) @@ -16643,9 +17939,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dlatrd #endif -#:if WITH_QP - module procedure stdlib_qlatrd +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$latrd + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine slatrd( uplo, n, nb, a, lda, e, tau, w, ldw ) import sp,dp,qp,ilp,lk @@ -16658,9 +17957,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_slatrd #endif -#:if WITH_QP - module procedure stdlib_wlatrd +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$latrd + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zlatrd( uplo, n, nb, a, lda, e, tau, w, ldw ) import sp,dp,qp,ilp,lk @@ -16720,9 +18022,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dlatrs #endif -#:if WITH_QP - module procedure stdlib_qlatrs +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$latrs + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine slatrs( uplo, trans, diag, normin, n, a, lda, x, scale,cnorm, info & ) @@ -16738,9 +18043,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_slatrs #endif -#:if WITH_QP - module procedure stdlib_wlatrs +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$latrs + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zlatrs( uplo, trans, diag, normin, n, a, lda, x, scale,cnorm, info & ) @@ -16788,9 +18096,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dlatrz #endif -#:if WITH_QP - module procedure stdlib_qlatrz +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$latrz + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine slatrz( m, n, l, a, lda, tau, work ) import sp,dp,qp,ilp,lk @@ -16802,9 +18113,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_slatrz #endif -#:if WITH_QP - module procedure stdlib_wlatrz +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$latrz + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zlatrz( m, n, l, a, lda, tau, work ) import sp,dp,qp,ilp,lk @@ -16856,9 +18170,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dlatsqr #endif -#:if WITH_QP - module procedure stdlib_qlatsqr +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$latsqr + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine slatsqr( m, n, mb, nb, a, lda, t, ldt, work,lwork, info) import sp,dp,qp,ilp,lk @@ -16871,9 +18188,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_slatsqr #endif -#:if WITH_QP - module procedure stdlib_wlatsqr +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$latsqr + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zlatsqr( m, n, mb, nb, a, lda, t, ldt, work,lwork, info) import sp,dp,qp,ilp,lk @@ -16936,9 +18256,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_claunhr_col_getrfnp #endif -#:if WITH_QP - module procedure stdlib_wlaunhr_col_getrfnp +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$launhr_col_getrfnp + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zlaunhr_col_getrfnp( m, n, a, lda, d, info ) import sp,dp,qp,ilp,lk @@ -17016,9 +18339,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_claunhr_col_getrfnp2 #endif -#:if WITH_QP - module procedure stdlib_wlaunhr_col_getrfnp2 +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$launhr_col_getrfnp2 + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure recursive subroutine zlaunhr_col_getrfnp2( m, n, a, lda, d, info ) import sp,dp,qp,ilp,lk @@ -17068,9 +18394,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dlauum #endif -#:if WITH_QP - module procedure stdlib_qlauum +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$lauum + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine slauum( uplo, n, a, lda, info ) import sp,dp,qp,ilp,lk @@ -17083,9 +18412,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_slauum #endif -#:if WITH_QP - module procedure stdlib_wlauum +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$lauum + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zlauum( uplo, n, a, lda, info ) import sp,dp,qp,ilp,lk @@ -17121,9 +18453,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dopgtr #endif -#:if WITH_QP - module procedure stdlib_qopgtr +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$opgtr + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine sopgtr( uplo, n, ap, tau, q, ldq, work, info ) import sp,dp,qp,ilp,lk @@ -17167,9 +18502,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dopmtr #endif -#:if WITH_QP - module procedure stdlib_qopmtr +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$opmtr + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine sopmtr( side, uplo, trans, m, n, ap, tau, c, ldc, work,info ) @@ -17222,9 +18560,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dorbdb #endif -#:if WITH_QP - module procedure stdlib_qorbdb +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$orbdb + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK subroutine sorbdb( trans, signs, m, p, q, x11, ldx11, x12, ldx12,x21, ldx21, x22, & ldx22, theta, phi, taup1,taup2, tauq1, tauq2, work, lwork, info ) @@ -17275,9 +18616,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dorbdb1 #endif -#:if WITH_QP - module procedure stdlib_qorbdb1 +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$orbdb1 + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK subroutine sorbdb1( m, p, q, x11, ldx11, x21, ldx21, theta, phi,taup1, taup2, & tauq1, work, lwork, info ) @@ -17326,9 +18670,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dorbdb2 #endif -#:if WITH_QP - module procedure stdlib_qorbdb2 +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$orbdb2 + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK subroutine sorbdb2( m, p, q, x11, ldx11, x21, ldx21, theta, phi,taup1, taup2, & tauq1, work, lwork, info ) @@ -17377,9 +18724,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dorbdb3 #endif -#:if WITH_QP - module procedure stdlib_qorbdb3 +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$orbdb3 + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK subroutine sorbdb3( m, p, q, x11, ldx11, x21, ldx21, theta, phi,taup1, taup2, & tauq1, work, lwork, info ) @@ -17428,9 +18778,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dorbdb4 #endif -#:if WITH_QP - module procedure stdlib_qorbdb4 +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$orbdb4 + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK subroutine sorbdb4( m, p, q, x11, ldx11, x21, ldx21, theta, phi,taup1, taup2, & tauq1, phantom, work, lwork,info ) @@ -17475,9 +18828,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dorbdb5 #endif -#:if WITH_QP - module procedure stdlib_qorbdb5 +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$orbdb5 + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine sorbdb5( m1, m2, n, x1, incx1, x2, incx2, q1, ldq1, q2,ldq2, work, & lwork, info ) @@ -17520,9 +18876,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dorbdb6 #endif -#:if WITH_QP - module procedure stdlib_qorbdb6 +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$orbdb6 + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine sorbdb6( m1, m2, n, x1, incx1, x2, incx2, q1, ldq1, q2,ldq2, work, & lwork, info ) @@ -17573,9 +18932,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dorcsd #endif -#:if WITH_QP - module procedure stdlib_qorcsd +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$orcsd + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK recursive subroutine sorcsd( jobu1, jobu2, jobv1t, jobv2t, trans,signs, m, p, q, & x11, ldx11, x12,ldx12, x21, ldx21, x22, ldx22, theta,u1, ldu1, u2, ldu2, v1t, & @@ -17629,9 +18991,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dorcsd2by1 #endif -#:if WITH_QP - module procedure stdlib_qorcsd2by1 +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$orcsd2by1 + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK subroutine sorcsd2by1( jobu1, jobu2, jobv1t, m, p, q, x11, ldx11,x21, ldx21, theta,& u1, ldu1, u2, ldu2, v1t,ldv1t, work, lwork, iwork, info ) @@ -17670,9 +19035,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dorg2l #endif -#:if WITH_QP - module procedure stdlib_qorg2l +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$org2l + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine sorg2l( m, n, k, a, lda, tau, work, info ) import sp,dp,qp,ilp,lk @@ -17709,9 +19077,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dorg2r #endif -#:if WITH_QP - module procedure stdlib_qorg2r +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$org2r + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine sorg2r( m, n, k, a, lda, tau, work, info ) import sp,dp,qp,ilp,lk @@ -17760,9 +19131,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dorgbr #endif -#:if WITH_QP - module procedure stdlib_qorgbr +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$orgbr + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine sorgbr( vect, m, n, k, a, lda, tau, work, lwork, info ) import sp,dp,qp,ilp,lk @@ -17799,9 +19173,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dorghr #endif -#:if WITH_QP - module procedure stdlib_qorghr +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$orghr + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine sorghr( n, ilo, ihi, a, lda, tau, work, lwork, info ) import sp,dp,qp,ilp,lk @@ -17838,9 +19215,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dorglq #endif -#:if WITH_QP - module procedure stdlib_qorglq +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$orglq + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine sorglq( m, n, k, a, lda, tau, work, lwork, info ) import sp,dp,qp,ilp,lk @@ -17877,9 +19257,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dorgql #endif -#:if WITH_QP - module procedure stdlib_qorgql +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$orgql + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine sorgql( m, n, k, a, lda, tau, work, lwork, info ) import sp,dp,qp,ilp,lk @@ -17916,9 +19299,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dorgqr #endif -#:if WITH_QP - module procedure stdlib_qorgqr +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$orgqr + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine sorgqr( m, n, k, a, lda, tau, work, lwork, info ) import sp,dp,qp,ilp,lk @@ -17955,9 +19341,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dorgrq #endif -#:if WITH_QP - module procedure stdlib_qorgrq +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$orgrq + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine sorgrq( m, n, k, a, lda, tau, work, lwork, info ) import sp,dp,qp,ilp,lk @@ -17995,9 +19384,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dorgtr #endif -#:if WITH_QP - module procedure stdlib_qorgtr +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$orgtr + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine sorgtr( uplo, n, a, lda, tau, work, lwork, info ) import sp,dp,qp,ilp,lk @@ -18035,9 +19427,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dorgtsqr #endif -#:if WITH_QP - module procedure stdlib_qorgtsqr +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$orgtsqr + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine sorgtsqr( m, n, mb, nb, a, lda, t, ldt, work, lwork,info ) import sp,dp,qp,ilp,lk @@ -18085,9 +19480,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dorgtsqr_row #endif -#:if WITH_QP - module procedure stdlib_qorgtsqr_row +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$orgtsqr_row + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine sorgtsqr_row( m, n, mb, nb, a, lda, t, ldt, work,lwork, info ) @@ -18128,9 +19526,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dorhr_col #endif -#:if WITH_QP - module procedure stdlib_qorhr_col +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$orhr_col + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine sorhr_col( m, n, nb, a, lda, t, ldt, d, info ) import sp,dp,qp,ilp,lk @@ -18173,9 +19574,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dorm2l #endif -#:if WITH_QP - module procedure stdlib_qorm2l +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$orm2l + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine sorm2l( side, trans, m, n, k, a, lda, tau, c, ldc,work, info ) @@ -18221,9 +19625,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dorm2r #endif -#:if WITH_QP - module procedure stdlib_qorm2r +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$orm2r + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine sorm2r( side, trans, m, n, k, a, lda, tau, c, ldc,work, info ) @@ -18281,9 +19688,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dormbr #endif -#:if WITH_QP - module procedure stdlib_qormbr +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$ormbr + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine sormbr( vect, side, trans, m, n, k, a, lda, tau, c,ldc, work, & lwork, info ) @@ -18327,9 +19737,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dormhr #endif -#:if WITH_QP - module procedure stdlib_qormhr +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$ormhr + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine sormhr( side, trans, m, n, ilo, ihi, a, lda, tau, c,ldc, work, & lwork, info ) @@ -18374,9 +19787,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dormlq #endif -#:if WITH_QP - module procedure stdlib_qormlq +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$ormlq + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine sormlq( side, trans, m, n, k, a, lda, tau, c, ldc,work, lwork, & info ) @@ -18421,9 +19837,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dormql #endif -#:if WITH_QP - module procedure stdlib_qormql +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$ormql + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine sormql( side, trans, m, n, k, a, lda, tau, c, ldc,work, lwork, & info ) @@ -18468,9 +19887,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dormqr #endif -#:if WITH_QP - module procedure stdlib_qormqr +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$ormqr + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine sormqr( side, trans, m, n, k, a, lda, tau, c, ldc,work, lwork, & info ) @@ -18515,9 +19937,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dormrq #endif -#:if WITH_QP - module procedure stdlib_qormrq +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$ormrq + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine sormrq( side, trans, m, n, k, a, lda, tau, c, ldc,work, lwork, & info ) @@ -18562,9 +19987,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dormrz #endif -#:if WITH_QP - module procedure stdlib_qormrz +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$ormrz + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine sormrz( side, trans, m, n, k, l, a, lda, tau, c, ldc,work, lwork, & info ) @@ -18609,9 +20037,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dormtr #endif -#:if WITH_QP - module procedure stdlib_qormtr +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$ormtr + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine sormtr( side, uplo, trans, m, n, a, lda, tau, c, ldc,work, lwork, & info ) @@ -18668,9 +20099,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dpbcon #endif -#:if WITH_QP - module procedure stdlib_qpbcon +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$pbcon + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine spbcon( uplo, n, kd, ab, ldab, anorm, rcond, work,iwork, info ) @@ -18685,9 +20119,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_spbcon #endif -#:if WITH_QP - module procedure stdlib_wpbcon +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$pbcon + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zpbcon( uplo, n, kd, ab, ldab, anorm, rcond, work,rwork, info ) @@ -18743,9 +20180,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dpbequ #endif -#:if WITH_QP - module procedure stdlib_qpbequ +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$pbequ + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine spbequ( uplo, n, kd, ab, ldab, s, scond, amax, info ) import sp,dp,qp,ilp,lk @@ -18759,9 +20199,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_spbequ #endif -#:if WITH_QP - module procedure stdlib_wpbequ +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$pbequ + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zpbequ( uplo, n, kd, ab, ldab, s, scond, amax, info ) import sp,dp,qp,ilp,lk @@ -18815,9 +20258,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dpbrfs #endif -#:if WITH_QP - module procedure stdlib_qpbrfs +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$pbrfs + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine spbrfs( uplo, n, kd, nrhs, ab, ldab, afb, ldafb, b,ldb, x, ldx, & ferr, berr, work, iwork, info ) @@ -18833,9 +20279,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_spbrfs #endif -#:if WITH_QP - module procedure stdlib_wpbrfs +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$pbrfs + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zpbrfs( uplo, n, kd, nrhs, ab, ldab, afb, ldafb, b,ldb, x, ldx, & ferr, berr, work, rwork, info ) @@ -18890,9 +20339,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dpbstf #endif -#:if WITH_QP - module procedure stdlib_qpbstf +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$pbstf + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine spbstf( uplo, n, kd, ab, ldab, info ) import sp,dp,qp,ilp,lk @@ -18905,9 +20357,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_spbstf #endif -#:if WITH_QP - module procedure stdlib_wpbstf +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$pbstf + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zpbstf( uplo, n, kd, ab, ldab, info ) import sp,dp,qp,ilp,lk @@ -18960,9 +20415,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dpbsv #endif -#:if WITH_QP - module procedure stdlib_qpbsv +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$pbsv + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine spbsv( uplo, n, kd, nrhs, ab, ldab, b, ldb, info ) import sp,dp,qp,ilp,lk @@ -18975,9 +20433,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_spbsv #endif -#:if WITH_QP - module procedure stdlib_wpbsv +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$pbsv + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zpbsv( uplo, n, kd, nrhs, ab, ldab, b, ldb, info ) import sp,dp,qp,ilp,lk @@ -19025,9 +20486,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dpbtrf #endif -#:if WITH_QP - module procedure stdlib_qpbtrf +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$pbtrf + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine spbtrf( uplo, n, kd, ab, ldab, info ) import sp,dp,qp,ilp,lk @@ -19040,9 +20504,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_spbtrf #endif -#:if WITH_QP - module procedure stdlib_wpbtrf +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$pbtrf + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zpbtrf( uplo, n, kd, ab, ldab, info ) import sp,dp,qp,ilp,lk @@ -19089,9 +20556,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dpbtrs #endif -#:if WITH_QP - module procedure stdlib_qpbtrs +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$pbtrs + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine spbtrs( uplo, n, kd, nrhs, ab, ldab, b, ldb, info ) import sp,dp,qp,ilp,lk @@ -19105,9 +20575,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_spbtrs #endif -#:if WITH_QP - module procedure stdlib_wpbtrs +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$pbtrs + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zpbtrs( uplo, n, kd, nrhs, ab, ldab, b, ldb, info ) import sp,dp,qp,ilp,lk @@ -19157,9 +20630,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dpftrf #endif -#:if WITH_QP - module procedure stdlib_qpftrf +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$pftrf + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine spftrf( transr, uplo, n, a, info ) import sp,dp,qp,ilp,lk @@ -19172,9 +20648,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_spftrf #endif -#:if WITH_QP - module procedure stdlib_wpftrf +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$pftrf + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zpftrf( transr, uplo, n, a, info ) import sp,dp,qp,ilp,lk @@ -19219,9 +20698,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dpftri #endif -#:if WITH_QP - module procedure stdlib_qpftri +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$pftri + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine spftri( transr, uplo, n, a, info ) import sp,dp,qp,ilp,lk @@ -19234,9 +20716,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_spftri #endif -#:if WITH_QP - module procedure stdlib_wpftri +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$pftri + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zpftri( transr, uplo, n, a, info ) import sp,dp,qp,ilp,lk @@ -19283,9 +20768,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dpftrs #endif -#:if WITH_QP - module procedure stdlib_qpftrs +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$pftrs + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine spftrs( transr, uplo, n, nrhs, a, b, ldb, info ) import sp,dp,qp,ilp,lk @@ -19299,9 +20787,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_spftrs #endif -#:if WITH_QP - module procedure stdlib_wpftrs +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$pftrs + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zpftrs( transr, uplo, n, nrhs, a, b, ldb, info ) import sp,dp,qp,ilp,lk @@ -19354,9 +20845,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dpocon #endif -#:if WITH_QP - module procedure stdlib_qpocon +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$pocon + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine spocon( uplo, n, a, lda, anorm, rcond, work, iwork,info ) import sp,dp,qp,ilp,lk @@ -19371,9 +20865,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_spocon #endif -#:if WITH_QP - module procedure stdlib_wpocon +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$pocon + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zpocon( uplo, n, a, lda, anorm, rcond, work, rwork,info ) import sp,dp,qp,ilp,lk @@ -19426,9 +20923,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dpoequ #endif -#:if WITH_QP - module procedure stdlib_qpoequ +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$poequ + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine spoequ( n, a, lda, s, scond, amax, info ) import sp,dp,qp,ilp,lk @@ -19441,9 +20941,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_spoequ #endif -#:if WITH_QP - module procedure stdlib_wpoequ +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$poequ + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zpoequ( n, a, lda, s, scond, amax, info ) import sp,dp,qp,ilp,lk @@ -19498,9 +21001,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dpoequb #endif -#:if WITH_QP - module procedure stdlib_qpoequb +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$poequb + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine spoequb( n, a, lda, s, scond, amax, info ) import sp,dp,qp,ilp,lk @@ -19513,9 +21019,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_spoequb #endif -#:if WITH_QP - module procedure stdlib_wpoequb +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$poequb + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zpoequb( n, a, lda, s, scond, amax, info ) import sp,dp,qp,ilp,lk @@ -19568,9 +21077,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dporfs #endif -#:if WITH_QP - module procedure stdlib_qporfs +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$porfs + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine sporfs( uplo, n, nrhs, a, lda, af, ldaf, b, ldb, x,ldx, ferr, berr,& work, iwork, info ) @@ -19586,9 +21098,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_sporfs #endif -#:if WITH_QP - module procedure stdlib_wporfs +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$porfs + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zporfs( uplo, n, nrhs, a, lda, af, ldaf, b, ldb, x,ldx, ferr, berr,& work, rwork, info ) @@ -19644,9 +21159,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dposv #endif -#:if WITH_QP - module procedure stdlib_qposv +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$posv + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine sposv( uplo, n, nrhs, a, lda, b, ldb, info ) import sp,dp,qp,ilp,lk @@ -19659,9 +21177,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_sposv #endif -#:if WITH_QP - module procedure stdlib_wposv +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$posv + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zposv( uplo, n, nrhs, a, lda, b, ldb, info ) import sp,dp,qp,ilp,lk @@ -19710,9 +21231,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dpotrf #endif -#:if WITH_QP - module procedure stdlib_qpotrf +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$potrf + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine spotrf( uplo, n, a, lda, info ) import sp,dp,qp,ilp,lk @@ -19725,9 +21249,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_spotrf #endif -#:if WITH_QP - module procedure stdlib_wpotrf +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$potrf + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zpotrf( uplo, n, a, lda, info ) import sp,dp,qp,ilp,lk @@ -19782,9 +21309,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dpotrf2 #endif -#:if WITH_QP - module procedure stdlib_qpotrf2 +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$potrf2 + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure recursive subroutine spotrf2( uplo, n, a, lda, info ) import sp,dp,qp,ilp,lk @@ -19797,9 +21327,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_spotrf2 #endif -#:if WITH_QP - module procedure stdlib_wpotrf2 +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$potrf2 + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure recursive subroutine zpotrf2( uplo, n, a, lda, info ) import sp,dp,qp,ilp,lk @@ -19844,9 +21377,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dpotri #endif -#:if WITH_QP - module procedure stdlib_qpotri +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$potri + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine spotri( uplo, n, a, lda, info ) import sp,dp,qp,ilp,lk @@ -19859,9 +21395,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_spotri #endif -#:if WITH_QP - module procedure stdlib_wpotri +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$potri + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zpotri( uplo, n, a, lda, info ) import sp,dp,qp,ilp,lk @@ -19908,9 +21447,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dpotrs #endif -#:if WITH_QP - module procedure stdlib_qpotrs +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$potrs + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine spotrs( uplo, n, nrhs, a, lda, b, ldb, info ) import sp,dp,qp,ilp,lk @@ -19924,9 +21466,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_spotrs #endif -#:if WITH_QP - module procedure stdlib_wpotrs +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$potrs + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zpotrs( uplo, n, nrhs, a, lda, b, ldb, info ) import sp,dp,qp,ilp,lk @@ -19979,9 +21524,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dppcon #endif -#:if WITH_QP - module procedure stdlib_qppcon +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$ppcon + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine sppcon( uplo, n, ap, anorm, rcond, work, iwork, info ) import sp,dp,qp,ilp,lk @@ -19995,9 +21543,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_sppcon #endif -#:if WITH_QP - module procedure stdlib_wppcon +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$ppcon + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zppcon( uplo, n, ap, anorm, rcond, work, rwork, info ) import sp,dp,qp,ilp,lk @@ -20052,9 +21603,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dppequ #endif -#:if WITH_QP - module procedure stdlib_qppequ +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$ppequ + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine sppequ( uplo, n, ap, s, scond, amax, info ) import sp,dp,qp,ilp,lk @@ -20068,9 +21622,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_sppequ #endif -#:if WITH_QP - module procedure stdlib_wppequ +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$ppequ + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zppequ( uplo, n, ap, s, scond, amax, info ) import sp,dp,qp,ilp,lk @@ -20124,9 +21681,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dpprfs #endif -#:if WITH_QP - module procedure stdlib_qpprfs +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$pprfs + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine spprfs( uplo, n, nrhs, ap, afp, b, ldb, x, ldx, ferr,berr, work, & iwork, info ) @@ -20142,9 +21702,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_spprfs #endif -#:if WITH_QP - module procedure stdlib_wpprfs +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$pprfs + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zpprfs( uplo, n, nrhs, ap, afp, b, ldb, x, ldx, ferr,berr, work, & rwork, info ) @@ -20200,9 +21763,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dppsv #endif -#:if WITH_QP - module procedure stdlib_qppsv +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$ppsv + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine sppsv( uplo, n, nrhs, ap, b, ldb, info ) import sp,dp,qp,ilp,lk @@ -20215,9 +21781,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_sppsv #endif -#:if WITH_QP - module procedure stdlib_wppsv +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$ppsv + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zppsv( uplo, n, nrhs, ap, b, ldb, info ) import sp,dp,qp,ilp,lk @@ -20265,9 +21834,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dpptrf #endif -#:if WITH_QP - module procedure stdlib_qpptrf +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$pptrf + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine spptrf( uplo, n, ap, info ) import sp,dp,qp,ilp,lk @@ -20280,9 +21852,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_spptrf #endif -#:if WITH_QP - module procedure stdlib_wpptrf +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$pptrf + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zpptrf( uplo, n, ap, info ) import sp,dp,qp,ilp,lk @@ -20327,9 +21902,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dpptri #endif -#:if WITH_QP - module procedure stdlib_qpptri +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$pptri + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine spptri( uplo, n, ap, info ) import sp,dp,qp,ilp,lk @@ -20342,9 +21920,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_spptri #endif -#:if WITH_QP - module procedure stdlib_wpptri +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$pptri + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zpptri( uplo, n, ap, info ) import sp,dp,qp,ilp,lk @@ -20391,9 +21972,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dpptrs #endif -#:if WITH_QP - module procedure stdlib_qpptrs +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$pptrs + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine spptrs( uplo, n, nrhs, ap, b, ldb, info ) import sp,dp,qp,ilp,lk @@ -20407,9 +21991,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_spptrs #endif -#:if WITH_QP - module procedure stdlib_wpptrs +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$pptrs + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zpptrs( uplo, n, nrhs, ap, b, ldb, info ) import sp,dp,qp,ilp,lk @@ -20465,9 +22052,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dpstrf #endif -#:if WITH_QP - module procedure stdlib_qpstrf +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$pstrf + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine spstrf( uplo, n, a, lda, piv, rank, tol, work, info ) import sp,dp,qp,ilp,lk @@ -20482,9 +22072,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_spstrf #endif -#:if WITH_QP - module procedure stdlib_wpstrf +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$pstrf + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zpstrf( uplo, n, a, lda, piv, rank, tol, work, info ) import sp,dp,qp,ilp,lk @@ -20536,9 +22129,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dptcon #endif -#:if WITH_QP - module procedure stdlib_qptcon +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$ptcon + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine sptcon( n, d, e, anorm, rcond, work, info ) import sp,dp,qp,ilp,lk @@ -20551,9 +22147,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_sptcon #endif -#:if WITH_QP - module procedure stdlib_wptcon +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$ptcon + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zptcon( n, d, e, anorm, rcond, rwork, info ) import sp,dp,qp,ilp,lk @@ -20614,9 +22213,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dpteqr #endif -#:if WITH_QP - module procedure stdlib_qpteqr +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$pteqr + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine spteqr( compz, n, d, e, z, ldz, work, info ) import sp,dp,qp,ilp,lk @@ -20630,9 +22232,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_spteqr #endif -#:if WITH_QP - module procedure stdlib_wpteqr +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$pteqr + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zpteqr( compz, n, d, e, z, ldz, work, info ) import sp,dp,qp,ilp,lk @@ -20687,9 +22292,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dptrfs #endif -#:if WITH_QP - module procedure stdlib_qptrfs +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$ptrfs + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine sptrfs( n, nrhs, d, e, df, ef, b, ldb, x, ldx, ferr,berr, work, & info ) @@ -20704,9 +22312,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_sptrfs #endif -#:if WITH_QP - module procedure stdlib_wptrfs +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$ptrfs + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zptrfs( uplo, n, nrhs, d, e, df, ef, b, ldb, x, ldx,ferr, berr, & work, rwork, info ) @@ -20757,9 +22368,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dptsv #endif -#:if WITH_QP - module procedure stdlib_qptsv +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$ptsv + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine sptsv( n, nrhs, d, e, b, ldb, info ) import sp,dp,qp,ilp,lk @@ -20771,9 +22385,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_sptsv #endif -#:if WITH_QP - module procedure stdlib_wptsv +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$ptsv + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zptsv( n, nrhs, d, e, b, ldb, info ) import sp,dp,qp,ilp,lk @@ -20817,9 +22434,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dpttrf #endif -#:if WITH_QP - module procedure stdlib_qpttrf +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$pttrf + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine spttrf( n, d, e, info ) import sp,dp,qp,ilp,lk @@ -20831,9 +22451,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_spttrf #endif -#:if WITH_QP - module procedure stdlib_wpttrf +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$pttrf + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zpttrf( n, d, e, info ) import sp,dp,qp,ilp,lk @@ -20883,9 +22506,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dpttrs #endif -#:if WITH_QP - module procedure stdlib_qpttrs +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$pttrs + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine spttrs( n, nrhs, d, e, b, ldb, info ) import sp,dp,qp,ilp,lk @@ -20898,9 +22524,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_spttrs #endif -#:if WITH_QP - module procedure stdlib_wpttrs +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$pttrs + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zpttrs( uplo, n, nrhs, d, e, b, ldb, info ) import sp,dp,qp,ilp,lk @@ -20934,9 +22563,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_crot #endif -#:if WITH_QP - module procedure stdlib_wrot +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$rot + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zrot( n, cx, incx, cy, incy, c, s ) import sp,dp,qp,ilp,lk @@ -20968,9 +22600,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_drscl #endif -#:if WITH_QP - module procedure stdlib_qrscl +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$rscl + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine srscl( n, sa, sx, incx ) import sp,dp,qp,ilp,lk @@ -21003,9 +22638,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dsb2st_kernels #endif -#:if WITH_QP - module procedure stdlib_qsb2st_kernels +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$sb2st_kernels + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine ssb2st_kernels( uplo, wantz, ttype,st, ed, sweep, n, nb, ib,a, & lda, v, tau, ldvt, work) @@ -21040,9 +22678,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dsbev #endif -#:if WITH_QP - module procedure stdlib_qsbev +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$sbev + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK subroutine ssbev( jobz, uplo, n, kd, ab, ldab, w, z, ldz, work,info ) import sp,dp,qp,ilp,lk @@ -21084,9 +22725,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dsbevd #endif -#:if WITH_QP - module procedure stdlib_qsbevd +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$sbevd + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK subroutine ssbevd( jobz, uplo, n, kd, ab, ldab, w, z, ldz, work,lwork, iwork, & liwork, info ) @@ -21128,9 +22772,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dsbgst #endif -#:if WITH_QP - module procedure stdlib_qsbgst +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$sbgst + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine ssbgst( vect, uplo, n, ka, kb, ab, ldab, bb, ldbb, x,ldx, work, & info ) @@ -21169,9 +22816,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dsbgv #endif -#:if WITH_QP - module procedure stdlib_qsbgv +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$sbgv + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine ssbgv( jobz, uplo, n, ka, kb, ab, ldab, bb, ldbb, w, z,ldz, work, & info ) @@ -21216,9 +22866,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dsbgvd #endif -#:if WITH_QP - module procedure stdlib_qsbgvd +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$sbgvd + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine ssbgvd( jobz, uplo, n, ka, kb, ab, ldab, bb, ldbb, w,z, ldz, work, & lwork, iwork, liwork, info ) @@ -21255,9 +22908,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dsbtrd #endif -#:if WITH_QP - module procedure stdlib_qsbtrd +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$sbtrd + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine ssbtrd( vect, uplo, n, kd, ab, ldab, d, e, q, ldq,work, info ) @@ -21297,9 +22953,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dsfrk #endif -#:if WITH_QP - module procedure stdlib_qsfrk +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$sfrk + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine ssfrk( transr, uplo, trans, n, k, alpha, a, lda, beta,c ) import sp,dp,qp,ilp,lk @@ -21350,9 +23009,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dspcon #endif -#:if WITH_QP - module procedure stdlib_qspcon +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$spcon + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine sspcon( uplo, n, ap, ipiv, anorm, rcond, work, iwork,info ) import sp,dp,qp,ilp,lk @@ -21366,9 +23028,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_sspcon #endif -#:if WITH_QP - module procedure stdlib_wspcon +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$spcon + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zspcon( uplo, n, ap, ipiv, anorm, rcond, work, info ) import sp,dp,qp,ilp,lk @@ -21404,9 +23069,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dspev #endif -#:if WITH_QP - module procedure stdlib_qspev +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$spev + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK subroutine sspev( jobz, uplo, n, ap, w, z, ldz, work, info ) import sp,dp,qp,ilp,lk @@ -21448,9 +23116,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dspevd #endif -#:if WITH_QP - module procedure stdlib_qspevd +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$spevd + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK subroutine sspevd( jobz, uplo, n, ap, w, z, ldz, work, lwork,iwork, liwork, info ) @@ -21490,9 +23161,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dspgst #endif -#:if WITH_QP - module procedure stdlib_qspgst +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$spgst + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine sspgst( itype, uplo, n, ap, bp, info ) import sp,dp,qp,ilp,lk @@ -21529,9 +23203,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dspgv #endif -#:if WITH_QP - module procedure stdlib_qspgv +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$spgv + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK subroutine sspgv( itype, jobz, uplo, n, ap, bp, w, z, ldz, work,info ) import sp,dp,qp,ilp,lk @@ -21576,9 +23253,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dspgvd #endif -#:if WITH_QP - module procedure stdlib_qspgvd +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$spgvd + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK subroutine sspgvd( itype, jobz, uplo, n, ap, bp, w, z, ldz, work,lwork, iwork, & liwork, info ) @@ -21614,9 +23294,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_cspmv #endif -#:if WITH_QP - module procedure stdlib_wspmv +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$spmv + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zspmv( uplo, n, alpha, ap, x, incx, beta, y, incy ) import sp,dp,qp,ilp,lk @@ -21650,9 +23333,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_cspr #endif -#:if WITH_QP - module procedure stdlib_wspr +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$spr + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zspr( uplo, n, alpha, x, incx, ap ) import sp,dp,qp,ilp,lk @@ -21705,9 +23391,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dsprfs #endif -#:if WITH_QP - module procedure stdlib_qsprfs +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$sprfs + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine ssprfs( uplo, n, nrhs, ap, afp, ipiv, b, ldb, x, ldx,ferr, berr, & work, iwork, info ) @@ -21723,9 +23412,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_ssprfs #endif -#:if WITH_QP - module procedure stdlib_wsprfs +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$sprfs + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zsprfs( uplo, n, nrhs, ap, afp, ipiv, b, ldb, x, ldx,ferr, berr, & work, rwork, info ) @@ -21782,9 +23474,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dspsv #endif -#:if WITH_QP - module procedure stdlib_qspsv +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$spsv + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine sspsv( uplo, n, nrhs, ap, ipiv, b, ldb, info ) import sp,dp,qp,ilp,lk @@ -21797,9 +23492,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_sspsv #endif -#:if WITH_QP - module procedure stdlib_wspsv +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$spsv + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zspsv( uplo, n, nrhs, ap, ipiv, b, ldb, info ) import sp,dp,qp,ilp,lk @@ -21833,9 +23531,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dsptrd #endif -#:if WITH_QP - module procedure stdlib_qsptrd +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$sptrd + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine ssptrd( uplo, n, ap, d, e, tau, info ) import sp,dp,qp,ilp,lk @@ -21885,9 +23586,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dsptrf #endif -#:if WITH_QP - module procedure stdlib_qsptrf +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$sptrf + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine ssptrf( uplo, n, ap, ipiv, info ) import sp,dp,qp,ilp,lk @@ -21900,9 +23604,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_ssptrf #endif -#:if WITH_QP - module procedure stdlib_wsptrf +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$sptrf + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zsptrf( uplo, n, ap, ipiv, info ) import sp,dp,qp,ilp,lk @@ -21949,9 +23656,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dsptri #endif -#:if WITH_QP - module procedure stdlib_qsptri +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$sptri + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine ssptri( uplo, n, ap, ipiv, work, info ) import sp,dp,qp,ilp,lk @@ -21965,9 +23675,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_ssptri #endif -#:if WITH_QP - module procedure stdlib_wsptri +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$sptri + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zsptri( uplo, n, ap, ipiv, work, info ) import sp,dp,qp,ilp,lk @@ -22015,9 +23728,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dsptrs #endif -#:if WITH_QP - module procedure stdlib_qsptrs +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$sptrs + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine ssptrs( uplo, n, nrhs, ap, ipiv, b, ldb, info ) import sp,dp,qp,ilp,lk @@ -22031,9 +23747,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_ssptrs #endif -#:if WITH_QP - module procedure stdlib_wsptrs +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$sptrs + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zsptrs( uplo, n, nrhs, ap, ipiv, b, ldb, info ) import sp,dp,qp,ilp,lk @@ -22077,9 +23796,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dstebz #endif -#:if WITH_QP - module procedure stdlib_qstebz +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$stebz + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine sstebz( range, order, n, vl, vu, il, iu, abstol, d, e,m, nsplit, w,& iblock, isplit, work, iwork,info ) @@ -22141,9 +23863,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dstedc #endif -#:if WITH_QP - module procedure stdlib_qstedc +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$stedc + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine sstedc( compz, n, d, e, z, ldz, work, lwork, iwork,liwork, info ) @@ -22158,9 +23883,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_sstedc #endif -#:if WITH_QP - module procedure stdlib_wstedc +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$stedc + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zstedc( compz, n, d, e, z, ldz, work, lwork, rwork,lrwork, iwork, & liwork, info ) @@ -22229,9 +23957,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dstegr #endif -#:if WITH_QP - module procedure stdlib_qstegr +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$stegr + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine sstegr( jobz, range, n, d, e, vl, vu, il, iu,abstol, m, w, z, ldz, & isuppz, work, lwork, iwork,liwork, info ) @@ -22247,9 +23978,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_sstegr #endif -#:if WITH_QP - module procedure stdlib_wstegr +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$stegr + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zstegr( jobz, range, n, d, e, vl, vu, il, iu,abstol, m, w, z, ldz, & isuppz, work, lwork, iwork,liwork, info ) @@ -22307,9 +24041,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dstein #endif -#:if WITH_QP - module procedure stdlib_qstein +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$stein + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine sstein( n, d, e, m, w, iblock, isplit, z, ldz, work,iwork, ifail, & info ) @@ -22323,9 +24060,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_sstein #endif -#:if WITH_QP - module procedure stdlib_wstein +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$stein + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zstein( n, d, e, m, w, iblock, isplit, z, ldz, work,iwork, ifail, & info ) @@ -22437,9 +24177,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dstemr #endif -#:if WITH_QP - module procedure stdlib_qstemr +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$stemr + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine sstemr( jobz, range, n, d, e, vl, vu, il, iu,m, w, z, ldz, nzc, & isuppz, tryrac, work, lwork,iwork, liwork, info ) @@ -22456,9 +24199,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_sstemr #endif -#:if WITH_QP - module procedure stdlib_wstemr +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$stemr + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zstemr( jobz, range, n, d, e, vl, vu, il, iu,m, w, z, ldz, nzc, & isuppz, tryrac, work, lwork,iwork, liwork, info ) @@ -22513,9 +24259,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dsteqr #endif -#:if WITH_QP - module procedure stdlib_qsteqr +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$steqr + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine ssteqr( compz, n, d, e, z, ldz, work, info ) import sp,dp,qp,ilp,lk @@ -22529,9 +24278,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_ssteqr #endif -#:if WITH_QP - module procedure stdlib_wsteqr +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$steqr + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zsteqr( compz, n, d, e, z, ldz, work, info ) import sp,dp,qp,ilp,lk @@ -22564,9 +24316,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dsterf #endif -#:if WITH_QP - module procedure stdlib_qsterf +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$sterf + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine ssterf( n, d, e, info ) import sp,dp,qp,ilp,lk @@ -22598,9 +24353,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dstev #endif -#:if WITH_QP - module procedure stdlib_qstev +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$stev + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine sstev( jobz, n, d, e, z, ldz, work, info ) import sp,dp,qp,ilp,lk @@ -22642,9 +24400,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dstevd #endif -#:if WITH_QP - module procedure stdlib_qstevd +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$stevd + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine sstevd( jobz, n, d, e, z, ldz, work, lwork, iwork,liwork, info ) @@ -22714,9 +24475,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dstevr #endif -#:if WITH_QP - module procedure stdlib_qstevr +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$stevr + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine sstevr( jobz, range, n, d, e, vl, vu, il, iu, abstol,m, w, z, ldz, & isuppz, work, lwork, iwork,liwork, info ) @@ -22771,9 +24535,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dsycon #endif -#:if WITH_QP - module procedure stdlib_qsycon +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$sycon + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine ssycon( uplo, n, a, lda, ipiv, anorm, rcond, work,iwork, info ) @@ -22788,9 +24555,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_ssycon #endif -#:if WITH_QP - module procedure stdlib_wsycon +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$sycon + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zsycon( uplo, n, a, lda, ipiv, anorm, rcond, work,info ) import sp,dp,qp,ilp,lk @@ -22846,9 +24616,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dsycon_rook #endif -#:if WITH_QP - module procedure stdlib_qsycon_rook +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$sycon_rook + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine ssycon_rook( uplo, n, a, lda, ipiv, anorm, rcond, work,iwork, info & ) @@ -22863,9 +24636,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_ssycon_rook #endif -#:if WITH_QP - module procedure stdlib_wsycon_rook +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$sycon_rook + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zsycon_rook( uplo, n, a, lda, ipiv, anorm, rcond, work,info ) @@ -22916,9 +24692,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dsyconv #endif -#:if WITH_QP - module procedure stdlib_qsyconv +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$syconv + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine ssyconv( uplo, way, n, a, lda, ipiv, e, info ) import sp,dp,qp,ilp,lk @@ -22932,9 +24711,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_ssyconv #endif -#:if WITH_QP - module procedure stdlib_wsyconv +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$syconv + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zsyconv( uplo, way, n, a, lda, ipiv, e, info ) import sp,dp,qp,ilp,lk @@ -22996,9 +24778,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dsyconvf #endif -#:if WITH_QP - module procedure stdlib_qsyconvf +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$syconvf + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine ssyconvf( uplo, way, n, a, lda, e, ipiv, info ) import sp,dp,qp,ilp,lk @@ -23012,9 +24797,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_ssyconvf #endif -#:if WITH_QP - module procedure stdlib_wsyconvf +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$syconvf + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zsyconvf( uplo, way, n, a, lda, e, ipiv, info ) import sp,dp,qp,ilp,lk @@ -23072,9 +24860,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dsyconvf_rook #endif -#:if WITH_QP - module procedure stdlib_qsyconvf_rook +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$syconvf_rook + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine ssyconvf_rook( uplo, way, n, a, lda, e, ipiv, info ) import sp,dp,qp,ilp,lk @@ -23087,9 +24878,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_ssyconvf_rook #endif -#:if WITH_QP - module procedure stdlib_wsyconvf_rook +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$syconvf_rook + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zsyconvf_rook( uplo, way, n, a, lda, e, ipiv, info ) import sp,dp,qp,ilp,lk @@ -23141,9 +24935,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dsyequb #endif -#:if WITH_QP - module procedure stdlib_qsyequb +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$syequb + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine ssyequb( uplo, n, a, lda, s, scond, amax, work, info ) import sp,dp,qp,ilp,lk @@ -23157,9 +24954,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_ssyequb #endif -#:if WITH_QP - module procedure stdlib_wsyequb +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$syequb + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zsyequb( uplo, n, a, lda, s, scond, amax, work, info ) import sp,dp,qp,ilp,lk @@ -23194,9 +24994,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dsyev #endif -#:if WITH_QP - module procedure stdlib_qsyev +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$syev + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK subroutine ssyev( jobz, uplo, n, a, lda, w, work, lwork, info ) import sp,dp,qp,ilp,lk @@ -23240,9 +25043,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dsyevd #endif -#:if WITH_QP - module procedure stdlib_qsyevd +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$syevd + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK subroutine ssyevd( jobz, uplo, n, a, lda, w, work, lwork, iwork,liwork, info ) @@ -23327,9 +25133,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dsyevr #endif -#:if WITH_QP - module procedure stdlib_qsyevr +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$syevr + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK subroutine ssyevr( jobz, range, uplo, n, a, lda, vl, vu, il, iu,abstol, m, w, z, & ldz, isuppz, work, lwork,iwork, liwork, info ) @@ -23370,9 +25179,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dsygst #endif -#:if WITH_QP - module procedure stdlib_qsygst +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$sygst + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine ssygst( itype, uplo, n, a, lda, b, ldb, info ) import sp,dp,qp,ilp,lk @@ -23410,9 +25222,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dsygv #endif -#:if WITH_QP - module procedure stdlib_qsygv +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$sygv + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK subroutine ssygv( itype, jobz, uplo, n, a, lda, b, ldb, w, work,lwork, info ) @@ -23457,9 +25272,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dsygvd #endif -#:if WITH_QP - module procedure stdlib_qsygvd +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$sygvd + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK subroutine ssygvd( itype, jobz, uplo, n, a, lda, b, ldb, w, work,lwork, iwork, & liwork, info ) @@ -23495,9 +25313,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_csymv #endif -#:if WITH_QP - module procedure stdlib_wsymv +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$symv + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zsymv( uplo, n, alpha, a, lda, x, incx, beta, y, incy ) import sp,dp,qp,ilp,lk @@ -23531,9 +25352,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_csyr #endif -#:if WITH_QP - module procedure stdlib_wsyr +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$syr + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zsyr( uplo, n, alpha, x, incx, a, lda ) import sp,dp,qp,ilp,lk @@ -23585,9 +25409,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dsyrfs #endif -#:if WITH_QP - module procedure stdlib_qsyrfs +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$syrfs + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine ssyrfs( uplo, n, nrhs, a, lda, af, ldaf, ipiv, b, ldb,x, ldx, ferr,& berr, work, iwork, info ) @@ -23603,9 +25430,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_ssyrfs #endif -#:if WITH_QP - module procedure stdlib_wsyrfs +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$syrfs + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zsyrfs( uplo, n, nrhs, a, lda, af, ldaf, ipiv, b, ldb,x, ldx, ferr,& berr, work, rwork, info ) @@ -23666,9 +25496,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dsysv #endif -#:if WITH_QP - module procedure stdlib_qsysv +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$sysv + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine ssysv( uplo, n, nrhs, a, lda, ipiv, b, ldb, work,lwork, info ) @@ -23683,9 +25516,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_ssysv #endif -#:if WITH_QP - module procedure stdlib_wsysv +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$sysv + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zsysv( uplo, n, nrhs, a, lda, ipiv, b, ldb, work,lwork, info ) @@ -23743,9 +25579,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dsysv_aa #endif -#:if WITH_QP - module procedure stdlib_qsysv_aa +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$sysv_aa + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine ssysv_aa( uplo, n, nrhs, a, lda, ipiv, b, ldb, work,lwork, info ) @@ -23760,9 +25599,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_ssysv_aa #endif -#:if WITH_QP - module procedure stdlib_wsysv_aa +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$sysv_aa + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zsysv_aa( uplo, n, nrhs, a, lda, ipiv, b, ldb, work,lwork, info ) @@ -23824,9 +25666,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dsysv_rk #endif -#:if WITH_QP - module procedure stdlib_qsysv_rk +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$sysv_rk + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine ssysv_rk( uplo, n, nrhs, a, lda, e, ipiv, b, ldb,work, lwork, info & ) @@ -23841,9 +25686,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_ssysv_rk #endif -#:if WITH_QP - module procedure stdlib_wsysv_rk +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$sysv_rk + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zsysv_rk( uplo, n, nrhs, a, lda, e, ipiv, b, ldb, work,lwork, info & ) @@ -23907,9 +25755,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dsysv_rook #endif -#:if WITH_QP - module procedure stdlib_qsysv_rook +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$sysv_rook + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine ssysv_rook( uplo, n, nrhs, a, lda, ipiv, b, ldb, work,lwork, info ) @@ -23924,9 +25775,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_ssysv_rook #endif -#:if WITH_QP - module procedure stdlib_wsysv_rook +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$sysv_rook + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zsysv_rook( uplo, n, nrhs, a, lda, ipiv, b, ldb, work,lwork, info ) @@ -23970,9 +25824,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dsyswapr #endif -#:if WITH_QP - module procedure stdlib_qsyswapr +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$syswapr + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine ssyswapr( uplo, n, a, lda, i1, i2) import sp,dp,qp,ilp,lk @@ -23984,9 +25841,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_ssyswapr #endif -#:if WITH_QP - module procedure stdlib_wsyswapr +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$syswapr + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zsyswapr( uplo, n, a, lda, i1, i2) import sp,dp,qp,ilp,lk @@ -24038,9 +25898,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dsytf2_rk #endif -#:if WITH_QP - module procedure stdlib_qsytf2_rk +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$sytf2_rk + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine ssytf2_rk( uplo, n, a, lda, e, ipiv, info ) import sp,dp,qp,ilp,lk @@ -24054,9 +25917,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_ssytf2_rk #endif -#:if WITH_QP - module procedure stdlib_wsytf2_rk +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$sytf2_rk + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zsytf2_rk( uplo, n, a, lda, e, ipiv, info ) import sp,dp,qp,ilp,lk @@ -24106,9 +25972,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dsytf2_rook #endif -#:if WITH_QP - module procedure stdlib_qsytf2_rook +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$sytf2_rook + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine ssytf2_rook( uplo, n, a, lda, ipiv, info ) import sp,dp,qp,ilp,lk @@ -24121,9 +25990,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_ssytf2_rook #endif -#:if WITH_QP - module procedure stdlib_wsytf2_rook +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$sytf2_rook + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zsytf2_rook( uplo, n, a, lda, ipiv, info ) import sp,dp,qp,ilp,lk @@ -24157,9 +26029,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dsytrd #endif -#:if WITH_QP - module procedure stdlib_qsytrd +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$sytrd + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine ssytrd( uplo, n, a, lda, d, e, tau, work, lwork, info ) import sp,dp,qp,ilp,lk @@ -24195,9 +26070,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dsytrd_sb2st #endif -#:if WITH_QP - module procedure stdlib_qsytrd_sb2st +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$sytrd_sb2st + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK subroutine ssytrd_sb2st( stage1, vect, uplo, n, kd, ab, ldab,d, e, hous, & lhous, work, lwork, info ) @@ -24234,9 +26112,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dsytrd_sy2sb #endif -#:if WITH_QP - module procedure stdlib_qsytrd_sy2sb +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$sytrd_sy2sb + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK subroutine ssytrd_sy2sb( uplo, n, kd, a, lda, ab, ldab, tau,work, lwork, info & ) @@ -24290,9 +26171,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dsytrf #endif -#:if WITH_QP - module procedure stdlib_qsytrf +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$sytrf + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine ssytrf( uplo, n, a, lda, ipiv, work, lwork, info ) import sp,dp,qp,ilp,lk @@ -24306,9 +26190,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_ssytrf #endif -#:if WITH_QP - module procedure stdlib_wsytrf +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$sytrf + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zsytrf( uplo, n, a, lda, ipiv, work, lwork, info ) import sp,dp,qp,ilp,lk @@ -24359,9 +26246,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dsytrf_aa #endif -#:if WITH_QP - module procedure stdlib_qsytrf_aa +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$sytrf_aa + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine ssytrf_aa( uplo, n, a, lda, ipiv, work, lwork, info) import sp,dp,qp,ilp,lk @@ -24375,9 +26265,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_ssytrf_aa #endif -#:if WITH_QP - module procedure stdlib_wsytrf_aa +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$sytrf_aa + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zsytrf_aa( uplo, n, a, lda, ipiv, work, lwork, info) import sp,dp,qp,ilp,lk @@ -24431,9 +26324,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dsytrf_rk #endif -#:if WITH_QP - module procedure stdlib_qsytrf_rk +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$sytrf_rk + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine ssytrf_rk( uplo, n, a, lda, e, ipiv, work, lwork,info ) import sp,dp,qp,ilp,lk @@ -24447,9 +26343,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_ssytrf_rk #endif -#:if WITH_QP - module procedure stdlib_wsytrf_rk +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$sytrf_rk + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zsytrf_rk( uplo, n, a, lda, e, ipiv, work, lwork,info ) import sp,dp,qp,ilp,lk @@ -24502,9 +26401,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dsytrf_rook #endif -#:if WITH_QP - module procedure stdlib_qsytrf_rook +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$sytrf_rook + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine ssytrf_rook( uplo, n, a, lda, ipiv, work, lwork, info ) import sp,dp,qp,ilp,lk @@ -24518,9 +26420,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_ssytrf_rook #endif -#:if WITH_QP - module procedure stdlib_wsytrf_rook +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$sytrf_rook + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zsytrf_rook( uplo, n, a, lda, ipiv, work, lwork, info ) import sp,dp,qp,ilp,lk @@ -24568,9 +26473,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dsytri #endif -#:if WITH_QP - module procedure stdlib_qsytri +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$sytri + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine ssytri( uplo, n, a, lda, ipiv, work, info ) import sp,dp,qp,ilp,lk @@ -24584,9 +26492,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_ssytri #endif -#:if WITH_QP - module procedure stdlib_wsytri +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$sytri + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zsytri( uplo, n, a, lda, ipiv, work, info ) import sp,dp,qp,ilp,lk @@ -24634,9 +26545,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dsytri_rook #endif -#:if WITH_QP - module procedure stdlib_qsytri_rook +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$sytri_rook + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine ssytri_rook( uplo, n, a, lda, ipiv, work, info ) import sp,dp,qp,ilp,lk @@ -24650,9 +26564,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_ssytri_rook #endif -#:if WITH_QP - module procedure stdlib_wsytri_rook +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$sytri_rook + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zsytri_rook( uplo, n, a, lda, ipiv, work, info ) import sp,dp,qp,ilp,lk @@ -24700,9 +26617,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dsytrs #endif -#:if WITH_QP - module procedure stdlib_qsytrs +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$sytrs + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine ssytrs( uplo, n, nrhs, a, lda, ipiv, b, ldb, info ) import sp,dp,qp,ilp,lk @@ -24716,9 +26636,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_ssytrs #endif -#:if WITH_QP - module procedure stdlib_wsytrs +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$sytrs + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zsytrs( uplo, n, nrhs, a, lda, ipiv, b, ldb, info ) import sp,dp,qp,ilp,lk @@ -24766,9 +26689,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dsytrs2 #endif -#:if WITH_QP - module procedure stdlib_qsytrs2 +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$sytrs2 + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine ssytrs2( uplo, n, nrhs, a, lda, ipiv, b, ldb,work, info ) import sp,dp,qp,ilp,lk @@ -24782,9 +26708,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_ssytrs2 #endif -#:if WITH_QP - module procedure stdlib_wsytrs2 +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$sytrs2 + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zsytrs2( uplo, n, nrhs, a, lda, ipiv, b, ldb,work, info ) import sp,dp,qp,ilp,lk @@ -24838,9 +26767,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dsytrs_3 #endif -#:if WITH_QP - module procedure stdlib_qsytrs_3 +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$sytrs_3 + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine ssytrs_3( uplo, n, nrhs, a, lda, e, ipiv, b, ldb,info ) import sp,dp,qp,ilp,lk @@ -24854,9 +26786,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_ssytrs_3 #endif -#:if WITH_QP - module procedure stdlib_wsytrs_3 +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$sytrs_3 + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zsytrs_3( uplo, n, nrhs, a, lda, e, ipiv, b, ldb,info ) import sp,dp,qp,ilp,lk @@ -24908,9 +26843,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dsytrs_aa #endif -#:if WITH_QP - module procedure stdlib_qsytrs_aa +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$sytrs_aa + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine ssytrs_aa( uplo, n, nrhs, a, lda, ipiv, b, ldb,work, lwork, info ) @@ -24926,9 +26864,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_ssytrs_aa #endif -#:if WITH_QP - module procedure stdlib_wsytrs_aa +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$sytrs_aa + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zsytrs_aa( uplo, n, nrhs, a, lda, ipiv, b, ldb,work, lwork, info ) @@ -24978,9 +26919,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dsytrs_rook #endif -#:if WITH_QP - module procedure stdlib_qsytrs_rook +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$sytrs_rook + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine ssytrs_rook( uplo, n, nrhs, a, lda, ipiv, b, ldb,info ) import sp,dp,qp,ilp,lk @@ -24994,9 +26938,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_ssytrs_rook #endif -#:if WITH_QP - module procedure stdlib_wsytrs_rook +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$sytrs_rook + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zsytrs_rook( uplo, n, nrhs, a, lda, ipiv, b, ldb,info ) import sp,dp,qp,ilp,lk @@ -25050,9 +26997,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dtbcon #endif -#:if WITH_QP - module procedure stdlib_qtbcon +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$tbcon + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK subroutine stbcon( norm, uplo, diag, n, kd, ab, ldab, rcond, work,iwork, info ) @@ -25067,9 +27017,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_stbcon #endif -#:if WITH_QP - module procedure stdlib_wtbcon +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$tbcon + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK subroutine ztbcon( norm, uplo, diag, n, kd, ab, ldab, rcond, work,rwork, info ) @@ -25125,9 +27078,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dtbrfs #endif -#:if WITH_QP - module procedure stdlib_qtbrfs +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$tbrfs + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine stbrfs( uplo, trans, diag, n, kd, nrhs, ab, ldab, b,ldb, x, ldx, & ferr, berr, work, iwork, info ) @@ -25142,9 +27098,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_stbrfs #endif -#:if WITH_QP - module procedure stdlib_wtbrfs +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$tbrfs + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine ztbrfs( uplo, trans, diag, n, kd, nrhs, ab, ldab, b,ldb, x, ldx, & ferr, berr, work, rwork, info ) @@ -25197,9 +27156,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dtbtrs #endif -#:if WITH_QP - module procedure stdlib_qtbtrs +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$tbtrs + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine stbtrs( uplo, trans, diag, n, kd, nrhs, ab, ldab, b,ldb, info ) @@ -25214,9 +27176,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_stbtrs #endif -#:if WITH_QP - module procedure stdlib_wtbtrs +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$tbtrs + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine ztbtrs( uplo, trans, diag, n, kd, nrhs, ab, ldab, b,ldb, info ) @@ -25270,9 +27235,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dtfsm #endif -#:if WITH_QP - module procedure stdlib_qtfsm +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$tfsm + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine stfsm( transr, side, uplo, trans, diag, m, n, alpha, a,b, ldb ) @@ -25286,9 +27254,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_stfsm #endif -#:if WITH_QP - module procedure stdlib_wtfsm +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$tfsm + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine ztfsm( transr, side, uplo, trans, diag, m, n, alpha, a,b, ldb ) @@ -25334,9 +27305,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dtftri #endif -#:if WITH_QP - module procedure stdlib_qtftri +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$tftri + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine stftri( transr, uplo, diag, n, a, info ) import sp,dp,qp,ilp,lk @@ -25349,9 +27323,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_stftri #endif -#:if WITH_QP - module procedure stdlib_wtftri +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$tftri + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine ztftri( transr, uplo, diag, n, a, info ) import sp,dp,qp,ilp,lk @@ -25397,9 +27374,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dtfttp #endif -#:if WITH_QP - module procedure stdlib_qtfttp +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$tfttp + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine stfttp( transr, uplo, n, arf, ap, info ) import sp,dp,qp,ilp,lk @@ -25413,9 +27393,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_stfttp #endif -#:if WITH_QP - module procedure stdlib_wtfttp +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$tfttp + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine ztfttp( transr, uplo, n, arf, ap, info ) import sp,dp,qp,ilp,lk @@ -25462,9 +27445,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dtfttr #endif -#:if WITH_QP - module procedure stdlib_qtfttr +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$tfttr + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine stfttr( transr, uplo, n, arf, a, lda, info ) import sp,dp,qp,ilp,lk @@ -25478,9 +27464,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_stfttr #endif -#:if WITH_QP - module procedure stdlib_wtfttr +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$tfttr + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine ztfttr( transr, uplo, n, arf, a, lda, info ) import sp,dp,qp,ilp,lk @@ -25550,9 +27539,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dtgevc #endif -#:if WITH_QP - module procedure stdlib_qtgevc +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$tgevc + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine stgevc( side, howmny, select, n, s, lds, p, ldp, vl,ldvl, vr, ldvr,& mm, m, work, info ) @@ -25569,9 +27561,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_stgevc #endif -#:if WITH_QP - module procedure stdlib_wtgevc +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$tgevc + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine ztgevc( side, howmny, select, n, s, lds, p, ldp, vl,ldvl, vr, ldvr,& mm, m, work, rwork, info ) @@ -25633,9 +27628,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dtgexc #endif -#:if WITH_QP - module procedure stdlib_qtgexc +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$tgexc + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine stgexc( wantq, wantz, n, a, lda, b, ldb, q, ldq, z,ldz, ifst, ilst,& work, lwork, info ) @@ -25651,9 +27649,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_stgexc #endif -#:if WITH_QP - module procedure stdlib_wtgexc +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$tgexc + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine ztgexc( wantq, wantz, n, a, lda, b, ldb, q, ldq, z,ldz, ifst, ilst,& info ) @@ -25722,9 +27723,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dtgsen #endif -#:if WITH_QP - module procedure stdlib_qtgsen +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$tgsen + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine stgsen( ijob, wantq, wantz, select, n, a, lda, b, ldb,alphar, & alphai, beta, q, ldq, z, ldz, m, pl,pr, dif, work, lwork, iwork, liwork, info ) @@ -25741,9 +27745,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_stgsen #endif -#:if WITH_QP - module procedure stdlib_wtgsen +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$tgsen + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine ztgsen( ijob, wantq, wantz, select, n, a, lda, b, ldb,alpha, beta, & q, ldq, z, ldz, m, pl, pr, dif,work, lwork, iwork, liwork, info ) @@ -25859,9 +27866,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dtgsja #endif -#:if WITH_QP - module procedure stdlib_qtgsja +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$tgsja + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine stgsja( jobu, jobv, jobq, m, p, n, k, l, a, lda, b,ldb, tola, tolb,& alpha, beta, u, ldu, v, ldv,q, ldq, work, ncycle, info ) @@ -25878,9 +27888,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_stgsja #endif -#:if WITH_QP - module procedure stdlib_wtgsja +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$tgsja + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine ztgsja( jobu, jobv, jobq, m, p, n, k, l, a, lda, b,ldb, tola, tolb,& alpha, beta, u, ldu, v, ldv,q, ldq, work, ncycle, info ) @@ -25938,9 +27951,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dtgsna #endif -#:if WITH_QP - module procedure stdlib_qtgsna +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$tgsna + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine stgsna( job, howmny, select, n, a, lda, b, ldb, vl,ldvl, vr, ldvr, & s, dif, mm, m, work, lwork,iwork, info ) @@ -25956,9 +27972,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_stgsna #endif -#:if WITH_QP - module procedure stdlib_wtgsna +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$tgsna + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine ztgsna( job, howmny, select, n, a, lda, b, ldb, vl,ldvl, vr, ldvr, & s, dif, mm, m, work, lwork,iwork, info ) @@ -26038,9 +28057,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dtgsyl #endif -#:if WITH_QP - module procedure stdlib_qtgsyl +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$tgsyl + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine stgsyl( trans, ijob, m, n, a, lda, b, ldb, c, ldc, d,ldd, e, lde, & f, ldf, scale, dif, work, lwork,iwork, info ) @@ -26056,9 +28078,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_stgsyl #endif -#:if WITH_QP - module procedure stdlib_wtgsyl +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$tgsyl + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine ztgsyl( trans, ijob, m, n, a, lda, b, ldb, c, ldc, d,ldd, e, lde, & f, ldf, scale, dif, work, lwork,iwork, info ) @@ -26113,9 +28138,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dtpcon #endif -#:if WITH_QP - module procedure stdlib_qtpcon +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$tpcon + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK subroutine stpcon( norm, uplo, diag, n, ap, rcond, work, iwork,info ) import sp,dp,qp,ilp,lk @@ -26129,9 +28157,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_stpcon #endif -#:if WITH_QP - module procedure stdlib_wtpcon +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$tpcon + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK subroutine ztpcon( norm, uplo, diag, n, ap, rcond, work, rwork,info ) import sp,dp,qp,ilp,lk @@ -26179,9 +28210,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dtplqt #endif -#:if WITH_QP - module procedure stdlib_qtplqt +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$tplqt + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine stplqt( m, n, l, mb, a, lda, b, ldb, t, ldt, work,info ) import sp,dp,qp,ilp,lk @@ -26194,9 +28228,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_stplqt #endif -#:if WITH_QP - module procedure stdlib_wtplqt +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$tplqt + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine ztplqt( m, n, l, mb, a, lda, b, ldb, t, ldt, work,info ) import sp,dp,qp,ilp,lk @@ -26241,9 +28278,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dtplqt2 #endif -#:if WITH_QP - module procedure stdlib_qtplqt2 +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$tplqt2 + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine stplqt2( m, n, l, a, lda, b, ldb, t, ldt, info ) import sp,dp,qp,ilp,lk @@ -26256,9 +28296,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_stplqt2 #endif -#:if WITH_QP - module procedure stdlib_wtplqt2 +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$tplqt2 + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine ztplqt2( m, n, l, a, lda, b, ldb, t, ldt, info ) import sp,dp,qp,ilp,lk @@ -26309,9 +28352,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dtpmlqt #endif -#:if WITH_QP - module procedure stdlib_qtpmlqt +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$tpmlqt + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine stpmlqt( side, trans, m, n, k, l, mb, v, ldv, t, ldt,a, lda, b, & ldb, work, info ) @@ -26327,9 +28373,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_stpmlqt #endif -#:if WITH_QP - module procedure stdlib_wtpmlqt +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$tpmlqt + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine ztpmlqt( side, trans, m, n, k, l, mb, v, ldv, t, ldt,a, lda, b, & ldb, work, info ) @@ -26383,9 +28432,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dtpmqrt #endif -#:if WITH_QP - module procedure stdlib_qtpmqrt +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$tpmqrt + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine stpmqrt( side, trans, m, n, k, l, nb, v, ldv, t, ldt,a, lda, b, & ldb, work, info ) @@ -26401,9 +28453,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_stpmqrt #endif -#:if WITH_QP - module procedure stdlib_wtpmqrt +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$tpmqrt + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine ztpmqrt( side, trans, m, n, k, l, nb, v, ldv, t, ldt,a, lda, b, & ldb, work, info ) @@ -26452,9 +28507,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dtpqrt #endif -#:if WITH_QP - module procedure stdlib_qtpqrt +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$tpqrt + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine stpqrt( m, n, l, nb, a, lda, b, ldb, t, ldt, work,info ) import sp,dp,qp,ilp,lk @@ -26467,9 +28525,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_stpqrt #endif -#:if WITH_QP - module procedure stdlib_wtpqrt +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$tpqrt + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine ztpqrt( m, n, l, nb, a, lda, b, ldb, t, ldt, work,info ) import sp,dp,qp,ilp,lk @@ -26514,9 +28575,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dtpqrt2 #endif -#:if WITH_QP - module procedure stdlib_qtpqrt2 +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$tpqrt2 + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine stpqrt2( m, n, l, a, lda, b, ldb, t, ldt, info ) import sp,dp,qp,ilp,lk @@ -26529,9 +28593,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_stpqrt2 #endif -#:if WITH_QP - module procedure stdlib_wtpqrt2 +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$tpqrt2 + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine ztpqrt2( m, n, l, a, lda, b, ldb, t, ldt, info ) import sp,dp,qp,ilp,lk @@ -26580,9 +28647,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dtprfb #endif -#:if WITH_QP - module procedure stdlib_qtprfb +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$tprfb + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine stprfb( side, trans, direct, storev, m, n, k, l,v, ldv, t, ldt, a, & lda, b, ldb, work, ldwork ) @@ -26597,9 +28667,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_stprfb #endif -#:if WITH_QP - module procedure stdlib_wtprfb +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$tprfb + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine ztprfb( side, trans, direct, storev, m, n, k, l,v, ldv, t, ldt, a, & lda, b, ldb, work, ldwork ) @@ -26654,9 +28727,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dtprfs #endif -#:if WITH_QP - module procedure stdlib_qtprfs +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$tprfs + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine stprfs( uplo, trans, diag, n, nrhs, ap, b, ldb, x, ldx,ferr, berr, & work, iwork, info ) @@ -26671,9 +28747,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_stprfs #endif -#:if WITH_QP - module procedure stdlib_wtprfs +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$tprfs + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine ztprfs( uplo, trans, diag, n, nrhs, ap, b, ldb, x, ldx,ferr, berr, & work, rwork, info ) @@ -26720,9 +28799,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dtptri #endif -#:if WITH_QP - module procedure stdlib_qtptri +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$tptri + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine stptri( uplo, diag, n, ap, info ) import sp,dp,qp,ilp,lk @@ -26735,9 +28817,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_stptri #endif -#:if WITH_QP - module procedure stdlib_wtptri +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$tptri + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine ztptri( uplo, diag, n, ap, info ) import sp,dp,qp,ilp,lk @@ -26786,9 +28871,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dtptrs #endif -#:if WITH_QP - module procedure stdlib_qtptrs +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$tptrs + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine stptrs( uplo, trans, diag, n, nrhs, ap, b, ldb, info ) import sp,dp,qp,ilp,lk @@ -26802,9 +28890,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_stptrs #endif -#:if WITH_QP - module procedure stdlib_wtptrs +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$tptrs + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine ztptrs( uplo, trans, diag, n, nrhs, ap, b, ldb, info ) import sp,dp,qp,ilp,lk @@ -26851,9 +28942,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dtpttf #endif -#:if WITH_QP - module procedure stdlib_qtpttf +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$tpttf + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine stpttf( transr, uplo, n, ap, arf, info ) import sp,dp,qp,ilp,lk @@ -26867,9 +28961,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_stpttf #endif -#:if WITH_QP - module procedure stdlib_wtpttf +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$tpttf + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine ztpttf( transr, uplo, n, ap, arf, info ) import sp,dp,qp,ilp,lk @@ -26916,9 +29013,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dtpttr #endif -#:if WITH_QP - module procedure stdlib_qtpttr +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$tpttr + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine stpttr( uplo, n, ap, a, lda, info ) import sp,dp,qp,ilp,lk @@ -26932,9 +29032,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_stpttr #endif -#:if WITH_QP - module procedure stdlib_wtpttr +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$tpttr + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine ztpttr( uplo, n, ap, a, lda, info ) import sp,dp,qp,ilp,lk @@ -26986,9 +29089,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dtrcon #endif -#:if WITH_QP - module procedure stdlib_qtrcon +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$trcon + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK subroutine strcon( norm, uplo, diag, n, a, lda, rcond, work,iwork, info ) import sp,dp,qp,ilp,lk @@ -27002,9 +29108,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_strcon #endif -#:if WITH_QP - module procedure stdlib_wtrcon +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$trcon + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK subroutine ztrcon( norm, uplo, diag, n, a, lda, rcond, work,rwork, info ) import sp,dp,qp,ilp,lk @@ -27071,9 +29180,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dtrevc #endif -#:if WITH_QP - module procedure stdlib_qtrevc +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$trevc + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine strevc( side, howmny, select, n, t, ldt, vl, ldvl, vr,ldvr, mm, m, & work, info ) @@ -27090,9 +29202,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_strevc #endif -#:if WITH_QP - module procedure stdlib_wtrevc +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$trevc + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine ztrevc( side, howmny, select, n, t, ldt, vl, ldvl, vr,ldvr, mm, m, & work, rwork, info ) @@ -27162,9 +29277,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dtrevc3 #endif -#:if WITH_QP - module procedure stdlib_qtrevc3 +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$trevc3 + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine strevc3( side, howmny, select, n, t, ldt, vl, ldvl,vr, ldvr, mm, m,& work, lwork, info ) @@ -27181,9 +29299,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_strevc3 #endif -#:if WITH_QP - module procedure stdlib_wtrevc3 +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$trevc3 + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine ztrevc3( side, howmny, select, n, t, ldt, vl, ldvl, vr,ldvr, mm, m,& work, lwork, rwork, lrwork, info) @@ -27237,9 +29358,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dtrexc #endif -#:if WITH_QP - module procedure stdlib_qtrexc +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$trexc + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK subroutine strexc( compq, n, t, ldt, q, ldq, ifst, ilst, work,info ) import sp,dp,qp,ilp,lk @@ -27254,9 +29378,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_strexc #endif -#:if WITH_QP - module procedure stdlib_wtrexc +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$trexc + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine ztrexc( compq, n, t, ldt, q, ldq, ifst, ilst, info ) import sp,dp,qp,ilp,lk @@ -27309,9 +29436,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dtrrfs #endif -#:if WITH_QP - module procedure stdlib_qtrrfs +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$trrfs + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine strrfs( uplo, trans, diag, n, nrhs, a, lda, b, ldb, x,ldx, ferr, & berr, work, iwork, info ) @@ -27326,9 +29456,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_strrfs #endif -#:if WITH_QP - module procedure stdlib_wtrrfs +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$trrfs + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine ztrrfs( uplo, trans, diag, n, nrhs, a, lda, b, ldb, x,ldx, ferr, & berr, work, rwork, info ) @@ -27387,9 +29520,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dtrsen #endif -#:if WITH_QP - module procedure stdlib_qtrsen +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$trsen + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK subroutine strsen( job, compq, select, n, t, ldt, q, ldq, wr, wi,m, s, sep, work, & lwork, iwork, liwork, info ) @@ -27405,9 +29541,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_strsen #endif -#:if WITH_QP - module procedure stdlib_wtrsen +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$trsen + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK subroutine ztrsen( job, compq, select, n, t, ldt, q, ldq, w, m, s,sep, work, lwork,& info ) @@ -27463,9 +29602,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dtrsna #endif -#:if WITH_QP - module procedure stdlib_qtrsna +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$trsna + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK subroutine strsna( job, howmny, select, n, t, ldt, vl, ldvl, vr,ldvr, s, sep, mm, & m, work, ldwork, iwork,info ) @@ -27481,9 +29623,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_strsna #endif -#:if WITH_QP - module procedure stdlib_wtrsna +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$trsna + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine ztrsna( job, howmny, select, n, t, ldt, vl, ldvl, vr,ldvr, s, sep, & mm, m, work, ldwork, rwork,info ) @@ -27542,9 +29687,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dtrsyl #endif -#:if WITH_QP - module procedure stdlib_qtrsyl +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$trsyl + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK subroutine strsyl( trana, tranb, isgn, m, n, a, lda, b, ldb, c,ldc, scale, info ) @@ -27560,9 +29708,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_strsyl #endif -#:if WITH_QP - module procedure stdlib_wtrsyl +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$trsyl + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK subroutine ztrsyl( trana, tranb, isgn, m, n, a, lda, b, ldb, c,ldc, scale, info ) @@ -27610,9 +29761,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dtrtri #endif -#:if WITH_QP - module procedure stdlib_qtrtri +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$trtri + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine strtri( uplo, diag, n, a, lda, info ) import sp,dp,qp,ilp,lk @@ -27625,9 +29779,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_strtri #endif -#:if WITH_QP - module procedure stdlib_wtrtri +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$trtri + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine ztrtri( uplo, diag, n, a, lda, info ) import sp,dp,qp,ilp,lk @@ -27675,9 +29832,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dtrtrs #endif -#:if WITH_QP - module procedure stdlib_qtrtrs +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$trtrs + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine strtrs( uplo, trans, diag, n, nrhs, a, lda, b, ldb,info ) import sp,dp,qp,ilp,lk @@ -27691,9 +29851,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_strtrs #endif -#:if WITH_QP - module procedure stdlib_wtrtrs +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$trtrs + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine ztrtrs( uplo, trans, diag, n, nrhs, a, lda, b, ldb,info ) import sp,dp,qp,ilp,lk @@ -27740,9 +29903,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dtrttf #endif -#:if WITH_QP - module procedure stdlib_qtrttf +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$trttf + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine strttf( transr, uplo, n, a, lda, arf, info ) import sp,dp,qp,ilp,lk @@ -27756,9 +29922,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_strttf #endif -#:if WITH_QP - module procedure stdlib_wtrttf +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$trttf + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine ztrttf( transr, uplo, n, a, lda, arf, info ) import sp,dp,qp,ilp,lk @@ -27805,9 +29974,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dtrttp #endif -#:if WITH_QP - module procedure stdlib_qtrttp +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$trttp + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine strttp( uplo, n, a, lda, ap, info ) import sp,dp,qp,ilp,lk @@ -27821,9 +29993,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_strttp #endif -#:if WITH_QP - module procedure stdlib_wtrttp +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$trttp + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine ztrttp( uplo, n, a, lda, ap, info ) import sp,dp,qp,ilp,lk @@ -27872,9 +30047,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_dtzrzf #endif -#:if WITH_QP - module procedure stdlib_qtzrzf +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$tzrzf + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine stzrzf( m, n, a, lda, tau, work, lwork, info ) import sp,dp,qp,ilp,lk @@ -27887,9 +30065,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_stzrzf #endif -#:if WITH_QP - module procedure stdlib_wtzrzf +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$tzrzf + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine ztzrzf( m, n, a, lda, tau, work, lwork, info ) import sp,dp,qp,ilp,lk @@ -27940,9 +30121,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_cunbdb #endif -#:if WITH_QP - module procedure stdlib_wunbdb +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$unbdb + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK subroutine zunbdb( trans, signs, m, p, q, x11, ldx11, x12, ldx12,x21, ldx21, x22, & ldx22, theta, phi, taup1,taup2, tauq1, tauq2, work, lwork, info ) @@ -27994,9 +30178,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_cunbdb1 #endif -#:if WITH_QP - module procedure stdlib_wunbdb1 +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$unbdb1 + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK subroutine zunbdb1( m, p, q, x11, ldx11, x21, ldx21, theta, phi,taup1, taup2, & tauq1, work, lwork, info ) @@ -28045,9 +30232,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_cunbdb2 #endif -#:if WITH_QP - module procedure stdlib_wunbdb2 +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$unbdb2 + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK subroutine zunbdb2( m, p, q, x11, ldx11, x21, ldx21, theta, phi,taup1, taup2, & tauq1, work, lwork, info ) @@ -28096,9 +30286,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_cunbdb3 #endif -#:if WITH_QP - module procedure stdlib_wunbdb3 +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$unbdb3 + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK subroutine zunbdb3( m, p, q, x11, ldx11, x21, ldx21, theta, phi,taup1, taup2, & tauq1, work, lwork, info ) @@ -28148,9 +30341,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_cunbdb4 #endif -#:if WITH_QP - module procedure stdlib_wunbdb4 +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$unbdb4 + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK subroutine zunbdb4( m, p, q, x11, ldx11, x21, ldx21, theta, phi,taup1, taup2, & tauq1, phantom, work, lwork,info ) @@ -28196,9 +30392,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_cunbdb5 #endif -#:if WITH_QP - module procedure stdlib_wunbdb5 +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$unbdb5 + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zunbdb5( m1, m2, n, x1, incx1, x2, incx2, q1, ldq1, q2,ldq2, work, & lwork, info ) @@ -28241,9 +30440,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_cunbdb6 #endif -#:if WITH_QP - module procedure stdlib_wunbdb6 +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$unbdb6 + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zunbdb6( m1, m2, n, x1, incx1, x2, incx2, q1, ldq1, q2,ldq2, work, & lwork, info ) @@ -28295,9 +30497,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_cuncsd #endif -#:if WITH_QP - module procedure stdlib_wuncsd +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$uncsd + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK recursive subroutine zuncsd( jobu1, jobu2, jobv1t, jobv2t, trans,signs, m, p, q, & x11, ldx11, x12,ldx12, x21, ldx21, x22, ldx22, theta,u1, ldu1, u2, ldu2, v1t, & @@ -28353,9 +30558,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_cuncsd2by1 #endif -#:if WITH_QP - module procedure stdlib_wuncsd2by1 +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$uncsd2by1 + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK subroutine zuncsd2by1( jobu1, jobu2, jobv1t, m, p, q, x11, ldx11,x21, ldx21, theta,& u1, ldu1, u2, ldu2, v1t,ldv1t, work, lwork, rwork, lrwork, iwork,info ) @@ -28395,9 +30603,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_cung2l #endif -#:if WITH_QP - module procedure stdlib_wung2l +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$ung2l + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zung2l( m, n, k, a, lda, tau, work, info ) import sp,dp,qp,ilp,lk @@ -28434,9 +30645,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_cung2r #endif -#:if WITH_QP - module procedure stdlib_wung2r +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$ung2r + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zung2r( m, n, k, a, lda, tau, work, info ) import sp,dp,qp,ilp,lk @@ -28485,9 +30699,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_cungbr #endif -#:if WITH_QP - module procedure stdlib_wungbr +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$ungbr + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zungbr( vect, m, n, k, a, lda, tau, work, lwork, info ) import sp,dp,qp,ilp,lk @@ -28524,9 +30741,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_cunghr #endif -#:if WITH_QP - module procedure stdlib_wunghr +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$unghr + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zunghr( n, ilo, ihi, a, lda, tau, work, lwork, info ) import sp,dp,qp,ilp,lk @@ -28563,9 +30783,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_cunglq #endif -#:if WITH_QP - module procedure stdlib_wunglq +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$unglq + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zunglq( m, n, k, a, lda, tau, work, lwork, info ) import sp,dp,qp,ilp,lk @@ -28602,9 +30825,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_cungql #endif -#:if WITH_QP - module procedure stdlib_wungql +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$ungql + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zungql( m, n, k, a, lda, tau, work, lwork, info ) import sp,dp,qp,ilp,lk @@ -28641,9 +30867,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_cungqr #endif -#:if WITH_QP - module procedure stdlib_wungqr +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$ungqr + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zungqr( m, n, k, a, lda, tau, work, lwork, info ) import sp,dp,qp,ilp,lk @@ -28680,9 +30909,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_cungrq #endif -#:if WITH_QP - module procedure stdlib_wungrq +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$ungrq + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zungrq( m, n, k, a, lda, tau, work, lwork, info ) import sp,dp,qp,ilp,lk @@ -28720,9 +30952,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_cungtr #endif -#:if WITH_QP - module procedure stdlib_wungtr +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$ungtr + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zungtr( uplo, n, a, lda, tau, work, lwork, info ) import sp,dp,qp,ilp,lk @@ -28760,9 +30995,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_cungtsqr #endif -#:if WITH_QP - module procedure stdlib_wungtsqr +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$ungtsqr + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zungtsqr( m, n, mb, nb, a, lda, t, ldt, work, lwork,info ) import sp,dp,qp,ilp,lk @@ -28810,9 +31048,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_cungtsqr_row #endif -#:if WITH_QP - module procedure stdlib_wungtsqr_row +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$ungtsqr_row + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zungtsqr_row( m, n, mb, nb, a, lda, t, ldt, work,lwork, info ) @@ -28853,9 +31094,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_cunhr_col #endif -#:if WITH_QP - module procedure stdlib_wunhr_col +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$unhr_col + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zunhr_col( m, n, nb, a, lda, t, ldt, d, info ) import sp,dp,qp,ilp,lk @@ -28898,9 +31142,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_cunm2l #endif -#:if WITH_QP - module procedure stdlib_wunm2l +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$unm2l + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zunm2l( side, trans, m, n, k, a, lda, tau, c, ldc,work, info ) @@ -28946,9 +31193,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_cunm2r #endif -#:if WITH_QP - module procedure stdlib_wunm2r +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$unm2r + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zunm2r( side, trans, m, n, k, a, lda, tau, c, ldc,work, info ) @@ -29006,9 +31256,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_cunmbr #endif -#:if WITH_QP - module procedure stdlib_wunmbr +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$unmbr + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zunmbr( vect, side, trans, m, n, k, a, lda, tau, c,ldc, work, & lwork, info ) @@ -29052,9 +31305,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_cunmhr #endif -#:if WITH_QP - module procedure stdlib_wunmhr +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$unmhr + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zunmhr( side, trans, m, n, ilo, ihi, a, lda, tau, c,ldc, work, & lwork, info ) @@ -29099,9 +31355,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_cunmlq #endif -#:if WITH_QP - module procedure stdlib_wunmlq +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$unmlq + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zunmlq( side, trans, m, n, k, a, lda, tau, c, ldc,work, lwork, & info ) @@ -29146,9 +31405,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_cunmql #endif -#:if WITH_QP - module procedure stdlib_wunmql +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$unmql + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zunmql( side, trans, m, n, k, a, lda, tau, c, ldc,work, lwork, & info ) @@ -29193,9 +31455,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_cunmqr #endif -#:if WITH_QP - module procedure stdlib_wunmqr +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$unmqr + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zunmqr( side, trans, m, n, k, a, lda, tau, c, ldc,work, lwork, & info ) @@ -29240,9 +31505,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_cunmrq #endif -#:if WITH_QP - module procedure stdlib_wunmrq +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$unmrq + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zunmrq( side, trans, m, n, k, a, lda, tau, c, ldc,work, lwork, & info ) @@ -29287,9 +31555,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_cunmrz #endif -#:if WITH_QP - module procedure stdlib_wunmrz +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$unmrz + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zunmrz( side, trans, m, n, k, l, a, lda, tau, c, ldc,work, lwork, & info ) @@ -29334,9 +31605,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_cunmtr #endif -#:if WITH_QP - module procedure stdlib_wunmtr +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$unmtr + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zunmtr( side, uplo, trans, m, n, a, lda, tau, c, ldc,work, lwork, & info ) @@ -29375,9 +31649,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_cupgtr #endif -#:if WITH_QP - module procedure stdlib_wupgtr +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$upgtr + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zupgtr( uplo, n, ap, tau, q, ldq, work, info ) import sp,dp,qp,ilp,lk @@ -29421,9 +31698,12 @@ module stdlib_linalg_lapack #else module procedure stdlib_cupmtr #endif -#:if WITH_QP - module procedure stdlib_wupmtr +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$upmtr + #:endif +#:endfor #ifdef STDLIB_EXTERNAL_LAPACK pure subroutine zupmtr( side, uplo, trans, m, n, ap, tau, c, ldc, work,info ) diff --git a/src/stdlib_linalg_lapack_aux.fypp b/src/stdlib_linalg_lapack_aux.fypp index 99b5ca03c..2856e4f74 100644 --- a/src/stdlib_linalg_lapack_aux.fypp +++ b/src/stdlib_linalg_lapack_aux.fypp @@ -1,4 +1,5 @@ #:include "common.fypp" +#:set RC_KINDS_TYPES = REAL_KINDS_TYPES + CMPLX_KINDS_TYPES module stdlib_linalg_lapack_aux use stdlib_linalg_constants use stdlib_linalg_blas @@ -7,140 +8,65 @@ module stdlib_linalg_lapack_aux public :: sp,dp,qp,lk,ilp - public :: stdlib_chla_transtype - public :: stdlib_droundup_lwork - public :: stdlib_icmax1 + public :: stdlib_chla_transtype public :: stdlib_ieeeck - public :: stdlib_ilaclc - public :: stdlib_ilaclr - public :: stdlib_iladiag - public :: stdlib_iladlc - public :: stdlib_iladlr + public :: stdlib_iladiag public :: stdlib_ilaenv public :: stdlib_ilaenv2stage - public :: stdlib_ilaprec - public :: stdlib_ilaslc - public :: stdlib_ilaslr + public :: stdlib_ilaprec public :: stdlib_ilatrans public :: stdlib_ilauplo - public :: stdlib_ilazlc - public :: stdlib_ilazlr public :: stdlib_iparam2stage - public :: stdlib_iparmq - public :: stdlib_izmax1 + public :: stdlib_iparmq public :: stdlib_lsamen - public :: stdlib_sroundup_lwork public :: stdlib_xerbla public :: stdlib_xerbla_array -#:if WITH_QP - public :: stdlib_qroundup_lwork -#:endif -#:if WITH_QP - public :: stdlib_ilaqiag -#:endif -#:if WITH_QP - public :: stdlib_ilaqlc -#:endif -#:if WITH_QP - public :: stdlib_ilaqlr -#:endif -#:if WITH_QP - public :: stdlib_ilawlc -#:endif -#:if WITH_QP - public :: stdlib_ilawlr -#:endif -#:if WITH_QP - public :: stdlib_iwmax1 -#:endif - public :: stdlib_selctg_s - public :: stdlib_select_s - public :: stdlib_selctg_d - public :: stdlib_select_d -#:if WITH_QP - public :: stdlib_selctg_q - public :: stdlib_select_q -#:endif - public :: stdlib_selctg_c - public :: stdlib_select_c - public :: stdlib_selctg_z - public :: stdlib_select_z -#:if WITH_QP - public :: stdlib_selctg_w - public :: stdlib_select_w -#:endif + + #:for rk,rt,ri in RC_KINDS_TYPES + public :: stdlib_ila${ri}$lc + public :: stdlib_ila${ri}$lr + public :: stdlib_select_${ri}$ + public :: stdlib_selctg_${ri}$ + #:endfor + + #:for rk,rt,ri in REAL_KINDS_TYPES + public :: stdlib_${ri}$roundup_lwork + #:endfor + + #:for ck,ct,ci in CMPLX_KINDS_TYPES + public :: stdlib_i${ci}$max1 + #:endfor + ! SELCTG is a LOGICAL FUNCTION of three DOUBLE PRECISION arguments ! used to select eigenvalues to sort to the top left of the Schur form. ! An eigenvalue (ALPHAR(j)+ALPHAI(j))/BETA(j) is selected if SELCTG is true, i.e., abstract interface - pure logical(lk) function stdlib_selctg_s(alphar,alphai,beta) - import sp,dp,qp,lk - implicit none - real(sp), intent(in) :: alphar,alphai,beta - end function stdlib_selctg_s - pure logical(lk) function stdlib_select_s(alphar,alphai) - import sp,dp,qp,lk - implicit none - real(sp), intent(in) :: alphar,alphai - end function stdlib_select_s - pure logical(lk) function stdlib_selctg_d(alphar,alphai,beta) - import sp,dp,qp,lk - implicit none - real(dp), intent(in) :: alphar,alphai,beta - end function stdlib_selctg_d - pure logical(lk) function stdlib_select_d(alphar,alphai) - import sp,dp,qp,lk - implicit none - real(dp), intent(in) :: alphar,alphai - end function stdlib_select_d -#:if WITH_QP - pure logical(lk) function stdlib_selctg_q(alphar,alphai,beta) - import sp,dp,qp,lk - implicit none - real(qp), intent(in) :: alphar,alphai,beta - end function stdlib_selctg_q - pure logical(lk) function stdlib_select_q(alphar,alphai) - import sp,dp,qp,lk - implicit none - real(qp), intent(in) :: alphar,alphai - end function stdlib_select_q -#:endif - pure logical(lk) function stdlib_selctg_c(alpha,beta) - import sp,dp,qp,lk + #:for rk,rt,ri in REAL_KINDS_TYPES + pure logical(lk) function stdlib_selctg_${ri}$(alphar,alphai,beta) + import ${rk}$,lk implicit none - complex(sp), intent(in) :: alpha,beta - end function stdlib_selctg_c - pure logical(lk) function stdlib_select_c(alpha) - import sp,dp,qp,lk + real(${rk}$), intent(in) :: alphar,alphai,beta + end function stdlib_selctg_${ri}$ + pure logical(lk) function stdlib_select_${ri}$(alphar,alphai) + import ${rk}$,lk implicit none - complex(sp), intent(in) :: alpha - end function stdlib_select_c - pure logical(lk) function stdlib_selctg_z(alpha,beta) - import sp,dp,qp,lk + real(${rk}$), intent(in) :: alphar,alphai + end function stdlib_select_${ri}$ + #:endfor + #:for ck,ct,ci in CMPLX_KINDS_TYPES + pure logical(lk) function stdlib_selctg_${ci}$(alpha,beta) + import ${ck}$,lk implicit none - complex(dp), intent(in) :: alpha,beta - end function stdlib_selctg_z - pure logical(lk) function stdlib_select_z(alpha) - import sp,dp,qp,lk + complex(${ck}$), intent(in) :: alpha,beta + end function stdlib_selctg_${ci}$ + pure logical(lk) function stdlib_select_${ci}$(alpha) + import ${ck}$,lk implicit none - complex(dp), intent(in) :: alpha - end function stdlib_select_z -#:if WITH_QP - pure logical(lk) function stdlib_selctg_w(alpha,beta) - import sp,dp,qp,lk - implicit none - complex(qp), intent(in) :: alpha,beta - end function stdlib_selctg_w - pure logical(lk) function stdlib_select_w(alpha) - import sp,dp,qp,lk - implicit none - complex(qp), intent(in) :: alpha - end function stdlib_select_w -#:endif + complex(${ck}$), intent(in) :: alpha + end function stdlib_select_${ci}$ + #:endfor end interface - - contains @@ -175,78 +101,7 @@ module stdlib_linalg_lapack_aux return end function stdlib_chla_transtype - - pure real(dp) function stdlib_droundup_lwork( lwork ) - !! DROUNDUP_LWORK >= LWORK. - !! DROUNDUP_LWORK is guaranteed to have zero decimal part. - ! -- lapack auxiliary routine -- - ! -- lapack is a software package provided by univ. of tennessee, -- - ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- - ! Scalar Arguments - integer(ilp), intent(in) :: lwork - ! ===================================================================== - ! Intrinsic Functions - intrinsic :: epsilon,real,int - ! Executable Statements - stdlib_droundup_lwork = real( lwork,KIND=dp) - if( int( stdlib_droundup_lwork,KIND=ilp) < lwork ) then - ! force round up of lwork - stdlib_droundup_lwork = stdlib_droundup_lwork * ( 1.0e+0_dp + epsilon(0.0e+0_dp) ) - - endif - return - end function stdlib_droundup_lwork - - - pure integer(ilp) function stdlib_icmax1( n, cx, incx ) - !! ICMAX1 finds the index of the first vector element of maximum absolute value. - !! Based on ICAMAX from Level 1 BLAS. - !! The change is to use the 'genuine' absolute value. - ! -- lapack auxiliary routine -- - ! -- lapack is a software package provided by univ. of tennessee, -- - ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- - ! Scalar Arguments - integer(ilp), intent(in) :: incx, n - ! Array Arguments - complex(sp), intent(in) :: cx(*) - ! ===================================================================== - ! Local Scalars - real(sp) :: smax - integer(ilp) :: i, ix - ! Intrinsic Functions - intrinsic :: abs - ! Executable Statements - stdlib_icmax1 = 0 - if (n<1 .or. incx<=0) return - stdlib_icmax1 = 1 - if (n==1) return - if (incx==1) then - ! code for increment equal to 1 - smax = abs(cx(1)) - do i = 2,n - if (abs(cx(i))>smax) then - stdlib_icmax1 = i - smax = abs(cx(i)) - end if - end do - else - ! code for increment not equal to 1 - ix = 1 - smax = abs(cx(1)) - ix = ix + incx - do i = 2,n - if (abs(cx(ix))>smax) then - stdlib_icmax1 = i - smax = abs(cx(ix)) - end if - ix = ix + incx - end do - end if - return - end function stdlib_icmax1 - - - pure integer(ilp) function stdlib_ieeeck( ispec, zero, one ) + pure integer(ilp) function stdlib_ieeeck( ispec, zero, one ) !! IEEECK is called from the ILAENV to verify that Infinity and !! possibly NaN arithmetic is safe (i.e. will not trap). ! -- lapack auxiliary routine -- @@ -336,73 +191,6 @@ module stdlib_linalg_lapack_aux end function stdlib_ieeeck - pure integer(ilp) function stdlib_ilaclc( m, n, a, lda ) - !! ILACLC scans A for its last non-zero column. - ! -- lapack auxiliary routine -- - ! -- lapack is a software package provided by univ. of tennessee, -- - ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- - ! Scalar Arguments - integer(ilp), intent(in) :: m, n, lda - ! Array Arguments - complex(sp), intent(in) :: a(lda,*) - ! ===================================================================== - ! Parameters - complex(sp), parameter :: zero = (0.0e+0,0.0e+0) - - ! Local Scalars - integer(ilp) :: i - ! Executable Statements - ! quick test for the common case where one corner is non-zero. - if( n==0 ) then - stdlib_ilaclc = n - else if( a(1, n)/=zero .or. a(m, n)/=zero ) then - stdlib_ilaclc = n - else - ! now scan each column from the end, returning with the first non-zero. - do stdlib_ilaclc = n, 1, -1 - do i = 1, m - if( a(i, stdlib_ilaclc)/=zero ) return - end do - end do - end if - return - end function stdlib_ilaclc - - - pure integer(ilp) function stdlib_ilaclr( m, n, a, lda ) - !! ILACLR scans A for its last non-zero row. - ! -- lapack auxiliary routine -- - ! -- lapack is a software package provided by univ. of tennessee, -- - ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- - ! Scalar Arguments - integer(ilp), intent(in) :: m, n, lda - ! Array Arguments - complex(sp), intent(in) :: a(lda,*) - ! ===================================================================== - ! Parameters - complex(sp), parameter :: zero = (0.0e+0,0.0e+0) - - ! Local Scalars - integer(ilp) :: i, j - ! Executable Statements - ! quick test for the common case where one corner is non-zero. - if( m==0 ) then - stdlib_ilaclr = m - else if( a(m, 1)/=zero .or. a(m, n)/=zero ) then - stdlib_ilaclr = m - else - ! scan up each column tracking the last zero row seen. - stdlib_ilaclr = 0 - do j = 1, n - i=m - do while((a(max(i,1),j)==zero).and.(i>=1)) - i=i-1 - enddo - stdlib_ilaclr = max( stdlib_ilaclr, i ) - end do - end if - return - end function stdlib_ilaclr integer(ilp) function stdlib_iladiag( diag ) @@ -434,73 +222,6 @@ module stdlib_linalg_lapack_aux end function stdlib_iladiag - pure integer(ilp) function stdlib_iladlc( m, n, a, lda ) - !! ILADLC scans A for its last non-zero column. - ! -- lapack auxiliary routine -- - ! -- lapack is a software package provided by univ. of tennessee, -- - ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- - ! Scalar Arguments - integer(ilp), intent(in) :: m, n, lda - ! Array Arguments - real(dp), intent(in) :: a(lda,*) - ! ===================================================================== - ! Parameters - real(dp), parameter :: zero = 0.0d+0 - - ! Local Scalars - integer(ilp) :: i - ! Executable Statements - ! quick test for the common case where one corner is non-zero. - if( n==0 ) then - stdlib_iladlc = n - else if( a(1, n)/=zero .or. a(m, n)/=zero ) then - stdlib_iladlc = n - else - ! now scan each column from the end, returning with the first non-zero. - do stdlib_iladlc = n, 1, -1 - do i = 1, m - if( a(i, stdlib_iladlc)/=zero ) return - end do - end do - end if - return - end function stdlib_iladlc - - - pure integer(ilp) function stdlib_iladlr( m, n, a, lda ) - !! ILADLR scans A for its last non-zero row. - ! -- lapack auxiliary routine -- - ! -- lapack is a software package provided by univ. of tennessee, -- - ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- - ! Scalar Arguments - integer(ilp), intent(in) :: m, n, lda - ! Array Arguments - real(dp), intent(in) :: a(lda,*) - ! ===================================================================== - ! Parameters - real(dp), parameter :: zero = 0.0d+0 - - ! Local Scalars - integer(ilp) :: i, j - ! Executable Statements - ! quick test for the common case where one corner is non-zero. - if( m==0 ) then - stdlib_iladlr = m - else if( a(m, 1)/=zero .or. a(m, n)/=zero ) then - stdlib_iladlr = m - else - ! scan up each column tracking the last zero row seen. - stdlib_iladlr = 0 - do j = 1, n - i=m - do while((a(max(i,1),j)==zero).and.(i>=1)) - i=i-1 - enddo - stdlib_iladlr = max( stdlib_iladlr, i ) - end do - end if - return - end function stdlib_iladlr integer(ilp) function stdlib_ilaprec( prec ) @@ -538,74 +259,6 @@ module stdlib_linalg_lapack_aux end function stdlib_ilaprec - pure integer(ilp) function stdlib_ilaslc( m, n, a, lda ) - !! ILASLC scans A for its last non-zero column. - ! -- lapack auxiliary routine -- - ! -- lapack is a software package provided by univ. of tennessee, -- - ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- - ! Scalar Arguments - integer(ilp), intent(in) :: m, n, lda - ! Array Arguments - real(sp), intent(in) :: a(lda,*) - ! ===================================================================== - ! Parameters - real(sp), parameter :: zero = 0.0e+0 - - ! Local Scalars - integer(ilp) :: i - ! Executable Statements - ! quick test for the common case where one corner is non-zero. - if( n==0 ) then - stdlib_ilaslc = n - else if( a(1, n)/=zero .or. a(m, n)/=zero ) then - stdlib_ilaslc = n - else - ! now scan each column from the end, returning with the first non-zero. - do stdlib_ilaslc = n, 1, -1 - do i = 1, m - if( a(i, stdlib_ilaslc)/=zero ) return - end do - end do - end if - return - end function stdlib_ilaslc - - - pure integer(ilp) function stdlib_ilaslr( m, n, a, lda ) - !! ILASLR scans A for its last non-zero row. - ! -- lapack auxiliary routine -- - ! -- lapack is a software package provided by univ. of tennessee, -- - ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- - ! Scalar Arguments - integer(ilp), intent(in) :: m, n, lda - ! Array Arguments - real(sp), intent(in) :: a(lda,*) - ! ===================================================================== - ! Parameters - real(sp), parameter :: zero = 0.0e+0 - - ! Local Scalars - integer(ilp) :: i, j - ! Executable Statements - ! quick test for the common case where one corner is non-zero. - if( m==0 ) then - stdlib_ilaslr = m - elseif( a(m, 1)/=zero .or. a(m, n)/=zero ) then - stdlib_ilaslr = m - else - ! scan up each column tracking the last zero row seen. - stdlib_ilaslr = 0 - do j = 1, n - i=m - do while((a(max(i,1),j)==zero).and.(i>=1)) - i=i-1 - enddo - stdlib_ilaslr = max( stdlib_ilaslr, i ) - end do - end if - return - end function stdlib_ilaslr - integer(ilp) function stdlib_ilatrans( trans ) !! This subroutine translates from a character string specifying a @@ -668,75 +321,6 @@ module stdlib_linalg_lapack_aux end function stdlib_ilauplo - pure integer(ilp) function stdlib_ilazlc( m, n, a, lda ) - !! ILAZLC scans A for its last non-zero column. - ! -- lapack auxiliary routine -- - ! -- lapack is a software package provided by univ. of tennessee, -- - ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- - ! Scalar Arguments - integer(ilp), intent(in) :: m, n, lda - ! Array Arguments - complex(dp), intent(in) :: a(lda,*) - ! ===================================================================== - ! Parameters - complex(dp), parameter :: zero = (0.0d+0,0.0d+0) - - ! Local Scalars - integer(ilp) :: i - ! Executable Statements - ! quick test for the common case where one corner is non-zero. - if( n==0 ) then - stdlib_ilazlc = n - else if( a(1, n)/=zero .or. a(m, n)/=zero ) then - stdlib_ilazlc = n - else - ! now scan each column from the end, returning with the first non-zero. - do stdlib_ilazlc = n, 1, -1 - do i = 1, m - if( a(i, stdlib_ilazlc)/=zero ) return - end do - end do - end if - return - end function stdlib_ilazlc - - - pure integer(ilp) function stdlib_ilazlr( m, n, a, lda ) - !! ILAZLR scans A for its last non-zero row. - ! -- lapack auxiliary routine -- - ! -- lapack is a software package provided by univ. of tennessee, -- - ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- - ! Scalar Arguments - integer(ilp), intent(in) :: m, n, lda - ! Array Arguments - complex(dp), intent(in) :: a(lda,*) - ! ===================================================================== - ! Parameters - complex(dp), parameter :: zero = (0.0d+0,0.0d+0) - - ! Local Scalars - integer(ilp) :: i, j - ! Executable Statements - ! quick test for the common case where one corner is non-zero. - if( m==0 ) then - stdlib_ilazlr = m - else if( a(m, 1)/=zero .or. a(m, n)/=zero ) then - stdlib_ilazlr = m - else - ! scan up each column tracking the last zero row seen. - stdlib_ilazlr = 0 - do j = 1, n - i=m - do while((a(max(i,1),j)==zero).and.(i>=1)) - i=i-1 - enddo - stdlib_ilazlr = max( stdlib_ilazlr, i ) - end do - end if - return - end function stdlib_ilazlr - - pure integer(ilp) function stdlib_iparmq( ispec, name, opts, n, ilo, ihi, lwork ) !! This program sets problem and machine dependent parameters !! useful for xHSEQR and related subroutines for eigenvalue @@ -868,56 +452,7 @@ module stdlib_linalg_lapack_aux end if end function stdlib_iparmq - - pure integer(ilp) function stdlib_izmax1( n, zx, incx ) - !! IZMAX1 finds the index of the first vector element of maximum absolute value. - !! Based on IZAMAX from Level 1 BLAS. - !! The change is to use the 'genuine' absolute value. - ! -- lapack auxiliary routine -- - ! -- lapack is a software package provided by univ. of tennessee, -- - ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- - ! Scalar Arguments - integer(ilp), intent(in) :: incx, n - ! Array Arguments - complex(dp), intent(in) :: zx(*) - ! ===================================================================== - ! Local Scalars - real(dp) :: dmax - integer(ilp) :: i, ix - ! Intrinsic Functions - intrinsic :: abs - ! Executable Statements - stdlib_izmax1 = 0 - if (n<1 .or. incx<=0) return - stdlib_izmax1 = 1 - if (n==1) return - if (incx==1) then - ! code for increment equal to 1 - dmax = abs(zx(1)) - do i = 2,n - if (abs(zx(i))>dmax) then - stdlib_izmax1 = i - dmax = abs(zx(i)) - end if - end do - else - ! code for increment not equal to 1 - ix = 1 - dmax = abs(zx(1)) - ix = ix + incx - do i = 2,n - if (abs(zx(ix))>dmax) then - stdlib_izmax1 = i - dmax = abs(zx(ix)) - end if - ix = ix + incx - end do - end if - return - end function stdlib_izmax1 - - - pure logical(lk) function stdlib_lsamen( n, ca, cb ) + pure logical(lk) function stdlib_lsamen( n, ca, cb ) !! LSAMEN tests if the first N letters of CA are the same as the !! first N letters of CB, regardless of case. !! LSAMEN returns .TRUE. if CA and CB are equivalent except for case @@ -947,10 +482,10 @@ module stdlib_linalg_lapack_aux return end function stdlib_lsamen - - pure real(sp) function stdlib_sroundup_lwork( lwork ) - !! SROUNDUP_LWORK >= LWORK. - !! SROUNDUP_LWORK is guaranteed to have zero decimal part. +#:for rk,rt,ri in REAL_KINDS_TYPES + pure real(${rk}$) function stdlib_${ri}$roundup_lwork( lwork ) + !! ROUNDUP_LWORK >= LWORK. + !! ROUNDUP_LWORK is guaranteed to have zero decimal part. ! -- lapack auxiliary routine -- ! -- lapack is a software package provided by univ. of tennessee, -- ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- @@ -960,76 +495,18 @@ module stdlib_linalg_lapack_aux ! Intrinsic Functions intrinsic :: epsilon,real,int ! Executable Statements - stdlib_sroundup_lwork = real( lwork,KIND=sp) - if( int( stdlib_sroundup_lwork,KIND=ilp) < lwork ) then + stdlib_${ri}$roundup_lwork = real(lwork,KIND=${rk}$) + if (int( stdlib_${ri}$roundup_lwork,KIND=ilp)= LWORK. - !! DROUNDUP_LWORK is guaranteed to have zero decimal part. - ! -- lapack auxiliary routine -- - ! -- lapack is a software package provided by univ. of tennessee, -- - ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- - ! Scalar Arguments - integer(ilp), intent(in) :: lwork - ! ===================================================================== - ! Intrinsic Functions - intrinsic :: epsilon,real,int - ! Executable Statements - stdlib_qroundup_lwork = real( lwork,KIND=qp) - if( int( stdlib_qroundup_lwork,KIND=ilp) < lwork ) then - ! force round up of lwork - stdlib_qroundup_lwork = stdlib_qroundup_lwork * ( 1.0e+0_qp + epsilon(0.0e+0_qp) ) - - endif - return - end function stdlib_qroundup_lwork -#:endif - -#:if WITH_QP - - - integer(ilp) function stdlib_ilaqiag( diag ) - !! This subroutine translated from a character string specifying if a - !! matrix has unit diagonal or not to the relevant BLAST-specified - !! integer constant. - !! ILADIAG: returns an INTEGER. If ILADIAG: < 0, then the input is not a - !! character indicating a unit or non-unit diagonal. Otherwise ILADIAG - !! returns the constant value corresponding to DIAG. - ! -- lapack computational routine -- - ! -- lapack is a software package provided by univ. of tennessee, -- - ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- - ! Scalar Arguments - character :: diag - ! ===================================================================== - ! Parameters - integer(ilp), parameter :: blas_non_unit_qiag = 131 - integer(ilp), parameter :: blas_unit_qiag = 132 - - ! Executable Statements - if( stdlib_lsame( diag, 'N' ) ) then - stdlib_ilaqiag = blas_non_unit_qiag - else if( stdlib_lsame( diag, 'U' ) ) then - stdlib_ilaqiag = blas_unit_qiag - else - stdlib_ilaqiag = -1 - end if - return - end function stdlib_ilaqiag -#:endif - -#:if WITH_QP - - - pure integer(ilp) function stdlib_ilaqlc( m, n, a, lda ) +#:for rk,rt,ri in RC_KINDS_TYPES + pure integer(ilp) function stdlib_ila${ri}$lc( m, n, a, lda ) !! ILADLC: scans A for its last non-zero column. ! -- lapack auxiliary routine -- ! -- lapack is a software package provided by univ. of tennessee, -- @@ -1037,35 +514,31 @@ module stdlib_linalg_lapack_aux ! Scalar Arguments integer(ilp), intent(in) :: m, n, lda ! Array Arguments - real(qp), intent(in) :: a(lda,*) + ${rt}$, intent(in) :: a(lda,*) ! ===================================================================== ! Parameters - real(qp), parameter :: zero = 0.0d+0 + ${rt}$, parameter :: zero = 0.0_${rk}$ ! Local Scalars integer(ilp) :: i ! Executable Statements ! quick test for the common case where one corner is non-zero. if( n==0 ) then - stdlib_ilaqlc = n - else if( a(1, n)/=zero .or. a(m, n)/=zero ) then - stdlib_ilaqlc = n + stdlib_ila${ri}$lc = n + else if (a(1, n)/=zero .or. a(m, n)/=zero) then + stdlib_ila${ri}$lc = n else ! now scan each column from the end, returning with the first non-zero. - do stdlib_ilaqlc = n, 1, -1 + do stdlib_ila${ri}$lc = n, 1, -1 do i = 1, m - if( a(i, stdlib_ilaqlc)/=zero ) return + if (a(i, stdlib_ila${ri}$lc)/=zero) return end do end do end if return - end function stdlib_ilaqlc -#:endif - -#:if WITH_QP - - - pure integer(ilp) function stdlib_ilaqlr( m, n, a, lda ) + end function stdlib_ila${ri}$lc + + pure integer(ilp) function stdlib_ila${ri}$lr( m, n, a, lda ) !! ILADLR: scans A for its last non-zero row. ! -- lapack auxiliary routine -- ! -- lapack is a software package provided by univ. of tennessee, -- @@ -1073,115 +546,39 @@ module stdlib_linalg_lapack_aux ! Scalar Arguments integer(ilp), intent(in) :: m, n, lda ! Array Arguments - real(qp), intent(in) :: a(lda,*) + ${rt}$, intent(in) :: a(lda,*) ! ===================================================================== ! Parameters - real(qp), parameter :: zero = 0.0d+0 + ${rt}$, parameter :: zero = 0.0_${rk}$ ! Local Scalars integer(ilp) :: i, j ! Executable Statements ! quick test for the common case where one corner is non-zero. if( m==0 ) then - stdlib_ilaqlr = m + stdlib_ila${ri}$lr = m else if( a(m, 1)/=zero .or. a(m, n)/=zero ) then - stdlib_ilaqlr = m + stdlib_ila${ri}$lr = m else ! scan up each column tracking the last zero row seen. - stdlib_ilaqlr = 0 + stdlib_ila${ri}$lr = 0 do j = 1, n i=m do while((a(max(i,1),j)==zero).and.(i>=1)) i=i-1 enddo - stdlib_ilaqlr = max( stdlib_ilaqlr, i ) + stdlib_ila${ri}$lr = max( stdlib_ila${ri}$lr, i ) end do end if return - end function stdlib_ilaqlr -#:endif - -#:if WITH_QP - - - pure integer(ilp) function stdlib_ilawlc( m, n, a, lda ) - !! ILAZLC: scans A for its last non-zero column. - ! -- lapack auxiliary routine -- - ! -- lapack is a software package provided by univ. of tennessee, -- - ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- - ! Scalar Arguments - integer(ilp), intent(in) :: m, n, lda - ! Array Arguments - complex(qp), intent(in) :: a(lda,*) - ! ===================================================================== - ! Parameters - complex(qp), parameter :: zero = (0.0d+0,0.0d+0) - - ! Local Scalars - integer(ilp) :: i - ! Executable Statements - ! quick test for the common case where one corner is non-zero. - if( n==0 ) then - stdlib_ilawlc = n - else if( a(1, n)/=zero .or. a(m, n)/=zero ) then - stdlib_ilawlc = n - else - ! now scan each column from the end, returning with the first non-zero. - do stdlib_ilawlc = n, 1, -1 - do i = 1, m - if( a(i, stdlib_ilawlc)/=zero ) return - end do - end do - end if - return - end function stdlib_ilawlc -#:endif - -#:if WITH_QP - - - pure integer(ilp) function stdlib_ilawlr( m, n, a, lda ) - !! ILAZLR: scans A for its last non-zero row. - ! -- lapack auxiliary routine -- - ! -- lapack is a software package provided by univ. of tennessee, -- - ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- - ! Scalar Arguments - integer(ilp), intent(in) :: m, n, lda - ! Array Arguments - complex(qp), intent(in) :: a(lda,*) - ! ===================================================================== - ! Parameters - complex(qp), parameter :: zero = (0.0d+0,0.0d+0) - - ! Local Scalars - integer(ilp) :: i, j - ! Executable Statements - ! quick test for the common case where one corner is non-zero. - if( m==0 ) then - stdlib_ilawlr = m - else if( a(m, 1)/=zero .or. a(m, n)/=zero ) then - stdlib_ilawlr = m - else - ! scan up each column tracking the last zero row seen. - stdlib_ilawlr = 0 - do j = 1, n - i=m - do while((a(max(i,1),j)==zero).and.(i>=1)) - i=i-1 - enddo - stdlib_ilawlr = max( stdlib_ilawlr, i ) - end do - end if - return - end function stdlib_ilawlr -#:endif - -#:if WITH_QP - - - pure integer(ilp) function stdlib_iwmax1( n, zx, incx ) - !! IZMAX1: finds the index of the first vector element of maximum absolute value. - !! Based on IZAMAX from Level 1 BLAS. + end function stdlib_ila${ri}$lr + +#:endfor + +#:for ck,ct,ci in CMPLX_KINDS_TYPES + pure integer(ilp) function stdlib_i${ci}$max1( n, zx, incx ) + !! I*MAX1: finds the index of the first vector element of maximum absolute value. + !! Based on I*AMAX from Level 1 BLAS. !! The change is to use the 'genuine' absolute value. ! -- lapack auxiliary routine -- ! -- lapack is a software package provided by univ. of tennessee, -- @@ -1189,24 +586,24 @@ module stdlib_linalg_lapack_aux ! Scalar Arguments integer(ilp), intent(in) :: incx, n ! Array Arguments - complex(qp), intent(in) :: zx(*) + complex(${ck}$), intent(in) :: zx(*) ! ===================================================================== ! Local Scalars - real(qp) :: dmax + real(${ck}$) :: dmax integer(ilp) :: i, ix ! Intrinsic Functions intrinsic :: abs ! Executable Statements - stdlib_iwmax1 = 0 + stdlib_i${ci}$max1 = 0 if (n<1 .or. incx<=0) return - stdlib_iwmax1 = 1 + stdlib_i${ci}$max1 = 1 if (n==1) return if (incx==1) then ! code for increment equal to 1 dmax = abs(zx(1)) do i = 2,n if (abs(zx(i))>dmax) then - stdlib_iwmax1 = i + stdlib_i${ci}$max1 = i dmax = abs(zx(i)) end if end do @@ -1217,15 +614,15 @@ module stdlib_linalg_lapack_aux ix = ix + incx do i = 2,n if (abs(zx(ix))>dmax) then - stdlib_iwmax1 = i + stdlib_i${ci}$max1 = i dmax = abs(zx(ix)) end if ix = ix + incx end do end if return - end function stdlib_iwmax1 -#:endif + end function stdlib_i${ci}$max1 +#:endfor pure integer(ilp) function stdlib_ilaenv( ispec, name, opts, n1, n2, n3, n4 ) diff --git a/src/stdlib_linalg_lapack_d.fypp b/src/stdlib_linalg_lapack_d.fypp index f5e6b1985..a5cdbe225 100644 --- a/src/stdlib_linalg_lapack_d.fypp +++ b/src/stdlib_linalg_lapack_d.fypp @@ -478,9 +478,6 @@ module stdlib_linalg_lapack_d public :: stdlib_dtrttp public :: stdlib_dtzrzf public :: stdlib_dzsum1 -#:if WITH_QP - public :: stdlib_dlag2q -#:endif ! 64-bit real constants real(dp), parameter, private :: negone = -1.00_dp @@ -24146,38 +24143,6 @@ module stdlib_linalg_lapack_d return end function stdlib_dzsum1 -#:if WITH_QP - - pure subroutine stdlib_dlag2q( m, n, sa, ldsa, a, lda, info ) - !! DLAG2Q converts a SINGLE PRECISION matrix, SA, to a DOUBLE - !! PRECISION matrix, A. - !! Note that while it is possible to overflow while converting - !! from double to single, it is not possible to overflow when - !! converting from single to double. - !! This is an auxiliary routine so there is no argument checking. - ! -- lapack auxiliary routine -- - ! -- lapack is a software package provided by univ. of tennessee, -- - ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- - ! Scalar Arguments - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda, ldsa, m, n - ! Array Arguments - real(dp), intent(in) :: sa(ldsa,*) - real(qp), intent(out) :: a(lda,*) - ! ===================================================================== - ! Local Scalars - integer(ilp) :: i, j - ! Executable Statements - info = 0 - do j = 1, n - do i = 1, m - a( i, j ) = sa( i, j ) - end do - end do - return - end subroutine stdlib_dlag2q -#:endif - pure subroutine stdlib_dbbcsd( jobu1, jobu2, jobv1t, jobv2t, trans, m, p, q,theta, phi, u1, & !! DBBCSD computes the CS decomposition of an orthogonal matrix in !! bidiagonal-block form, diff --git a/src/stdlib_linalg_lapack_q.fypp b/src/stdlib_linalg_lapack_q.fypp index fb9d0c137..2b820687a 100644 --- a/src/stdlib_linalg_lapack_q.fypp +++ b/src/stdlib_linalg_lapack_q.fypp @@ -1,6 +1,7 @@ #:include "common.fypp" -#:if WITH_QP -module stdlib_linalg_lapack_q +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] +module stdlib_linalg_lapack_${ri}$ use stdlib_linalg_constants use stdlib_linalg_blas use stdlib_linalg_lapack_aux @@ -12,519 +13,519 @@ module stdlib_linalg_lapack_q private - public :: sp,dp,qp,lk,ilp - public :: stdlib_qbbcsd - public :: stdlib_qbdsdc - public :: stdlib_qbdsqr - public :: stdlib_qdisna - public :: stdlib_qgbbrd - public :: stdlib_qgbcon - public :: stdlib_qgbequ - public :: stdlib_qgbequb - public :: stdlib_qgbrfs - public :: stdlib_qgbsv - public :: stdlib_qgbsvx - public :: stdlib_qgbtf2 - public :: stdlib_qgbtrf - public :: stdlib_qgbtrs - public :: stdlib_qgebak - public :: stdlib_qgebal - public :: stdlib_qgebd2 - public :: stdlib_qgebrd - public :: stdlib_qgecon - public :: stdlib_qgeequ - public :: stdlib_qgeequb - public :: stdlib_qgees - public :: stdlib_qgeesx - public :: stdlib_qgeev - public :: stdlib_qgeevx - public :: stdlib_qgehd2 - public :: stdlib_qgehrd - public :: stdlib_qgejsv - public :: stdlib_qgelq - public :: stdlib_qgelq2 - public :: stdlib_qgelqf - public :: stdlib_qgelqt - public :: stdlib_qgelqt3 - public :: stdlib_qgels - public :: stdlib_qgelsd - public :: stdlib_qgelss - public :: stdlib_qgelsy - public :: stdlib_qgemlq - public :: stdlib_qgemlqt - public :: stdlib_qgemqr - public :: stdlib_qgemqrt - public :: stdlib_qgeql2 - public :: stdlib_qgeqlf - public :: stdlib_qgeqp3 - public :: stdlib_qgeqr - public :: stdlib_qgeqr2 - public :: stdlib_qgeqr2p - public :: stdlib_qgeqrf - public :: stdlib_qgeqrfp - public :: stdlib_qgeqrt - public :: stdlib_qgeqrt2 - public :: stdlib_qgeqrt3 - public :: stdlib_qgerfs - public :: stdlib_qgerq2 - public :: stdlib_qgerqf - public :: stdlib_qgesc2 - public :: stdlib_qgesdd - public :: stdlib_qgesv - public :: stdlib_qgesvd - public :: stdlib_qgesvdq - public :: stdlib_qgesvj - public :: stdlib_qgesvx - public :: stdlib_qgetc2 - public :: stdlib_qgetf2 - public :: stdlib_qgetrf - public :: stdlib_qgetrf2 - public :: stdlib_qgetri - public :: stdlib_qgetrs - public :: stdlib_qgetsls - public :: stdlib_qgetsqrhrt - public :: stdlib_qggbak - public :: stdlib_qggbal - public :: stdlib_qgges - public :: stdlib_qgges3 - public :: stdlib_qggesx - public :: stdlib_qggev - public :: stdlib_qggev3 - public :: stdlib_qggevx - public :: stdlib_qggglm - public :: stdlib_qgghd3 - public :: stdlib_qgghrd - public :: stdlib_qgglse - public :: stdlib_qggqrf - public :: stdlib_qggrqf - public :: stdlib_qgsvj0 - public :: stdlib_qgsvj1 - public :: stdlib_qgtcon - public :: stdlib_qgtrfs - public :: stdlib_qgtsv - public :: stdlib_qgtsvx - public :: stdlib_qgttrf - public :: stdlib_qgttrs - public :: stdlib_qgtts2 - public :: stdlib_qhgeqz - public :: stdlib_qhsein - public :: stdlib_qhseqr - public :: stdlib_qisnan - public :: stdlib_qla_gbamv - public :: stdlib_qla_gbrcond - public :: stdlib_qla_gbrpvgrw - public :: stdlib_qla_geamv - public :: stdlib_qla_gercond - public :: stdlib_qla_gerpvgrw - public :: stdlib_qla_lin_berr - public :: stdlib_qla_porcond - public :: stdlib_qla_porpvgrw - public :: stdlib_qla_syamv - public :: stdlib_qla_syrcond - public :: stdlib_qla_syrpvgrw - public :: stdlib_qla_wwaddw - public :: stdlib_qlabad - public :: stdlib_qlabrd - public :: stdlib_qlacn2 - public :: stdlib_qlacon - public :: stdlib_qlacpy - public :: stdlib_qladiv - public :: stdlib_qladiv1 - public :: stdlib_qladiv2 - public :: stdlib_qlae2 - public :: stdlib_qlaebz - public :: stdlib_qlaed0 - public :: stdlib_qlaed1 - public :: stdlib_qlaed2 - public :: stdlib_qlaed3 - public :: stdlib_qlaed4 - public :: stdlib_qlaed5 - public :: stdlib_qlaed6 - public :: stdlib_qlaed7 - public :: stdlib_qlaed8 - public :: stdlib_qlaed9 - public :: stdlib_qlaeda - public :: stdlib_qlaein - public :: stdlib_qlaev2 - public :: stdlib_qlaexc - public :: stdlib_qlag2 - public :: stdlib_qlag2s - public :: stdlib_qlags2 - public :: stdlib_qlagtf - public :: stdlib_qlagtm - public :: stdlib_qlagts - public :: stdlib_qlagv2 - public :: stdlib_qlahqr - public :: stdlib_qlahr2 - public :: stdlib_qlaic1 - public :: stdlib_qlaisnan - public :: stdlib_qlaln2 - public :: stdlib_qlals0 - public :: stdlib_qlalsa - public :: stdlib_qlalsd - public :: stdlib_qlamch - public :: stdlib_qlamc3 - public :: stdlib_qlamrg - public :: stdlib_qlamswlq - public :: stdlib_qlamtsqr - public :: stdlib_qlaneg - public :: stdlib_qlangb - public :: stdlib_qlange - public :: stdlib_qlangt - public :: stdlib_qlanhs - public :: stdlib_qlansb - public :: stdlib_qlansf - public :: stdlib_qlansp - public :: stdlib_qlanst - public :: stdlib_qlansy - public :: stdlib_qlantb - public :: stdlib_qlantp - public :: stdlib_qlantr - public :: stdlib_qlanv2 - public :: stdlib_qlaorhr_col_getrfnp - public :: stdlib_qlaorhr_col_getrfnp2 - public :: stdlib_qlapll - public :: stdlib_qlapmr - public :: stdlib_qlapmt - public :: stdlib_qlapy2 - public :: stdlib_qlapy3 - public :: stdlib_qlaqgb - public :: stdlib_qlaqge - public :: stdlib_qlaqp2 - public :: stdlib_qlaqps - public :: stdlib_qlaqr0 - public :: stdlib_qlaqr1 - public :: stdlib_qlaqr2 - public :: stdlib_qlaqr3 - public :: stdlib_qlaqr4 - public :: stdlib_qlaqr5 - public :: stdlib_qlaqsb - public :: stdlib_qlaqsp - public :: stdlib_qlaqsy - public :: stdlib_qlaqtr - public :: stdlib_qlaqz0 - public :: stdlib_qlaqz1 - public :: stdlib_qlaqz2 - public :: stdlib_qlaqz3 - public :: stdlib_qlaqz4 - public :: stdlib_qlar1v - public :: stdlib_qlar2v - public :: stdlib_qlarf - public :: stdlib_qlarfb - public :: stdlib_qlarfb_gett - public :: stdlib_qlarfg - public :: stdlib_qlarfgp - public :: stdlib_qlarft - public :: stdlib_qlarfx - public :: stdlib_qlarfy - public :: stdlib_qlargv - public :: stdlib_qlarnv - public :: stdlib_qlarra - public :: stdlib_qlarrb - public :: stdlib_qlarrc - public :: stdlib_qlarrd - public :: stdlib_qlarre - public :: stdlib_qlarrf - public :: stdlib_qlarrj - public :: stdlib_qlarrk - public :: stdlib_qlarrr - public :: stdlib_qlarrv - public :: stdlib_qlartg - public :: stdlib_qlartgp - public :: stdlib_qlartgs - public :: stdlib_qlartv - public :: stdlib_qlaruv - public :: stdlib_qlarz - public :: stdlib_qlarzb - public :: stdlib_qlarzt - public :: stdlib_qlas2 - public :: stdlib_qlascl - public :: stdlib_qlasd0 - public :: stdlib_qlasd1 - public :: stdlib_qlasd2 - public :: stdlib_qlasd3 - public :: stdlib_qlasd4 - public :: stdlib_qlasd5 - public :: stdlib_qlasd6 - public :: stdlib_qlasd7 - public :: stdlib_qlasd8 - public :: stdlib_qlasda - public :: stdlib_qlasdq - public :: stdlib_qlasdt - public :: stdlib_qlaset - public :: stdlib_qlasq1 - public :: stdlib_qlasq2 - public :: stdlib_qlasq3 - public :: stdlib_qlasq4 - public :: stdlib_qlasq5 - public :: stdlib_qlasq6 - public :: stdlib_qlasr - public :: stdlib_qlasrt - public :: stdlib_qlassq - public :: stdlib_qlasv2 - public :: stdlib_qlaswlq - public :: stdlib_qlaswp - public :: stdlib_qlasy2 - public :: stdlib_qlasyf - public :: stdlib_qlasyf_aa - public :: stdlib_qlasyf_rk - public :: stdlib_qlasyf_rook - public :: stdlib_qlat2s - public :: stdlib_qlatbs - public :: stdlib_qlatdf - public :: stdlib_qlatps - public :: stdlib_qlatrd - public :: stdlib_qlatrs - public :: stdlib_qlatrz - public :: stdlib_qlatsqr - public :: stdlib_qlauu2 - public :: stdlib_qlauum - public :: stdlib_qopgtr - public :: stdlib_qopmtr - public :: stdlib_qorbdb - public :: stdlib_qorbdb1 - public :: stdlib_qorbdb2 - public :: stdlib_qorbdb3 - public :: stdlib_qorbdb4 - public :: stdlib_qorbdb5 - public :: stdlib_qorbdb6 - public :: stdlib_qorcsd - public :: stdlib_qorcsd2by1 - public :: stdlib_qorg2l - public :: stdlib_qorg2r - public :: stdlib_qorgbr - public :: stdlib_qorghr - public :: stdlib_qorgl2 - public :: stdlib_qorglq - public :: stdlib_qorgql - public :: stdlib_qorgqr - public :: stdlib_qorgr2 - public :: stdlib_qorgrq - public :: stdlib_qorgtr - public :: stdlib_qorgtsqr - public :: stdlib_qorgtsqr_row - public :: stdlib_qorhr_col - public :: stdlib_qorm22 - public :: stdlib_qorm2l - public :: stdlib_qorm2r - public :: stdlib_qormbr - public :: stdlib_qormhr - public :: stdlib_qorml2 - public :: stdlib_qormlq - public :: stdlib_qormql - public :: stdlib_qormqr - public :: stdlib_qormr2 - public :: stdlib_qormr3 - public :: stdlib_qormrq - public :: stdlib_qormrz - public :: stdlib_qormtr - public :: stdlib_qpbcon - public :: stdlib_qpbequ - public :: stdlib_qpbrfs - public :: stdlib_qpbstf - public :: stdlib_qpbsv - public :: stdlib_qpbsvx - public :: stdlib_qpbtf2 - public :: stdlib_qpbtrf - public :: stdlib_qpbtrs - public :: stdlib_qpftrf - public :: stdlib_qpftri - public :: stdlib_qpftrs - public :: stdlib_qpocon - public :: stdlib_qpoequ - public :: stdlib_qpoequb - public :: stdlib_qporfs - public :: stdlib_qposv - public :: stdlib_qposvx - public :: stdlib_qpotf2 - public :: stdlib_qpotrf - public :: stdlib_qpotrf2 - public :: stdlib_qpotri - public :: stdlib_qpotrs - public :: stdlib_qppcon - public :: stdlib_qppequ - public :: stdlib_qpprfs - public :: stdlib_qppsv - public :: stdlib_qppsvx - public :: stdlib_qpptrf - public :: stdlib_qpptri - public :: stdlib_qpptrs - public :: stdlib_qpstf2 - public :: stdlib_qpstrf - public :: stdlib_qptcon - public :: stdlib_qpteqr - public :: stdlib_qptrfs - public :: stdlib_qptsv - public :: stdlib_qptsvx - public :: stdlib_qpttrf - public :: stdlib_qpttrs - public :: stdlib_qptts2 - public :: stdlib_qrscl - public :: stdlib_qsb2st_kernels - public :: stdlib_qsbev - public :: stdlib_qsbevd - public :: stdlib_qsbevx - public :: stdlib_qsbgst - public :: stdlib_qsbgv - public :: stdlib_qsbgvd - public :: stdlib_qsbgvx - public :: stdlib_qsbtrd - public :: stdlib_qsfrk - public :: stdlib_qsgesv - public :: stdlib_qspcon - public :: stdlib_qspev - public :: stdlib_qspevd - public :: stdlib_qspevx - public :: stdlib_qspgst - public :: stdlib_qspgv - public :: stdlib_qspgvd - public :: stdlib_qspgvx - public :: stdlib_qsposv - public :: stdlib_qsprfs - public :: stdlib_qspsv - public :: stdlib_qspsvx - public :: stdlib_qsptrd - public :: stdlib_qsptrf - public :: stdlib_qsptri - public :: stdlib_qsptrs - public :: stdlib_qstebz - public :: stdlib_qstedc - public :: stdlib_qstegr - public :: stdlib_qstein - public :: stdlib_qstemr - public :: stdlib_qsteqr - public :: stdlib_qsterf - public :: stdlib_qstev - public :: stdlib_qstevd - public :: stdlib_qstevr - public :: stdlib_qstevx - public :: stdlib_qsycon - public :: stdlib_qsycon_rook - public :: stdlib_qsyconv - public :: stdlib_qsyconvf - public :: stdlib_qsyconvf_rook - public :: stdlib_qsyequb - public :: stdlib_qsyev - public :: stdlib_qsyevd - public :: stdlib_qsyevr - public :: stdlib_qsyevx - public :: stdlib_qsygs2 - public :: stdlib_qsygst - public :: stdlib_qsygv - public :: stdlib_qsygvd - public :: stdlib_qsygvx - public :: stdlib_qsyrfs - public :: stdlib_qsysv - public :: stdlib_qsysv_aa - public :: stdlib_qsysv_rk - public :: stdlib_qsysv_rook - public :: stdlib_qsysvx - public :: stdlib_qsyswapr - public :: stdlib_qsytd2 - public :: stdlib_qsytf2 - public :: stdlib_qsytf2_rk - public :: stdlib_qsytf2_rook - public :: stdlib_qsytrd - public :: stdlib_qsytrd_sb2st - public :: stdlib_qsytrd_sy2sb - public :: stdlib_qsytrf - public :: stdlib_qsytrf_aa - public :: stdlib_qsytrf_rk - public :: stdlib_qsytrf_rook - public :: stdlib_qsytri - public :: stdlib_qsytri_rook - public :: stdlib_qsytrs - public :: stdlib_qsytrs2 - public :: stdlib_qsytrs_3 - public :: stdlib_qsytrs_aa - public :: stdlib_qsytrs_rook - public :: stdlib_qtbcon - public :: stdlib_qtbrfs - public :: stdlib_qtbtrs - public :: stdlib_qtfsm - public :: stdlib_qtftri - public :: stdlib_qtfttp - public :: stdlib_qtfttr - public :: stdlib_qtgevc - public :: stdlib_qtgex2 - public :: stdlib_qtgexc - public :: stdlib_qtgsen - public :: stdlib_qtgsja - public :: stdlib_qtgsna - public :: stdlib_qtgsy2 - public :: stdlib_qtgsyl - public :: stdlib_qtpcon - public :: stdlib_qtplqt - public :: stdlib_qtplqt2 - public :: stdlib_qtpmlqt - public :: stdlib_qtpmqrt - public :: stdlib_qtpqrt - public :: stdlib_qtpqrt2 - public :: stdlib_qtprfb - public :: stdlib_qtprfs - public :: stdlib_qtptri - public :: stdlib_qtptrs - public :: stdlib_qtpttf - public :: stdlib_qtpttr - public :: stdlib_qtrcon - public :: stdlib_qtrevc - public :: stdlib_qtrevc3 - public :: stdlib_qtrexc - public :: stdlib_qtrrfs - public :: stdlib_qtrsen - public :: stdlib_qtrsna - public :: stdlib_qtrsyl - public :: stdlib_qtrti2 - public :: stdlib_qtrtri - public :: stdlib_qtrtrs - public :: stdlib_qtrttf - public :: stdlib_qtrttp - public :: stdlib_qtzrzf - public :: stdlib_qzsum1 - public :: stdlib_qlag2q + public :: sp,dp,${rk}$,lk,ilp + public :: stdlib_${ri}$bbcsd + public :: stdlib_${ri}$bdsdc + public :: stdlib_${ri}$bdsqr + public :: stdlib_${ri}$disna + public :: stdlib_${ri}$gbbrd + public :: stdlib_${ri}$gbcon + public :: stdlib_${ri}$gbequ + public :: stdlib_${ri}$gbequb + public :: stdlib_${ri}$gbrfs + public :: stdlib_${ri}$gbsv + public :: stdlib_${ri}$gbsvx + public :: stdlib_${ri}$gbtf2 + public :: stdlib_${ri}$gbtrf + public :: stdlib_${ri}$gbtrs + public :: stdlib_${ri}$gebak + public :: stdlib_${ri}$gebal + public :: stdlib_${ri}$gebd2 + public :: stdlib_${ri}$gebrd + public :: stdlib_${ri}$gecon + public :: stdlib_${ri}$geequ + public :: stdlib_${ri}$geequb + public :: stdlib_${ri}$gees + public :: stdlib_${ri}$geesx + public :: stdlib_${ri}$geev + public :: stdlib_${ri}$geevx + public :: stdlib_${ri}$gehd2 + public :: stdlib_${ri}$gehrd + public :: stdlib_${ri}$gejsv + public :: stdlib_${ri}$gelq + public :: stdlib_${ri}$gelq2 + public :: stdlib_${ri}$gelqf + public :: stdlib_${ri}$gelqt + public :: stdlib_${ri}$gelqt3 + public :: stdlib_${ri}$gels + public :: stdlib_${ri}$gelsd + public :: stdlib_${ri}$gelss + public :: stdlib_${ri}$gelsy + public :: stdlib_${ri}$gemlq + public :: stdlib_${ri}$gemlqt + public :: stdlib_${ri}$gemqr + public :: stdlib_${ri}$gemqrt + public :: stdlib_${ri}$geql2 + public :: stdlib_${ri}$geqlf + public :: stdlib_${ri}$geqp3 + public :: stdlib_${ri}$geqr + public :: stdlib_${ri}$geqr2 + public :: stdlib_${ri}$geqr2p + public :: stdlib_${ri}$geqrf + public :: stdlib_${ri}$geqrfp + public :: stdlib_${ri}$geqrt + public :: stdlib_${ri}$geqrt2 + public :: stdlib_${ri}$geqrt3 + public :: stdlib_${ri}$gerfs + public :: stdlib_${ri}$gerq2 + public :: stdlib_${ri}$gerqf + public :: stdlib_${ri}$gesc2 + public :: stdlib_${ri}$gesdd + public :: stdlib_${ri}$gesv + public :: stdlib_${ri}$gesvd + public :: stdlib_${ri}$gesvdq + public :: stdlib_${ri}$gesvj + public :: stdlib_${ri}$gesvx + public :: stdlib_${ri}$getc2 + public :: stdlib_${ri}$getf2 + public :: stdlib_${ri}$getrf + public :: stdlib_${ri}$getrf2 + public :: stdlib_${ri}$getri + public :: stdlib_${ri}$getrs + public :: stdlib_${ri}$getsls + public :: stdlib_${ri}$getsqrhrt + public :: stdlib_${ri}$ggbak + public :: stdlib_${ri}$ggbal + public :: stdlib_${ri}$gges + public :: stdlib_${ri}$gges3 + public :: stdlib_${ri}$ggesx + public :: stdlib_${ri}$ggev + public :: stdlib_${ri}$ggev3 + public :: stdlib_${ri}$ggevx + public :: stdlib_${ri}$ggglm + public :: stdlib_${ri}$gghd3 + public :: stdlib_${ri}$gghrd + public :: stdlib_${ri}$gglse + public :: stdlib_${ri}$ggqrf + public :: stdlib_${ri}$ggrqf + public :: stdlib_${ri}$gsvj0 + public :: stdlib_${ri}$gsvj1 + public :: stdlib_${ri}$gtcon + public :: stdlib_${ri}$gtrfs + public :: stdlib_${ri}$gtsv + public :: stdlib_${ri}$gtsvx + public :: stdlib_${ri}$gttrf + public :: stdlib_${ri}$gttrs + public :: stdlib_${ri}$gtts2 + public :: stdlib_${ri}$hgeqz + public :: stdlib_${ri}$hsein + public :: stdlib_${ri}$hseqr + public :: stdlib_${ri}$isnan + public :: stdlib_${ri}$la_gbamv + public :: stdlib_${ri}$la_gbrcond + public :: stdlib_${ri}$la_gbrpvgrw + public :: stdlib_${ri}$la_geamv + public :: stdlib_${ri}$la_gercond + public :: stdlib_${ri}$la_gerpvgrw + public :: stdlib_${ri}$la_lin_berr + public :: stdlib_${ri}$la_porcond + public :: stdlib_${ri}$la_porpvgrw + public :: stdlib_${ri}$la_syamv + public :: stdlib_${ri}$la_syrcond + public :: stdlib_${ri}$la_syrpvgrw + public :: stdlib_${ri}$la_wwaddw + public :: stdlib_${ri}$labad + public :: stdlib_${ri}$labrd + public :: stdlib_${ri}$lacn2 + public :: stdlib_${ri}$lacon + public :: stdlib_${ri}$lacpy + public :: stdlib_${ri}$ladiv + public :: stdlib_${ri}$ladiv1 + public :: stdlib_${ri}$ladiv2 + public :: stdlib_${ri}$lae2 + public :: stdlib_${ri}$laebz + public :: stdlib_${ri}$laed0 + public :: stdlib_${ri}$laed1 + public :: stdlib_${ri}$laed2 + public :: stdlib_${ri}$laed3 + public :: stdlib_${ri}$laed4 + public :: stdlib_${ri}$laed5 + public :: stdlib_${ri}$laed6 + public :: stdlib_${ri}$laed7 + public :: stdlib_${ri}$laed8 + public :: stdlib_${ri}$laed9 + public :: stdlib_${ri}$laeda + public :: stdlib_${ri}$laein + public :: stdlib_${ri}$laev2 + public :: stdlib_${ri}$laexc + public :: stdlib_${ri}$lag2 + public :: stdlib_${ri}$lag2s + public :: stdlib_dlag2${ri}$ + public :: stdlib_${ri}$lags2 + public :: stdlib_${ri}$lagtf + public :: stdlib_${ri}$lagtm + public :: stdlib_${ri}$lagts + public :: stdlib_${ri}$lagv2 + public :: stdlib_${ri}$lahqr + public :: stdlib_${ri}$lahr2 + public :: stdlib_${ri}$laic1 + public :: stdlib_${ri}$laisnan + public :: stdlib_${ri}$laln2 + public :: stdlib_${ri}$lals0 + public :: stdlib_${ri}$lalsa + public :: stdlib_${ri}$lalsd + public :: stdlib_${ri}$lamch + public :: stdlib_${ri}$lamc3 + public :: stdlib_${ri}$lamrg + public :: stdlib_${ri}$lamswlq + public :: stdlib_${ri}$lamtsqr + public :: stdlib_${ri}$laneg + public :: stdlib_${ri}$langb + public :: stdlib_${ri}$lange + public :: stdlib_${ri}$langt + public :: stdlib_${ri}$lanhs + public :: stdlib_${ri}$lansb + public :: stdlib_${ri}$lansf + public :: stdlib_${ri}$lansp + public :: stdlib_${ri}$lanst + public :: stdlib_${ri}$lansy + public :: stdlib_${ri}$lantb + public :: stdlib_${ri}$lantp + public :: stdlib_${ri}$lantr + public :: stdlib_${ri}$lanv2 + public :: stdlib_${ri}$laorhr_col_getrfnp + public :: stdlib_${ri}$laorhr_col_getrfnp2 + public :: stdlib_${ri}$lapll + public :: stdlib_${ri}$lapmr + public :: stdlib_${ri}$lapmt + public :: stdlib_${ri}$lapy2 + public :: stdlib_${ri}$lapy3 + public :: stdlib_${ri}$laqgb + public :: stdlib_${ri}$laqge + public :: stdlib_${ri}$laqp2 + public :: stdlib_${ri}$laqps + public :: stdlib_${ri}$laqr0 + public :: stdlib_${ri}$laqr1 + public :: stdlib_${ri}$laqr2 + public :: stdlib_${ri}$laqr3 + public :: stdlib_${ri}$laqr4 + public :: stdlib_${ri}$laqr5 + public :: stdlib_${ri}$laqsb + public :: stdlib_${ri}$laqsp + public :: stdlib_${ri}$laqsy + public :: stdlib_${ri}$laqtr + public :: stdlib_${ri}$laqz0 + public :: stdlib_${ri}$laqz1 + public :: stdlib_${ri}$laqz2 + public :: stdlib_${ri}$laqz3 + public :: stdlib_${ri}$laqz4 + public :: stdlib_${ri}$lar1v + public :: stdlib_${ri}$lar2v + public :: stdlib_${ri}$larf + public :: stdlib_${ri}$larfb + public :: stdlib_${ri}$larfb_gett + public :: stdlib_${ri}$larfg + public :: stdlib_${ri}$larfgp + public :: stdlib_${ri}$larft + public :: stdlib_${ri}$larfx + public :: stdlib_${ri}$larfy + public :: stdlib_${ri}$largv + public :: stdlib_${ri}$larnv + public :: stdlib_${ri}$larra + public :: stdlib_${ri}$larrb + public :: stdlib_${ri}$larrc + public :: stdlib_${ri}$larrd + public :: stdlib_${ri}$larre + public :: stdlib_${ri}$larrf + public :: stdlib_${ri}$larrj + public :: stdlib_${ri}$larrk + public :: stdlib_${ri}$larrr + public :: stdlib_${ri}$larrv + public :: stdlib_${ri}$lartg + public :: stdlib_${ri}$lartgp + public :: stdlib_${ri}$lartgs + public :: stdlib_${ri}$lartv + public :: stdlib_${ri}$laruv + public :: stdlib_${ri}$larz + public :: stdlib_${ri}$larzb + public :: stdlib_${ri}$larzt + public :: stdlib_${ri}$las2 + public :: stdlib_${ri}$lascl + public :: stdlib_${ri}$lasd0 + public :: stdlib_${ri}$lasd1 + public :: stdlib_${ri}$lasd2 + public :: stdlib_${ri}$lasd3 + public :: stdlib_${ri}$lasd4 + public :: stdlib_${ri}$lasd5 + public :: stdlib_${ri}$lasd6 + public :: stdlib_${ri}$lasd7 + public :: stdlib_${ri}$lasd8 + public :: stdlib_${ri}$lasda + public :: stdlib_${ri}$lasdq + public :: stdlib_${ri}$lasdt + public :: stdlib_${ri}$laset + public :: stdlib_${ri}$lasq1 + public :: stdlib_${ri}$lasq2 + public :: stdlib_${ri}$lasq3 + public :: stdlib_${ri}$lasq4 + public :: stdlib_${ri}$lasq5 + public :: stdlib_${ri}$lasq6 + public :: stdlib_${ri}$lasr + public :: stdlib_${ri}$lasrt + public :: stdlib_${ri}$lassq + public :: stdlib_${ri}$lasv2 + public :: stdlib_${ri}$laswlq + public :: stdlib_${ri}$laswp + public :: stdlib_${ri}$lasy2 + public :: stdlib_${ri}$lasyf + public :: stdlib_${ri}$lasyf_aa + public :: stdlib_${ri}$lasyf_rk + public :: stdlib_${ri}$lasyf_rook + public :: stdlib_${ri}$lat2s + public :: stdlib_${ri}$latbs + public :: stdlib_${ri}$latdf + public :: stdlib_${ri}$latps + public :: stdlib_${ri}$latrd + public :: stdlib_${ri}$latrs + public :: stdlib_${ri}$latrz + public :: stdlib_${ri}$latsqr + public :: stdlib_${ri}$lauu2 + public :: stdlib_${ri}$lauum + public :: stdlib_${ri}$opgtr + public :: stdlib_${ri}$opmtr + public :: stdlib_${ri}$orbdb + public :: stdlib_${ri}$orbdb1 + public :: stdlib_${ri}$orbdb2 + public :: stdlib_${ri}$orbdb3 + public :: stdlib_${ri}$orbdb4 + public :: stdlib_${ri}$orbdb5 + public :: stdlib_${ri}$orbdb6 + public :: stdlib_${ri}$orcsd + public :: stdlib_${ri}$orcsd2by1 + public :: stdlib_${ri}$org2l + public :: stdlib_${ri}$org2r + public :: stdlib_${ri}$orgbr + public :: stdlib_${ri}$orghr + public :: stdlib_${ri}$orgl2 + public :: stdlib_${ri}$orglq + public :: stdlib_${ri}$orgql + public :: stdlib_${ri}$orgqr + public :: stdlib_${ri}$orgr2 + public :: stdlib_${ri}$orgrq + public :: stdlib_${ri}$orgtr + public :: stdlib_${ri}$orgtsqr + public :: stdlib_${ri}$orgtsqr_row + public :: stdlib_${ri}$orhr_col + public :: stdlib_${ri}$orm22 + public :: stdlib_${ri}$orm2l + public :: stdlib_${ri}$orm2r + public :: stdlib_${ri}$ormbr + public :: stdlib_${ri}$ormhr + public :: stdlib_${ri}$orml2 + public :: stdlib_${ri}$ormlq + public :: stdlib_${ri}$ormql + public :: stdlib_${ri}$ormqr + public :: stdlib_${ri}$ormr2 + public :: stdlib_${ri}$ormr3 + public :: stdlib_${ri}$ormrq + public :: stdlib_${ri}$ormrz + public :: stdlib_${ri}$ormtr + public :: stdlib_${ri}$pbcon + public :: stdlib_${ri}$pbequ + public :: stdlib_${ri}$pbrfs + public :: stdlib_${ri}$pbstf + public :: stdlib_${ri}$pbsv + public :: stdlib_${ri}$pbsvx + public :: stdlib_${ri}$pbtf2 + public :: stdlib_${ri}$pbtrf + public :: stdlib_${ri}$pbtrs + public :: stdlib_${ri}$pftrf + public :: stdlib_${ri}$pftri + public :: stdlib_${ri}$pftrs + public :: stdlib_${ri}$pocon + public :: stdlib_${ri}$poequ + public :: stdlib_${ri}$poequb + public :: stdlib_${ri}$porfs + public :: stdlib_${ri}$posv + public :: stdlib_${ri}$posvx + public :: stdlib_${ri}$potf2 + public :: stdlib_${ri}$potrf + public :: stdlib_${ri}$potrf2 + public :: stdlib_${ri}$potri + public :: stdlib_${ri}$potrs + public :: stdlib_${ri}$ppcon + public :: stdlib_${ri}$ppequ + public :: stdlib_${ri}$pprfs + public :: stdlib_${ri}$ppsv + public :: stdlib_${ri}$ppsvx + public :: stdlib_${ri}$pptrf + public :: stdlib_${ri}$pptri + public :: stdlib_${ri}$pptrs + public :: stdlib_${ri}$pstf2 + public :: stdlib_${ri}$pstrf + public :: stdlib_${ri}$ptcon + public :: stdlib_${ri}$pteqr + public :: stdlib_${ri}$ptrfs + public :: stdlib_${ri}$ptsv + public :: stdlib_${ri}$ptsvx + public :: stdlib_${ri}$pttrf + public :: stdlib_${ri}$pttrs + public :: stdlib_${ri}$ptts2 + public :: stdlib_${ri}$rscl + public :: stdlib_${ri}$sb2st_kernels + public :: stdlib_${ri}$sbev + public :: stdlib_${ri}$sbevd + public :: stdlib_${ri}$sbevx + public :: stdlib_${ri}$sbgst + public :: stdlib_${ri}$sbgv + public :: stdlib_${ri}$sbgvd + public :: stdlib_${ri}$sbgvx + public :: stdlib_${ri}$sbtrd + public :: stdlib_${ri}$sfrk + public :: stdlib_${ri}$sgesv + public :: stdlib_${ri}$spcon + public :: stdlib_${ri}$spev + public :: stdlib_${ri}$spevd + public :: stdlib_${ri}$spevx + public :: stdlib_${ri}$spgst + public :: stdlib_${ri}$spgv + public :: stdlib_${ri}$spgvd + public :: stdlib_${ri}$spgvx + public :: stdlib_${ri}$sposv + public :: stdlib_${ri}$sprfs + public :: stdlib_${ri}$spsv + public :: stdlib_${ri}$spsvx + public :: stdlib_${ri}$sptrd + public :: stdlib_${ri}$sptrf + public :: stdlib_${ri}$sptri + public :: stdlib_${ri}$sptrs + public :: stdlib_${ri}$stebz + public :: stdlib_${ri}$stedc + public :: stdlib_${ri}$stegr + public :: stdlib_${ri}$stein + public :: stdlib_${ri}$stemr + public :: stdlib_${ri}$steqr + public :: stdlib_${ri}$sterf + public :: stdlib_${ri}$stev + public :: stdlib_${ri}$stevd + public :: stdlib_${ri}$stevr + public :: stdlib_${ri}$stevx + public :: stdlib_${ri}$sycon + public :: stdlib_${ri}$sycon_rook + public :: stdlib_${ri}$syconv + public :: stdlib_${ri}$syconvf + public :: stdlib_${ri}$syconvf_rook + public :: stdlib_${ri}$syequb + public :: stdlib_${ri}$syev + public :: stdlib_${ri}$syevd + public :: stdlib_${ri}$syevr + public :: stdlib_${ri}$syevx + public :: stdlib_${ri}$sygs2 + public :: stdlib_${ri}$sygst + public :: stdlib_${ri}$sygv + public :: stdlib_${ri}$sygvd + public :: stdlib_${ri}$sygvx + public :: stdlib_${ri}$syrfs + public :: stdlib_${ri}$sysv + public :: stdlib_${ri}$sysv_aa + public :: stdlib_${ri}$sysv_rk + public :: stdlib_${ri}$sysv_rook + public :: stdlib_${ri}$sysvx + public :: stdlib_${ri}$syswapr + public :: stdlib_${ri}$sytd2 + public :: stdlib_${ri}$sytf2 + public :: stdlib_${ri}$sytf2_rk + public :: stdlib_${ri}$sytf2_rook + public :: stdlib_${ri}$sytrd + public :: stdlib_${ri}$sytrd_sb2st + public :: stdlib_${ri}$sytrd_sy2sb + public :: stdlib_${ri}$sytrf + public :: stdlib_${ri}$sytrf_aa + public :: stdlib_${ri}$sytrf_rk + public :: stdlib_${ri}$sytrf_rook + public :: stdlib_${ri}$sytri + public :: stdlib_${ri}$sytri_rook + public :: stdlib_${ri}$sytrs + public :: stdlib_${ri}$sytrs2 + public :: stdlib_${ri}$sytrs_3 + public :: stdlib_${ri}$sytrs_aa + public :: stdlib_${ri}$sytrs_rook + public :: stdlib_${ri}$tbcon + public :: stdlib_${ri}$tbrfs + public :: stdlib_${ri}$tbtrs + public :: stdlib_${ri}$tfsm + public :: stdlib_${ri}$tftri + public :: stdlib_${ri}$tfttp + public :: stdlib_${ri}$tfttr + public :: stdlib_${ri}$tgevc + public :: stdlib_${ri}$tgex2 + public :: stdlib_${ri}$tgexc + public :: stdlib_${ri}$tgsen + public :: stdlib_${ri}$tgsja + public :: stdlib_${ri}$tgsna + public :: stdlib_${ri}$tgsy2 + public :: stdlib_${ri}$tgsyl + public :: stdlib_${ri}$tpcon + public :: stdlib_${ri}$tplqt + public :: stdlib_${ri}$tplqt2 + public :: stdlib_${ri}$tpmlqt + public :: stdlib_${ri}$tpmqrt + public :: stdlib_${ri}$tpqrt + public :: stdlib_${ri}$tpqrt2 + public :: stdlib_${ri}$tprfb + public :: stdlib_${ri}$tprfs + public :: stdlib_${ri}$tptri + public :: stdlib_${ri}$tptrs + public :: stdlib_${ri}$tpttf + public :: stdlib_${ri}$tpttr + public :: stdlib_${ri}$trcon + public :: stdlib_${ri}$trevc + public :: stdlib_${ri}$trevc3 + public :: stdlib_${ri}$trexc + public :: stdlib_${ri}$trrfs + public :: stdlib_${ri}$trsen + public :: stdlib_${ri}$trsna + public :: stdlib_${ri}$trsyl + public :: stdlib_${ri}$trti2 + public :: stdlib_${ri}$trtri + public :: stdlib_${ri}$trtrs + public :: stdlib_${ri}$trttf + public :: stdlib_${ri}$trttp + public :: stdlib_${ri}$tzrzf + public :: stdlib_${ri}$zsum1 ! 128-bit real constants - real(qp), parameter, private :: negone = -1.00_qp - real(qp), parameter, private :: zero = 0.00_qp - real(qp), parameter, private :: half = 0.50_qp - real(qp), parameter, private :: one = 1.00_qp - real(qp), parameter, private :: two = 2.00_qp - real(qp), parameter, private :: three = 3.00_qp - real(qp), parameter, private :: four = 4.00_qp - real(qp), parameter, private :: eight = 8.00_qp - real(qp), parameter, private :: ten = 10.00_qp + real(${rk}$), parameter, private :: negone = -1.00_${rk}$ + real(${rk}$), parameter, private :: zero = 0.00_${rk}$ + real(${rk}$), parameter, private :: half = 0.50_${rk}$ + real(${rk}$), parameter, private :: one = 1.00_${rk}$ + real(${rk}$), parameter, private :: two = 2.00_${rk}$ + real(${rk}$), parameter, private :: three = 3.00_${rk}$ + real(${rk}$), parameter, private :: four = 4.00_${rk}$ + real(${rk}$), parameter, private :: eight = 8.00_${rk}$ + real(${rk}$), parameter, private :: ten = 10.00_${rk}$ ! 128-bit complex constants - complex(qp), parameter, private :: czero = ( 0.0_qp,0.0_qp) - complex(qp), parameter, private :: chalf = ( 0.5_qp,0.0_qp) - complex(qp), parameter, private :: cone = ( 1.0_qp,0.0_qp) - complex(qp), parameter, private :: cnegone = (-1.0_qp,0.0_qp) + complex(${rk}$), parameter, private :: czero = ( 0.0_${rk}$,0.0_${rk}$) + complex(${rk}$), parameter, private :: chalf = ( 0.5_${rk}$,0.0_${rk}$) + complex(${rk}$), parameter, private :: cone = ( 1.0_${rk}$,0.0_${rk}$) + complex(${rk}$), parameter, private :: cnegone = (-1.0_${rk}$,0.0_${rk}$) ! 128-bit scaling constants integer, parameter, private :: maxexp = maxexponent(zero) integer, parameter, private :: minexp = minexponent(zero) - real(qp), parameter, private :: rradix = real(radix(zero),qp) - real(qp), parameter, private :: ulp = epsilon(zero) - real(qp), parameter, private :: eps = ulp*half - real(qp), parameter, private :: safmin = rradix**max(minexp-1,1-maxexp) - real(qp), parameter, private :: safmax = one/safmin - real(qp), parameter, private :: smlnum = safmin/ulp - real(qp), parameter, private :: bignum = safmax*ulp - real(qp), parameter, private :: rtmin = sqrt(smlnum) - real(qp), parameter, private :: rtmax = sqrt(bignum) + real(${rk}$), parameter, private :: rradix = real(radix(zero),${rk}$) + real(${rk}$), parameter, private :: ulp = epsilon(zero) + real(${rk}$), parameter, private :: eps = ulp*half + real(${rk}$), parameter, private :: safmin = rradix**max(minexp-1,1-maxexp) + real(${rk}$), parameter, private :: safmax = one/safmin + real(${rk}$), parameter, private :: smlnum = safmin/ulp + real(${rk}$), parameter, private :: bignum = safmax*ulp + real(${rk}$), parameter, private :: rtmin = sqrt(smlnum) + real(${rk}$), parameter, private :: rtmax = sqrt(bignum) ! 128-bit Blue's scaling constants ! ssml>=1/s and sbig==1/S with s,S as defined in https://doi.org/10.1145/355769.355771 - real(qp), parameter, private :: tsml = rradix**ceiling((minexp-1)*half) - real(qp), parameter, private :: tbig = rradix**floor((maxexp-digits(zero)+1)*half) - real(qp), parameter, private :: ssml = rradix**(-floor((minexp-digits(zero))*half)) - real(qp), parameter, private :: sbig = rradix**(-ceiling((maxexp+digits(zero)-1)*half)) + real(${rk}$), parameter, private :: tsml = rradix**ceiling((minexp-1)*half) + real(${rk}$), parameter, private :: tbig = rradix**floor((maxexp-digits(zero)+1)*half) + real(${rk}$), parameter, private :: ssml = rradix**(-floor((minexp-digits(zero))*half)) + real(${rk}$), parameter, private :: sbig = rradix**(-ceiling((maxexp+digits(zero)-1)*half)) contains - pure subroutine stdlib_qbbcsd( jobu1, jobu2, jobv1t, jobv2t, trans, m, p, q,theta, phi, u1, & + pure subroutine stdlib_${ri}$bbcsd( jobu1, jobu2, jobv1t, jobv2t, trans, m, p, q,theta, phi, u1, & !! DBBCSD: computes the CS decomposition of an orthogonal matrix in !! bidiagonal-block form, !! [ B11 | B12 0 0 ] @@ -556,16 +557,16 @@ module stdlib_linalg_lapack_q integer(ilp), intent(out) :: info integer(ilp), intent(in) :: ldu1, ldu2, ldv1t, ldv2t, lwork, m, p, q ! Array Arguments - real(qp), intent(out) :: b11d(*), b11e(*), b12d(*), b12e(*), b21d(*), b21e(*), b22d(*),& + real(${rk}$), intent(out) :: b11d(*), b11e(*), b12d(*), b12e(*), b21d(*), b21e(*), b22d(*),& b22e(*), work(*) - real(qp), intent(inout) :: phi(*), theta(*) - real(qp), intent(inout) :: u1(ldu1,*), u2(ldu2,*), v1t(ldv1t,*), v2t(ldv2t,*) + real(${rk}$), intent(inout) :: phi(*), theta(*) + real(${rk}$), intent(inout) :: u1(ldu1,*), u2(ldu2,*), v1t(ldv1t,*), v2t(ldv2t,*) ! =================================================================== ! Parameters integer(ilp), parameter :: maxitr = 6 - real(qp), parameter :: hundred = 100.0_qp - real(qp), parameter :: meighth = -0.125_qp - real(qp), parameter :: piover2 = 1.57079632679489661923132169163975144210_qp + real(${rk}$), parameter :: hundred = 100.0_${rk}$ + real(${rk}$), parameter :: meighth = -0.125_${rk}$ + real(${rk}$), parameter :: piover2 = 1.57079632679489661923132169163975144210_${rk}$ @@ -575,7 +576,7 @@ module stdlib_linalg_lapack_q wantu2, wantv1t, wantv2t integer(ilp) :: i, imin, imax, iter, iu1cs, iu1sn, iu2cs, iu2sn, iv1tcs, iv1tsn, & iv2tcs, iv2tsn, j, lworkmin, lworkopt, maxit, mini - real(qp) :: b11bulge, b12bulge, b21bulge, b22bulge, dummy, eps, mu, nu, r, sigma11, & + real(${rk}$) :: b11bulge, b12bulge, b21bulge, b22bulge, dummy, eps, mu, nu, r, sigma11, & sigma21, temp, thetamax, thetamin, thresh, tol, tolmul, unfl, x1, x2, y1, y2 ! Intrinsic Functions intrinsic :: abs,atan2,cos,max,min,sin,sqrt @@ -635,8 +636,8 @@ module stdlib_linalg_lapack_q return end if ! get machine constants - eps = stdlib_qlamch( 'EPSILON' ) - unfl = stdlib_qlamch( 'SAFE MINIMUM' ) + eps = stdlib_${ri}$lamch( 'EPSILON' ) + unfl = stdlib_${ri}$lamch( 'SAFE MINIMUM' ) tolmul = max( ten, min( hundred, eps**meighth ) ) tol = tolmul*eps thresh = max( tol, maxitr*q*q*unfl ) @@ -718,9 +719,9 @@ module stdlib_linalg_lapack_q nu = zero else ! compute shifts for b11 and b21 and use the lesser - call stdlib_qlas2( b11d(imax-1), b11e(imax-1), b11d(imax), sigma11,dummy ) + call stdlib_${ri}$las2( b11d(imax-1), b11e(imax-1), b11d(imax), sigma11,dummy ) - call stdlib_qlas2( b21d(imax-1), b21e(imax-1), b21d(imax), sigma21,dummy ) + call stdlib_${ri}$las2( b21d(imax-1), b21e(imax-1), b21d(imax), sigma21,dummy ) if( sigma11 <= sigma21 ) then mu = sigma11 @@ -731,7 +732,7 @@ module stdlib_linalg_lapack_q end if else nu = sigma21 - mu = sqrt( 1.0_qp - nu**2 ) + mu = sqrt( 1.0_${rk}$ - nu**2 ) if( nu < thresh ) then mu = one nu = zero @@ -740,10 +741,10 @@ module stdlib_linalg_lapack_q end if ! rotate to produce bulges in b11 and b21 if( mu <= nu ) then - call stdlib_qlartgs( b11d(imin), b11e(imin), mu,work(iv1tcs+imin-1), work(iv1tsn+& + call stdlib_${ri}$lartgs( b11d(imin), b11e(imin), mu,work(iv1tcs+imin-1), work(iv1tsn+& imin-1) ) else - call stdlib_qlartgs( b21d(imin), b21e(imin), nu,work(iv1tcs+imin-1), work(iv1tsn+& + call stdlib_${ri}$lartgs( b21d(imin), b21e(imin), nu,work(iv1tcs+imin-1), work(iv1tsn+& imin-1) ) end if temp = work(iv1tcs+imin-1)*b11d(imin) +work(iv1tsn+imin-1)*b11e(imin) @@ -761,23 +762,23 @@ module stdlib_linalg_lapack_q b11bulge**2 ) ) ! chase the bulges in b11(imin+1,imin) and b21(imin+1,imin) if( b11d(imin)**2+b11bulge**2 > thresh**2 ) then - call stdlib_qlartgp( b11bulge, b11d(imin), work(iu1sn+imin-1),work(iu1cs+imin-1),& + call stdlib_${ri}$lartgp( b11bulge, b11d(imin), work(iu1sn+imin-1),work(iu1cs+imin-1),& r ) else if( mu <= nu ) then - call stdlib_qlartgs( b11e( imin ), b11d( imin + 1 ), mu,work(iu1cs+imin-1), work(& + call stdlib_${ri}$lartgs( b11e( imin ), b11d( imin + 1 ), mu,work(iu1cs+imin-1), work(& iu1sn+imin-1) ) else - call stdlib_qlartgs( b12d( imin ), b12e( imin ), nu,work(iu1cs+imin-1), work(& + call stdlib_${ri}$lartgs( b12d( imin ), b12e( imin ), nu,work(iu1cs+imin-1), work(& iu1sn+imin-1) ) end if if( b21d(imin)**2+b21bulge**2 > thresh**2 ) then - call stdlib_qlartgp( b21bulge, b21d(imin), work(iu2sn+imin-1),work(iu2cs+imin-1),& + call stdlib_${ri}$lartgp( b21bulge, b21d(imin), work(iu2sn+imin-1),work(iu2cs+imin-1),& r ) else if( nu < mu ) then - call stdlib_qlartgs( b21e( imin ), b21d( imin + 1 ), nu,work(iu2cs+imin-1), work(& + call stdlib_${ri}$lartgs( b21e( imin ), b21d( imin + 1 ), nu,work(iu2cs+imin-1), work(& iu2sn+imin-1) ) else - call stdlib_qlartgs( b22d(imin), b22e(imin), mu,work(iu2cs+imin-1), work(iu2sn+& + call stdlib_${ri}$lartgs( b22d(imin), b22e(imin), mu,work(iu2cs+imin-1), work(iu2sn+& imin-1) ) end if work(iu2cs+imin-1) = -work(iu2cs+imin-1) @@ -828,36 +829,36 @@ module stdlib_linalg_lapack_q ! b21(i-1,i+1), and b22(i-1,i). if necessary, restart bulge- ! chasing by applying the original shift again. if( .not. restart11 .and. .not. restart21 ) then - call stdlib_qlartgp( x2, x1, work(iv1tsn+i-1), work(iv1tcs+i-1),r ) + call stdlib_${ri}$lartgp( x2, x1, work(iv1tsn+i-1), work(iv1tcs+i-1),r ) else if( .not. restart11 .and. restart21 ) then - call stdlib_qlartgp( b11bulge, b11e(i-1), work(iv1tsn+i-1),work(iv1tcs+i-1), & + call stdlib_${ri}$lartgp( b11bulge, b11e(i-1), work(iv1tsn+i-1),work(iv1tcs+i-1), & r ) else if( restart11 .and. .not. restart21 ) then - call stdlib_qlartgp( b21bulge, b21e(i-1), work(iv1tsn+i-1),work(iv1tcs+i-1), & + call stdlib_${ri}$lartgp( b21bulge, b21e(i-1), work(iv1tsn+i-1),work(iv1tcs+i-1), & r ) else if( mu <= nu ) then - call stdlib_qlartgs( b11d(i), b11e(i), mu, work(iv1tcs+i-1),work(iv1tsn+i-1) ) + call stdlib_${ri}$lartgs( b11d(i), b11e(i), mu, work(iv1tcs+i-1),work(iv1tsn+i-1) ) else - call stdlib_qlartgs( b21d(i), b21e(i), nu, work(iv1tcs+i-1),work(iv1tsn+i-1) ) + call stdlib_${ri}$lartgs( b21d(i), b21e(i), nu, work(iv1tcs+i-1),work(iv1tsn+i-1) ) end if work(iv1tcs+i-1) = -work(iv1tcs+i-1) work(iv1tsn+i-1) = -work(iv1tsn+i-1) if( .not. restart12 .and. .not. restart22 ) then - call stdlib_qlartgp( y2, y1, work(iv2tsn+i-1-1),work(iv2tcs+i-1-1), r ) + call stdlib_${ri}$lartgp( y2, y1, work(iv2tsn+i-1-1),work(iv2tcs+i-1-1), r ) else if( .not. restart12 .and. restart22 ) then - call stdlib_qlartgp( b12bulge, b12d(i-1), work(iv2tsn+i-1-1),work(iv2tcs+i-1-& + call stdlib_${ri}$lartgp( b12bulge, b12d(i-1), work(iv2tsn+i-1-1),work(iv2tcs+i-1-& 1), r ) else if( restart12 .and. .not. restart22 ) then - call stdlib_qlartgp( b22bulge, b22d(i-1), work(iv2tsn+i-1-1),work(iv2tcs+i-1-& + call stdlib_${ri}$lartgp( b22bulge, b22d(i-1), work(iv2tsn+i-1-1),work(iv2tcs+i-1-& 1), r ) else if( nu < mu ) then - call stdlib_qlartgs( b12e(i-1), b12d(i), nu, work(iv2tcs+i-1-1),work(iv2tsn+i-& + call stdlib_${ri}$lartgs( b12e(i-1), b12d(i), nu, work(iv2tcs+i-1-1),work(iv2tsn+i-& 1-1) ) else - call stdlib_qlartgs( b22e(i-1), b22d(i), mu, work(iv2tcs+i-1-1),work(iv2tsn+i-& + call stdlib_${ri}$lartgs( b22e(i-1), b22d(i), mu, work(iv2tcs+i-1-1),work(iv2tsn+i-& 1-1) ) end if temp = work(iv1tcs+i-1)*b11d(i) + work(iv1tsn+i-1)*b11e(i) @@ -896,33 +897,33 @@ module stdlib_linalg_lapack_q ! b21(i+1,i), and b22(i+1,i-1). if necessary, restart bulge- ! chasing by applying the original shift again. if( .not. restart11 .and. .not. restart12 ) then - call stdlib_qlartgp( x2, x1, work(iu1sn+i-1), work(iu1cs+i-1),r ) + call stdlib_${ri}$lartgp( x2, x1, work(iu1sn+i-1), work(iu1cs+i-1),r ) else if( .not. restart11 .and. restart12 ) then - call stdlib_qlartgp( b11bulge, b11d(i), work(iu1sn+i-1),work(iu1cs+i-1), r ) + call stdlib_${ri}$lartgp( b11bulge, b11d(i), work(iu1sn+i-1),work(iu1cs+i-1), r ) else if( restart11 .and. .not. restart12 ) then - call stdlib_qlartgp( b12bulge, b12e(i-1), work(iu1sn+i-1),work(iu1cs+i-1), r ) + call stdlib_${ri}$lartgp( b12bulge, b12e(i-1), work(iu1sn+i-1),work(iu1cs+i-1), r ) else if( mu <= nu ) then - call stdlib_qlartgs( b11e(i), b11d(i+1), mu, work(iu1cs+i-1),work(iu1sn+i-1) ) + call stdlib_${ri}$lartgs( b11e(i), b11d(i+1), mu, work(iu1cs+i-1),work(iu1sn+i-1) ) else - call stdlib_qlartgs( b12d(i), b12e(i), nu, work(iu1cs+i-1),work(iu1sn+i-1) ) + call stdlib_${ri}$lartgs( b12d(i), b12e(i), nu, work(iu1cs+i-1),work(iu1sn+i-1) ) end if if( .not. restart21 .and. .not. restart22 ) then - call stdlib_qlartgp( y2, y1, work(iu2sn+i-1), work(iu2cs+i-1),r ) + call stdlib_${ri}$lartgp( y2, y1, work(iu2sn+i-1), work(iu2cs+i-1),r ) else if( .not. restart21 .and. restart22 ) then - call stdlib_qlartgp( b21bulge, b21d(i), work(iu2sn+i-1),work(iu2cs+i-1), r ) + call stdlib_${ri}$lartgp( b21bulge, b21d(i), work(iu2sn+i-1),work(iu2cs+i-1), r ) else if( restart21 .and. .not. restart22 ) then - call stdlib_qlartgp( b22bulge, b22e(i-1), work(iu2sn+i-1),work(iu2cs+i-1), r ) + call stdlib_${ri}$lartgp( b22bulge, b22e(i-1), work(iu2sn+i-1),work(iu2cs+i-1), r ) else if( nu < mu ) then - call stdlib_qlartgs( b21e(i), b21e(i+1), nu, work(iu2cs+i-1),work(iu2sn+i-1) ) + call stdlib_${ri}$lartgs( b21e(i), b21e(i+1), nu, work(iu2cs+i-1),work(iu2sn+i-1) ) else - call stdlib_qlartgs( b22d(i), b22e(i), mu, work(iu2cs+i-1),work(iu2sn+i-1) ) + call stdlib_${ri}$lartgs( b22d(i), b22e(i), mu, work(iu2cs+i-1),work(iu2sn+i-1) ) end if work(iu2cs+i-1) = -work(iu2cs+i-1) @@ -961,19 +962,19 @@ module stdlib_linalg_lapack_q restart12 = b12d(imax-1)**2 + b12bulge**2 <= thresh**2 restart22 = b22d(imax-1)**2 + b22bulge**2 <= thresh**2 if( .not. restart12 .and. .not. restart22 ) then - call stdlib_qlartgp( y2, y1, work(iv2tsn+imax-1-1),work(iv2tcs+imax-1-1), r ) + call stdlib_${ri}$lartgp( y2, y1, work(iv2tsn+imax-1-1),work(iv2tcs+imax-1-1), r ) else if( .not. restart12 .and. restart22 ) then - call stdlib_qlartgp( b12bulge, b12d(imax-1), work(iv2tsn+imax-1-1),work(iv2tcs+& + call stdlib_${ri}$lartgp( b12bulge, b12d(imax-1), work(iv2tsn+imax-1-1),work(iv2tcs+& imax-1-1), r ) else if( restart12 .and. .not. restart22 ) then - call stdlib_qlartgp( b22bulge, b22d(imax-1), work(iv2tsn+imax-1-1),work(iv2tcs+& + call stdlib_${ri}$lartgp( b22bulge, b22d(imax-1), work(iv2tsn+imax-1-1),work(iv2tcs+& imax-1-1), r ) else if( nu < mu ) then - call stdlib_qlartgs( b12e(imax-1), b12d(imax), nu,work(iv2tcs+imax-1-1), work(& + call stdlib_${ri}$lartgs( b12e(imax-1), b12d(imax), nu,work(iv2tcs+imax-1-1), work(& iv2tsn+imax-1-1) ) else - call stdlib_qlartgs( b22e(imax-1), b22d(imax), mu,work(iv2tcs+imax-1-1), work(& + call stdlib_${ri}$lartgs( b22e(imax-1), b22d(imax), mu,work(iv2tcs+imax-1-1), work(& iv2tsn+imax-1-1) ) end if temp = work(iv2tcs+imax-1-1)*b12e(imax-1) +work(iv2tsn+imax-1-1)*b12d(imax) @@ -987,37 +988,37 @@ module stdlib_linalg_lapack_q ! update singular vectors if( wantu1 ) then if( colmajor ) then - call stdlib_qlasr( 'R', 'V', 'F', p, imax-imin+1,work(iu1cs+imin-1), work(& + call stdlib_${ri}$lasr( 'R', 'V', 'F', p, imax-imin+1,work(iu1cs+imin-1), work(& iu1sn+imin-1),u1(1,imin), ldu1 ) else - call stdlib_qlasr( 'L', 'V', 'F', imax-imin+1, p,work(iu1cs+imin-1), work(& + call stdlib_${ri}$lasr( 'L', 'V', 'F', imax-imin+1, p,work(iu1cs+imin-1), work(& iu1sn+imin-1),u1(imin,1), ldu1 ) end if end if if( wantu2 ) then if( colmajor ) then - call stdlib_qlasr( 'R', 'V', 'F', m-p, imax-imin+1,work(iu2cs+imin-1), work(& + call stdlib_${ri}$lasr( 'R', 'V', 'F', m-p, imax-imin+1,work(iu2cs+imin-1), work(& iu2sn+imin-1),u2(1,imin), ldu2 ) else - call stdlib_qlasr( 'L', 'V', 'F', imax-imin+1, m-p,work(iu2cs+imin-1), work(& + call stdlib_${ri}$lasr( 'L', 'V', 'F', imax-imin+1, m-p,work(iu2cs+imin-1), work(& iu2sn+imin-1),u2(imin,1), ldu2 ) end if end if if( wantv1t ) then if( colmajor ) then - call stdlib_qlasr( 'L', 'V', 'F', imax-imin+1, q,work(iv1tcs+imin-1), work(& + call stdlib_${ri}$lasr( 'L', 'V', 'F', imax-imin+1, q,work(iv1tcs+imin-1), work(& iv1tsn+imin-1),v1t(imin,1), ldv1t ) else - call stdlib_qlasr( 'R', 'V', 'F', q, imax-imin+1,work(iv1tcs+imin-1), work(& + call stdlib_${ri}$lasr( 'R', 'V', 'F', q, imax-imin+1,work(iv1tcs+imin-1), work(& iv1tsn+imin-1),v1t(1,imin), ldv1t ) end if end if if( wantv2t ) then if( colmajor ) then - call stdlib_qlasr( 'L', 'V', 'F', imax-imin+1, m-q,work(iv2tcs+imin-1), work(& + call stdlib_${ri}$lasr( 'L', 'V', 'F', imax-imin+1, m-q,work(iv2tcs+imin-1), work(& iv2tsn+imin-1),v2t(imin,1), ldv2t ) else - call stdlib_qlasr( 'R', 'V', 'F', m-q, imax-imin+1,work(iv2tcs+imin-1), work(& + call stdlib_${ri}$lasr( 'R', 'V', 'F', m-q, imax-imin+1,work(iv2tcs+imin-1), work(& iv2tsn+imin-1),v2t(1,imin), ldv2t ) end if end if @@ -1027,9 +1028,9 @@ module stdlib_linalg_lapack_q b21d(imax) = -b21d(imax) if( wantv1t ) then if( colmajor ) then - call stdlib_qscal( q, negone, v1t(imax,1), ldv1t ) + call stdlib_${ri}$scal( q, negone, v1t(imax,1), ldv1t ) else - call stdlib_qscal( q, negone, v1t(1,imax), 1 ) + call stdlib_${ri}$scal( q, negone, v1t(1,imax), 1 ) end if end if end if @@ -1043,9 +1044,9 @@ module stdlib_linalg_lapack_q b12d(imax) = -b12d(imax) if( wantu1 ) then if( colmajor ) then - call stdlib_qscal( p, negone, u1(1,imax), 1 ) + call stdlib_${ri}$scal( p, negone, u1(1,imax), 1 ) else - call stdlib_qscal( p, negone, u1(imax,1), ldu1 ) + call stdlib_${ri}$scal( p, negone, u1(imax,1), ldu1 ) end if end if end if @@ -1053,9 +1054,9 @@ module stdlib_linalg_lapack_q b22d(imax) = -b22d(imax) if( wantu2 ) then if( colmajor ) then - call stdlib_qscal( m-p, negone, u2(1,imax), 1 ) + call stdlib_${ri}$scal( m-p, negone, u2(1,imax), 1 ) else - call stdlib_qscal( m-p, negone, u2(imax,1), ldu2 ) + call stdlib_${ri}$scal( m-p, negone, u2(imax,1), ldu2 ) end if end if end if @@ -1063,9 +1064,9 @@ module stdlib_linalg_lapack_q if( b12d(imax)+b22d(imax) < 0 ) then if( wantv2t ) then if( colmajor ) then - call stdlib_qscal( m-q, negone, v2t(imax,1), ldv2t ) + call stdlib_${ri}$scal( m-q, negone, v2t(imax,1), ldv2t ) else - call stdlib_qscal( m-q, negone, v2t(1,imax), 1 ) + call stdlib_${ri}$scal( m-q, negone, v2t(1,imax), 1 ) end if end if end if @@ -1114,25 +1115,25 @@ module stdlib_linalg_lapack_q theta(mini) = theta(i) theta(i) = thetamin if( colmajor ) then - if( wantu1 )call stdlib_qswap( p, u1(1,i), 1, u1(1,mini), 1 ) - if( wantu2 )call stdlib_qswap( m-p, u2(1,i), 1, u2(1,mini), 1 ) - if( wantv1t )call stdlib_qswap( q, v1t(i,1), ldv1t, v1t(mini,1), ldv1t ) + if( wantu1 )call stdlib_${ri}$swap( p, u1(1,i), 1, u1(1,mini), 1 ) + if( wantu2 )call stdlib_${ri}$swap( m-p, u2(1,i), 1, u2(1,mini), 1 ) + if( wantv1t )call stdlib_${ri}$swap( q, v1t(i,1), ldv1t, v1t(mini,1), ldv1t ) - if( wantv2t )call stdlib_qswap( m-q, v2t(i,1), ldv2t, v2t(mini,1),ldv2t ) + if( wantv2t )call stdlib_${ri}$swap( m-q, v2t(i,1), ldv2t, v2t(mini,1),ldv2t ) else - if( wantu1 )call stdlib_qswap( p, u1(i,1), ldu1, u1(mini,1), ldu1 ) - if( wantu2 )call stdlib_qswap( m-p, u2(i,1), ldu2, u2(mini,1), ldu2 ) - if( wantv1t )call stdlib_qswap( q, v1t(1,i), 1, v1t(1,mini), 1 ) - if( wantv2t )call stdlib_qswap( m-q, v2t(1,i), 1, v2t(1,mini), 1 ) + if( wantu1 )call stdlib_${ri}$swap( p, u1(i,1), ldu1, u1(mini,1), ldu1 ) + if( wantu2 )call stdlib_${ri}$swap( m-p, u2(i,1), ldu2, u2(mini,1), ldu2 ) + if( wantv1t )call stdlib_${ri}$swap( q, v1t(1,i), 1, v1t(1,mini), 1 ) + if( wantv2t )call stdlib_${ri}$swap( m-q, v2t(1,i), 1, v2t(1,mini), 1 ) end if end if end do return - end subroutine stdlib_qbbcsd + end subroutine stdlib_${ri}$bbcsd - pure subroutine stdlib_qbdsdc( uplo, compq, n, d, e, u, ldu, vt, ldvt, q, iq,work, iwork, & + pure subroutine stdlib_${ri}$bdsdc( uplo, compq, n, d, e, u, ldu, vt, ldvt, q, iq,work, iwork, & !! DBDSDC: computes the singular value decomposition (SVD) of a real !! N-by-N (upper or lower) bidiagonal matrix B: B = U * S * VT, !! using a divide and conquer method, where S is a diagonal matrix @@ -1159,8 +1160,8 @@ module stdlib_linalg_lapack_q integer(ilp), intent(in) :: ldu, ldvt, n ! Array Arguments integer(ilp), intent(out) :: iq(*), iwork(*) - real(qp), intent(inout) :: d(*), e(*) - real(qp), intent(out) :: q(*), u(ldu,*), vt(ldvt,*), work(*) + real(${rk}$), intent(inout) :: d(*), e(*) + real(${rk}$), intent(out) :: q(*), u(ldu,*), vt(ldvt,*), work(*) ! ===================================================================== ! changed dimension statement in comment describing e from (n) to ! (n-1). sven, 17 feb 05. @@ -1170,7 +1171,7 @@ module stdlib_linalg_lapack_q integer(ilp) :: difl, difr, givcol, givnum, givptr, i, ic, icompq, ierr, ii, is, iu, & iuplo, ivt, j, k, kk, mlvl, nm1, nsize, perm, poles, qstart, smlsiz, smlszp, sqre, & start, wstart, z - real(qp) :: cs, eps, orgnrm, p, r, sn + real(${rk}$) :: cs, eps, orgnrm, p, r, sn ! Intrinsic Functions intrinsic :: abs,real,int,log,sign ! Executable Statements @@ -1223,14 +1224,14 @@ module stdlib_linalg_lapack_q wstart = 1 qstart = 3 if( icompq==1 ) then - call stdlib_qcopy( n, d, 1, q( 1 ), 1 ) - call stdlib_qcopy( n-1, e, 1, q( n+1 ), 1 ) + call stdlib_${ri}$copy( n, d, 1, q( 1 ), 1 ) + call stdlib_${ri}$copy( n-1, e, 1, q( n+1 ), 1 ) end if if( iuplo==2 ) then qstart = 5 if( icompq == 2 ) wstart = 2*n - 1 do i = 1, n - 1 - call stdlib_qlartg( d( i ), e( i ), cs, sn, r ) + call stdlib_${ri}$lartg( d( i ), e( i ), cs, sn, r ) d( i ) = r e( i ) = sn*d( i+1 ) d( i+1 ) = cs*d( i+1 ) @@ -1243,12 +1244,12 @@ module stdlib_linalg_lapack_q end if end do end if - ! if icompq = 0, use stdlib_qlasdq to compute the singular values. + ! if icompq = 0, use stdlib_${ri}$lasdq to compute the singular values. if( icompq==0 ) then ! ignore wstart, instead using work( 1 ), since the two vectors ! for cs and -sn above are added only if icompq == 2, ! and adding them exceeds documented work size of 4*n. - call stdlib_qlasdq( 'U', 0, n, 0, 0, 0, d, e, vt, ldvt, u, ldu, u,ldu, work( 1 ), & + call stdlib_${ri}$lasdq( 'U', 0, n, 0, 0, 0, d, e, vt, ldvt, u, ldu, u,ldu, work( 1 ), & info ) go to 40 end if @@ -1256,31 +1257,31 @@ module stdlib_linalg_lapack_q ! the problem with another solver. if( n<=smlsiz ) then if( icompq==2 ) then - call stdlib_qlaset( 'A', n, n, zero, one, u, ldu ) - call stdlib_qlaset( 'A', n, n, zero, one, vt, ldvt ) - call stdlib_qlasdq( 'U', 0, n, n, n, 0, d, e, vt, ldvt, u, ldu, u,ldu, work( & + call stdlib_${ri}$laset( 'A', n, n, zero, one, u, ldu ) + call stdlib_${ri}$laset( 'A', n, n, zero, one, vt, ldvt ) + call stdlib_${ri}$lasdq( 'U', 0, n, n, n, 0, d, e, vt, ldvt, u, ldu, u,ldu, work( & wstart ), info ) else if( icompq==1 ) then iu = 1 ivt = iu + n - call stdlib_qlaset( 'A', n, n, zero, one, q( iu+( qstart-1 )*n ),n ) - call stdlib_qlaset( 'A', n, n, zero, one, q( ivt+( qstart-1 )*n ),n ) - call stdlib_qlasdq( 'U', 0, n, n, n, 0, d, e,q( ivt+( qstart-1 )*n ), n,q( iu+( & + call stdlib_${ri}$laset( 'A', n, n, zero, one, q( iu+( qstart-1 )*n ),n ) + call stdlib_${ri}$laset( 'A', n, n, zero, one, q( ivt+( qstart-1 )*n ),n ) + call stdlib_${ri}$lasdq( 'U', 0, n, n, n, 0, d, e,q( ivt+( qstart-1 )*n ), n,q( iu+( & qstart-1 )*n ), n,q( iu+( qstart-1 )*n ), n, work( wstart ),info ) end if go to 40 end if if( icompq==2 ) then - call stdlib_qlaset( 'A', n, n, zero, one, u, ldu ) - call stdlib_qlaset( 'A', n, n, zero, one, vt, ldvt ) + call stdlib_${ri}$laset( 'A', n, n, zero, one, u, ldu ) + call stdlib_${ri}$laset( 'A', n, n, zero, one, vt, ldvt ) end if ! scale. - orgnrm = stdlib_qlanst( 'M', n, d, e ) + orgnrm = stdlib_${ri}$lanst( 'M', n, d, e ) if( orgnrm==zero )return - call stdlib_qlascl( 'G', 0, 0, orgnrm, one, n, 1, d, n, ierr ) - call stdlib_qlascl( 'G', 0, 0, orgnrm, one, nm1, 1, e, nm1, ierr ) - eps = (0.9e+0_qp)*stdlib_qlamch( 'EPSILON' ) - mlvl = int( log( real( n,KIND=qp) / real( smlsiz+1,KIND=qp) ) / log( two ),KIND=ilp) + & + call stdlib_${ri}$lascl( 'G', 0, 0, orgnrm, one, n, 1, d, n, ierr ) + call stdlib_${ri}$lascl( 'G', 0, 0, orgnrm, one, nm1, 1, e, nm1, ierr ) + eps = (0.9e+0_${rk}$)*stdlib_${ri}$lamch( 'EPSILON' ) + mlvl = int( log( real( n,KIND=${rk}$) / real( smlsiz+1,KIND=${rk}$) ) / log( two ),KIND=ilp) + & 1 smlszp = smlsiz + 1 if( icompq==1 ) then @@ -1330,10 +1331,10 @@ module stdlib_linalg_lapack_q d( n ) = abs( d( n ) ) end if if( icompq==2 ) then - call stdlib_qlasd0( nsize, sqre, d( start ), e( start ),u( start, start ), & + call stdlib_${ri}$lasd0( nsize, sqre, d( start ), e( start ),u( start, start ), & ldu, vt( start, start ),ldvt, smlsiz, iwork, work( wstart ), info ) else - call stdlib_qlasda( icompq, smlsiz, nsize, sqre, d( start ),e( start ), q( & + call stdlib_${ri}$lasda( icompq, smlsiz, nsize, sqre, d( start ),e( start ), q( & start+( iu+qstart-2 )*n ), n,q( start+( ivt+qstart-2 )*n ),iq( start+k*n ), q(& start+( difl+qstart-2 )*n ), q( start+( difr+qstart-2 )*n ),q( start+( z+& qstart-2 )*n ),q( start+( poles+qstart-2 )*n ),iq( start+givptr*n ), iq( & @@ -1348,7 +1349,7 @@ module stdlib_linalg_lapack_q end if end do loop_30 ! unscale - call stdlib_qlascl( 'G', 0, 0, one, orgnrm, n, 1, d, n, ierr ) + call stdlib_${ri}$lascl( 'G', 0, 0, one, orgnrm, n, 1, d, n, ierr ) 40 continue ! use selection sort to minimize swaps of singular vectors do ii = 2, n @@ -1367,8 +1368,8 @@ module stdlib_linalg_lapack_q if( icompq==1 ) then iq( i ) = kk else if( icompq==2 ) then - call stdlib_qswap( n, u( 1, i ), 1, u( 1, kk ), 1 ) - call stdlib_qswap( n, vt( i, 1 ), ldvt, vt( kk, 1 ), ldvt ) + call stdlib_${ri}$swap( n, u( 1, i ), 1, u( 1, kk ), 1 ) + call stdlib_${ri}$swap( n, vt( i, 1 ), ldvt, vt( kk, 1 ), ldvt ) end if else if( icompq==1 ) then iq( i ) = i @@ -1384,13 +1385,13 @@ module stdlib_linalg_lapack_q end if ! if b is lower bidiagonal, update u by those givens rotations ! which rotated b to be upper bidiagonal - if( ( iuplo==2 ) .and. ( icompq==2 ) )call stdlib_qlasr( 'L', 'V', 'B', n, n, work( 1 )& + if( ( iuplo==2 ) .and. ( icompq==2 ) )call stdlib_${ri}$lasr( 'L', 'V', 'B', n, n, work( 1 )& , work( n ), u, ldu ) return - end subroutine stdlib_qbdsdc + end subroutine stdlib_${ri}$bdsdc - pure subroutine stdlib_qbdsqr( uplo, n, ncvt, nru, ncc, d, e, vt, ldvt, u,ldu, c, ldc, work, & + pure subroutine stdlib_${ri}$bdsqr( uplo, n, ncvt, nru, ncc, d, e, vt, ldvt, u,ldu, c, ldc, work, & !! DBDSQR: computes the singular values and, optionally, the right and/or !! left singular vectors from the singular value decomposition (SVD) of !! a real N-by-N (upper or lower) bidiagonal matrix B using the implicit @@ -1424,13 +1425,13 @@ module stdlib_linalg_lapack_q integer(ilp), intent(out) :: info integer(ilp), intent(in) :: ldc, ldu, ldvt, n, ncc, ncvt, nru ! Array Arguments - real(qp), intent(inout) :: c(ldc,*), d(*), e(*), u(ldu,*), vt(ldvt,*) - real(qp), intent(out) :: work(*) + real(${rk}$), intent(inout) :: c(ldc,*), d(*), e(*), u(ldu,*), vt(ldvt,*) + real(${rk}$), intent(out) :: work(*) ! ===================================================================== ! Parameters - real(qp), parameter :: hndrth = 0.01_qp - real(qp), parameter :: hndrd = 100.0_qp - real(qp), parameter :: meigth = -0.125_qp + real(${rk}$), parameter :: hndrth = 0.01_${rk}$ + real(${rk}$), parameter :: hndrd = 100.0_${rk}$ + real(${rk}$), parameter :: meigth = -0.125_${rk}$ integer(ilp), parameter :: maxitr = 6 @@ -1444,7 +1445,7 @@ module stdlib_linalg_lapack_q logical(lk) :: lower, rotate integer(ilp) :: i, idir, isub, iter, iterdivn, j, ll, lll, m, maxitdivn, nm1, nm12, & nm13, oldll, oldm - real(qp) :: abse, abss, cosl, cosr, cs, eps, f, g, h, mu, oldcs, oldsn, r, shift, & + real(${rk}$) :: abse, abss, cosl, cosr, cs, eps, f, g, h, mu, oldcs, oldsn, r, shift, & sigmn, sigmx, sinl, sinr, sll, smax, smin, sminl, sminoa, sn, thresh, tol, tolmul, & unfl ! Intrinsic Functions @@ -1480,7 +1481,7 @@ module stdlib_linalg_lapack_q rotate = ( ncvt>0 ) .or. ( nru>0 ) .or. ( ncc>0 ) ! if no singular vectors desired, use qd algorithm if( .not.rotate ) then - call stdlib_qlasq1( n, d, e, work, info ) + call stdlib_${ri}$lasq1( n, d, e, work, info ) ! if info equals 2, dqds didn't finish, try to finish if( info /= 2 ) return info = 0 @@ -1490,13 +1491,13 @@ module stdlib_linalg_lapack_q nm13 = nm12 + nm1 idir = 0 ! get machine constants - eps = stdlib_qlamch( 'EPSILON' ) - unfl = stdlib_qlamch( 'SAFE MINIMUM' ) + eps = stdlib_${ri}$lamch( 'EPSILON' ) + unfl = stdlib_${ri}$lamch( 'SAFE MINIMUM' ) ! if matrix lower bidiagonal, rotate to be upper bidiagonal ! by applying givens rotations on the left if( lower ) then do i = 1, n - 1 - call stdlib_qlartg( d( i ), e( i ), cs, sn, r ) + call stdlib_${ri}$lartg( d( i ), e( i ), cs, sn, r ) d( i ) = r e( i ) = sn*d( i+1 ) d( i+1 ) = cs*d( i+1 ) @@ -1504,9 +1505,9 @@ module stdlib_linalg_lapack_q work( nm1+i ) = sn end do ! update singular vectors if desired - if( nru>0 )call stdlib_qlasr( 'R', 'V', 'F', nru, n, work( 1 ), work( n ), u,ldu ) + if( nru>0 )call stdlib_${ri}$lasr( 'R', 'V', 'F', nru, n, work( 1 ), work( n ), u,ldu ) - if( ncc>0 )call stdlib_qlasr( 'L', 'V', 'F', n, ncc, work( 1 ), work( n ), c,ldc ) + if( ncc>0 )call stdlib_${ri}$lasr( 'L', 'V', 'F', n, ncc, work( 1 ), work( n ), c,ldc ) end if ! compute singular values to relative accuracy tol @@ -1534,7 +1535,7 @@ module stdlib_linalg_lapack_q if( sminoa==zero )go to 50 end do 50 continue - sminoa = sminoa / sqrt( real( n,KIND=qp) ) + sminoa = sminoa / sqrt( real( n,KIND=${rk}$) ) thresh = max( tol*sminoa, maxitr*(n*(n*unfl)) ) else ! absolute accuracy desired @@ -1587,16 +1588,16 @@ module stdlib_linalg_lapack_q ! e(ll) through e(m-1) are nonzero, e(ll-1) is zero if( ll==m-1 ) then ! 2 by 2 block, handle separately - call stdlib_qlasv2( d( m-1 ), e( m-1 ), d( m ), sigmn, sigmx, sinr,cosr, sinl, cosl & + call stdlib_${ri}$lasv2( d( m-1 ), e( m-1 ), d( m ), sigmn, sigmx, sinr,cosr, sinl, cosl & ) d( m-1 ) = sigmx e( m-1 ) = zero d( m ) = sigmn ! compute singular vectors, if desired - if( ncvt>0 )call stdlib_qrot( ncvt, vt( m-1, 1 ), ldvt, vt( m, 1 ), ldvt, cosr,sinr & + if( ncvt>0 )call stdlib_${ri}$rot( ncvt, vt( m-1, 1 ), ldvt, vt( m, 1 ), ldvt, cosr,sinr & ) - if( nru>0 )call stdlib_qrot( nru, u( 1, m-1 ), 1, u( 1, m ), 1, cosl, sinl ) - if( ncc>0 )call stdlib_qrot( ncc, c( m-1, 1 ), ldc, c( m, 1 ), ldc, cosl,sinl ) + if( nru>0 )call stdlib_${ri}$rot( nru, u( 1, m-1 ), 1, u( 1, m ), 1, cosl, sinl ) + if( ncc>0 )call stdlib_${ri}$rot( ncc, c( m-1, 1 ), ldc, c( m, 1 ), ldc, cosl,sinl ) m = m - 2 go to 60 @@ -1669,10 +1670,10 @@ module stdlib_linalg_lapack_q ! compute the shift from 2-by-2 block at end of matrix if( idir==1 ) then sll = abs( d( ll ) ) - call stdlib_qlas2( d( m-1 ), e( m-1 ), d( m ), shift, r ) + call stdlib_${ri}$las2( d( m-1 ), e( m-1 ), d( m ), shift, r ) else sll = abs( d( m ) ) - call stdlib_qlas2( d( ll ), e( ll ), d( ll+1 ), shift, r ) + call stdlib_${ri}$las2( d( ll ), e( ll ), d( ll+1 ), shift, r ) end if ! test if shift negligible, and if so set to zero if( sll>zero ) then @@ -1689,9 +1690,9 @@ module stdlib_linalg_lapack_q cs = one oldcs = one do i = ll, m - 1 - call stdlib_qlartg( d( i )*cs, e( i ), cs, sn, r ) + call stdlib_${ri}$lartg( d( i )*cs, e( i ), cs, sn, r ) if( i>ll )e( i-1 ) = oldsn*r - call stdlib_qlartg( oldcs*r, d( i+1 )*sn, oldcs, oldsn, d( i ) ) + call stdlib_${ri}$lartg( oldcs*r, d( i+1 )*sn, oldcs, oldsn, d( i ) ) work( i-ll+1 ) = cs work( i-ll+1+nm1 ) = sn work( i-ll+1+nm12 ) = oldcs @@ -1701,11 +1702,11 @@ module stdlib_linalg_lapack_q d( m ) = h*oldcs e( m-1 ) = h*oldsn ! update singular vectors - if( ncvt>0 )call stdlib_qlasr( 'L', 'V', 'F', m-ll+1, ncvt, work( 1 ),work( n ), & + if( ncvt>0 )call stdlib_${ri}$lasr( 'L', 'V', 'F', m-ll+1, ncvt, work( 1 ),work( n ), & vt( ll, 1 ), ldvt ) - if( nru>0 )call stdlib_qlasr( 'R', 'V', 'F', nru, m-ll+1, work( nm12+1 ),work( & + if( nru>0 )call stdlib_${ri}$lasr( 'R', 'V', 'F', nru, m-ll+1, work( nm12+1 ),work( & nm13+1 ), u( 1, ll ), ldu ) - if( ncc>0 )call stdlib_qlasr( 'L', 'V', 'F', m-ll+1, ncc, work( nm12+1 ),work( & + if( ncc>0 )call stdlib_${ri}$lasr( 'L', 'V', 'F', m-ll+1, ncc, work( nm12+1 ),work( & nm13+1 ), c( ll, 1 ), ldc ) ! test convergence if( abs( e( m-1 ) )<=thresh )e( m-1 ) = zero @@ -1715,9 +1716,9 @@ module stdlib_linalg_lapack_q cs = one oldcs = one do i = m, ll + 1, -1 - call stdlib_qlartg( d( i )*cs, e( i-1 ), cs, sn, r ) + call stdlib_${ri}$lartg( d( i )*cs, e( i-1 ), cs, sn, r ) if( i0 )call stdlib_qlasr( 'L', 'V', 'B', m-ll+1, ncvt, work( nm12+1 ),work( & + if( ncvt>0 )call stdlib_${ri}$lasr( 'L', 'V', 'B', m-ll+1, ncvt, work( nm12+1 ),work( & nm13+1 ), vt( ll, 1 ), ldvt ) - if( nru>0 )call stdlib_qlasr( 'R', 'V', 'B', nru, m-ll+1, work( 1 ),work( n ), u(& + if( nru>0 )call stdlib_${ri}$lasr( 'R', 'V', 'B', nru, m-ll+1, work( 1 ),work( n ), u(& 1, ll ), ldu ) - if( ncc>0 )call stdlib_qlasr( 'L', 'V', 'B', m-ll+1, ncc, work( 1 ),work( n ), c(& + if( ncc>0 )call stdlib_${ri}$lasr( 'L', 'V', 'B', m-ll+1, ncc, work( 1 ),work( n ), c(& ll, 1 ), ldc ) ! test convergence if( abs( e( ll ) )<=thresh )e( ll ) = zero @@ -1744,13 +1745,13 @@ module stdlib_linalg_lapack_q f = ( abs( d( ll ) )-shift )*( sign( one, d( ll ) )+shift / d( ll ) ) g = e( ll ) do i = ll, m - 1 - call stdlib_qlartg( f, g, cosr, sinr, r ) + call stdlib_${ri}$lartg( f, g, cosr, sinr, r ) if( i>ll )e( i-1 ) = r f = cosr*d( i ) + sinr*e( i ) e( i ) = cosr*e( i ) - sinr*d( i ) g = sinr*d( i+1 ) d( i+1 ) = cosr*d( i+1 ) - call stdlib_qlartg( f, g, cosl, sinl, r ) + call stdlib_${ri}$lartg( f, g, cosl, sinl, r ) d( i ) = r f = cosl*e( i ) + sinl*d( i+1 ) d( i+1 ) = cosl*d( i+1 ) - sinl*e( i ) @@ -1765,11 +1766,11 @@ module stdlib_linalg_lapack_q end do e( m-1 ) = f ! update singular vectors - if( ncvt>0 )call stdlib_qlasr( 'L', 'V', 'F', m-ll+1, ncvt, work( 1 ),work( n ), & + if( ncvt>0 )call stdlib_${ri}$lasr( 'L', 'V', 'F', m-ll+1, ncvt, work( 1 ),work( n ), & vt( ll, 1 ), ldvt ) - if( nru>0 )call stdlib_qlasr( 'R', 'V', 'F', nru, m-ll+1, work( nm12+1 ),work( & + if( nru>0 )call stdlib_${ri}$lasr( 'R', 'V', 'F', nru, m-ll+1, work( nm12+1 ),work( & nm13+1 ), u( 1, ll ), ldu ) - if( ncc>0 )call stdlib_qlasr( 'L', 'V', 'F', m-ll+1, ncc, work( nm12+1 ),work( & + if( ncc>0 )call stdlib_${ri}$lasr( 'L', 'V', 'F', m-ll+1, ncc, work( nm12+1 ),work( & nm13+1 ), c( ll, 1 ), ldc ) ! test convergence if( abs( e( m-1 ) )<=thresh )e( m-1 ) = zero @@ -1779,13 +1780,13 @@ module stdlib_linalg_lapack_q f = ( abs( d( m ) )-shift )*( sign( one, d( m ) )+shift /d( m ) ) g = e( m-1 ) do i = m, ll + 1, -1 - call stdlib_qlartg( f, g, cosr, sinr, r ) + call stdlib_${ri}$lartg( f, g, cosr, sinr, r ) if( i0 )call stdlib_qlasr( 'L', 'V', 'B', m-ll+1, ncvt, work( nm12+1 ),work( & + if( ncvt>0 )call stdlib_${ri}$lasr( 'L', 'V', 'B', m-ll+1, ncvt, work( nm12+1 ),work( & nm13+1 ), vt( ll, 1 ), ldvt ) - if( nru>0 )call stdlib_qlasr( 'R', 'V', 'B', nru, m-ll+1, work( 1 ),work( n ), u(& + if( nru>0 )call stdlib_${ri}$lasr( 'R', 'V', 'B', nru, m-ll+1, work( 1 ),work( n ), u(& 1, ll ), ldu ) - if( ncc>0 )call stdlib_qlasr( 'L', 'V', 'B', m-ll+1, ncc, work( 1 ),work( n ), c(& + if( ncc>0 )call stdlib_${ri}$lasr( 'L', 'V', 'B', m-ll+1, ncc, work( 1 ),work( n ), c(& ll, 1 ), ldc ) end if end if @@ -1818,7 +1819,7 @@ module stdlib_linalg_lapack_q if( d( i )0 )call stdlib_qscal( ncvt, negone, vt( i, 1 ), ldvt ) + if( ncvt>0 )call stdlib_${ri}$scal( ncvt, negone, vt( i, 1 ), ldvt ) end if end do ! sort the singular values into decreasing order (insertion sort on @@ -1837,10 +1838,10 @@ module stdlib_linalg_lapack_q ! swap singular values and vectors d( isub ) = d( n+1-i ) d( n+1-i ) = smin - if( ncvt>0 )call stdlib_qswap( ncvt, vt( isub, 1 ), ldvt, vt( n+1-i, 1 ),ldvt ) + if( ncvt>0 )call stdlib_${ri}$swap( ncvt, vt( isub, 1 ), ldvt, vt( n+1-i, 1 ),ldvt ) - if( nru>0 )call stdlib_qswap( nru, u( 1, isub ), 1, u( 1, n+1-i ), 1 ) - if( ncc>0 )call stdlib_qswap( ncc, c( isub, 1 ), ldc, c( n+1-i, 1 ), ldc ) + if( nru>0 )call stdlib_${ri}$swap( nru, u( 1, isub ), 1, u( 1, n+1-i ), 1 ) + if( ncc>0 )call stdlib_${ri}$swap( ncc, c( isub, 1 ), ldc, c( n+1-i, 1 ), ldc ) end if end do @@ -1853,10 +1854,10 @@ module stdlib_linalg_lapack_q end do 220 continue return - end subroutine stdlib_qbdsqr + end subroutine stdlib_${ri}$bdsqr - pure subroutine stdlib_qdisna( job, m, n, d, sep, info ) + pure subroutine stdlib_${ri}$disna( job, m, n, d, sep, info ) !! DDISNA: computes the reciprocal condition numbers for the eigenvectors !! of a real symmetric or complex Hermitian matrix or for the left or !! right singular vectors of a general m-by-n matrix. The reciprocal @@ -1878,14 +1879,14 @@ module stdlib_linalg_lapack_q integer(ilp), intent(out) :: info integer(ilp), intent(in) :: m, n ! Array Arguments - real(qp), intent(in) :: d(*) - real(qp), intent(out) :: sep(*) + real(${rk}$), intent(in) :: d(*) + real(${rk}$), intent(out) :: sep(*) ! ===================================================================== ! Local Scalars logical(lk) :: decr, eigen, incr, left, right, sing integer(ilp) :: i, k - real(qp) :: anorm, eps, newgap, oldgap, safmin, thresh + real(${rk}$) :: anorm, eps, newgap, oldgap, safmin, thresh ! Intrinsic Functions intrinsic :: abs,max,min ! Executable Statements @@ -1927,7 +1928,7 @@ module stdlib_linalg_lapack_q if( k==0 )return ! compute reciprocal condition numbers if( k==1 ) then - sep( 1 ) = stdlib_qlamch( 'O' ) + sep( 1 ) = stdlib_${ri}$lamch( 'O' ) else oldgap = abs( d( 2 )-d( 1 ) ) sep( 1 ) = oldgap @@ -1946,8 +1947,8 @@ module stdlib_linalg_lapack_q end if ! ensure that reciprocal condition numbers are not less than ! threshold, in order to limit the size of the error bound - eps = stdlib_qlamch( 'E' ) - safmin = stdlib_qlamch( 'S' ) + eps = stdlib_${ri}$lamch( 'E' ) + safmin = stdlib_${ri}$lamch( 'S' ) anorm = max( abs( d( 1 ) ), abs( d( k ) ) ) if( anorm==zero ) then thresh = eps @@ -1958,10 +1959,10 @@ module stdlib_linalg_lapack_q sep( i ) = max( sep( i ), thresh ) end do return - end subroutine stdlib_qdisna + end subroutine stdlib_${ri}$disna - pure subroutine stdlib_qgbbrd( vect, m, n, ncc, kl, ku, ab, ldab, d, e, q,ldq, pt, ldpt, c, & + pure subroutine stdlib_${ri}$gbbrd( vect, m, n, ncc, kl, ku, ab, ldab, d, e, q,ldq, pt, ldpt, c, & !! DGBBRD: reduces a real general m-by-n band matrix A to upper !! bidiagonal form B by an orthogonal transformation: Q**T * A * P = B. !! The routine computes B, and optionally forms Q or P**T, or computes @@ -1975,15 +1976,15 @@ module stdlib_linalg_lapack_q integer(ilp), intent(out) :: info integer(ilp), intent(in) :: kl, ku, ldab, ldc, ldpt, ldq, m, n, ncc ! Array Arguments - real(qp), intent(inout) :: ab(ldab,*), c(ldc,*) - real(qp), intent(out) :: d(*), e(*), pt(ldpt,*), q(ldq,*), work(*) + real(${rk}$), intent(inout) :: ab(ldab,*), c(ldc,*) + real(${rk}$), intent(out) :: d(*), e(*), pt(ldpt,*), q(ldq,*), work(*) ! ===================================================================== ! Local Scalars logical(lk) :: wantb, wantc, wantpt, wantq integer(ilp) :: i, inca, j, j1, j2, kb, kb1, kk, klm, klu1, kun, l, minmn, ml, ml0, mn,& mu, mu0, nr, nrt - real(qp) :: ra, rb, rc, rs + real(${rk}$) :: ra, rb, rc, rs ! Intrinsic Functions intrinsic :: max,min ! Executable Statements @@ -2020,8 +2021,8 @@ module stdlib_linalg_lapack_q return end if ! initialize q and p**t to the unit matrix, if needed - if( wantq )call stdlib_qlaset( 'FULL', m, m, zero, one, q, ldq ) - if( wantpt )call stdlib_qlaset( 'FULL', n, n, zero, one, pt, ldpt ) + if( wantq )call stdlib_${ri}$laset( 'FULL', m, m, zero, one, q, ldq ) + if( wantpt )call stdlib_${ri}$laset( 'FULL', n, n, zero, one, pt, ldpt ) ! quick return if possible. if( m==0 .or. n==0 )return minmn = min( m, n ) @@ -2058,7 +2059,7 @@ module stdlib_linalg_lapack_q j2 = j2 + kb ! generate plane rotations to annihilate nonzero elements ! which have been created below the band - if( nr>0 )call stdlib_qlargv( nr, ab( klu1, j1-klm-1 ), inca,work( j1 ), kb1, & + if( nr>0 )call stdlib_${ri}$largv( nr, ab( klu1, j1-klm-1 ), inca,work( j1 ), kb1, & work( mn+j1 ), kb1 ) ! apply plane rotations from the left do l = 1, kb @@ -2067,17 +2068,17 @@ module stdlib_linalg_lapack_q else nrt = nr end if - if( nrt>0 )call stdlib_qlartv( nrt, ab( klu1-l, j1-klm+l-1 ), inca,ab( & + if( nrt>0 )call stdlib_${ri}$lartv( nrt, ab( klu1-l, j1-klm+l-1 ), inca,ab( & klu1-l+1, j1-klm+l-1 ), inca,work( mn+j1 ), work( j1 ), kb1 ) end do if( ml>ml0 ) then if( ml<=m-i+1 ) then ! generate plane rotation to annihilate a(i+ml-1,i) ! within the band, and apply rotation from the left - call stdlib_qlartg( ab( ku+ml-1, i ), ab( ku+ml, i ),work( mn+i+ml-1 ), & + call stdlib_${ri}$lartg( ab( ku+ml-1, i ), ab( ku+ml, i ),work( mn+i+ml-1 ), & work( i+ml-1 ),ra ) ab( ku+ml-1, i ) = ra - if( i0 )call stdlib_qlargv( nr, ab( 1, j1+kun-1 ), inca,work( j1+kun ), kb1,& + if( nr>0 )call stdlib_${ri}$largv( nr, ab( 1, j1+kun-1 ), inca,work( j1+kun ), kb1,& work( mn+j1+kun ),kb1 ) ! apply plane rotations from the right do l = 1, kb @@ -2119,17 +2120,17 @@ module stdlib_linalg_lapack_q else nrt = nr end if - if( nrt>0 )call stdlib_qlartv( nrt, ab( l+1, j1+kun-1 ), inca,ab( l, j1+& + if( nrt>0 )call stdlib_${ri}$lartv( nrt, ab( l+1, j1+kun-1 ), inca,ab( l, j1+& kun ), inca,work( mn+j1+kun ), work( j1+kun ),kb1 ) end do if( ml==ml0 .and. mu>mu0 ) then if( mu<=n-i+1 ) then ! generate plane rotation to annihilate a(i,i+mu-1) ! within the band, and apply rotation from the right - call stdlib_qlartg( ab( ku-mu+3, i+mu-2 ),ab( ku-mu+2, i+mu-1 ),work( & + call stdlib_${ri}$lartg( ab( ku-mu+3, i+mu-2 ),ab( ku-mu+2, i+mu-1 ),work( & mn+i+mu-1 ), work( i+mu-1 ),ra ) ab( ku-mu+3, i+mu-2 ) = ra - call stdlib_qrot( min( kl+mu-2, m-i ),ab( ku-mu+4, i+mu-2 ), 1,ab( ku-& + call stdlib_${ri}$rot( min( kl+mu-2, m-i ),ab( ku-mu+4, i+mu-2 ), 1,ab( ku-& mu+3, i+mu-1 ), 1,work( mn+i+mu-1 ), work( i+mu-1 ) ) end if nr = nr + 1 @@ -2138,7 +2139,7 @@ module stdlib_linalg_lapack_q if( wantpt ) then ! accumulate product of plane rotations in p**t do j = j1, j2, kb1 - call stdlib_qrot( n, pt( j+kun-1, 1 ), ldpt,pt( j+kun, 1 ), ldpt, work( & + call stdlib_${ri}$rot( n, pt( j+kun-1, 1 ), ldpt,pt( j+kun, 1 ), ldpt, work( & mn+j+kun ),work( j+kun ) ) end do end if @@ -2167,14 +2168,14 @@ module stdlib_linalg_lapack_q ! plane rotations from the left, storing diagonal elements in d ! and off-diagonal elements in e do i = 1, min( m-1, n ) - call stdlib_qlartg( ab( 1, i ), ab( 2, i ), rc, rs, ra ) + call stdlib_${ri}$lartg( ab( 1, i ), ab( 2, i ), rc, rs, ra ) d( i ) = ra if( i1 ) then rb = -rs*ab( ku, i ) e( i-1 ) = rc*ab( ku, i ) end if - if( wantpt )call stdlib_qrot( n, pt( i, 1 ), ldpt, pt( m+1, 1 ), ldpt,rc, rs ) + if( wantpt )call stdlib_${ri}$rot( n, pt( i, 1 ), ldpt, pt( m+1, 1 ), ldpt,rc, rs ) end do else @@ -2215,10 +2216,10 @@ module stdlib_linalg_lapack_q end do end if return - end subroutine stdlib_qgbbrd + end subroutine stdlib_${ri}$gbbrd - pure subroutine stdlib_qgbcon( norm, n, kl, ku, ab, ldab, ipiv, anorm, rcond,work, iwork, & + pure subroutine stdlib_${ri}$gbcon( norm, n, kl, ku, ab, ldab, ipiv, anorm, rcond,work, iwork, & !! DGBCON: estimates the reciprocal of the condition number of a real !! general band matrix A, in either the 1-norm or the infinity-norm, !! using the LU factorization computed by DGBTRF. @@ -2233,20 +2234,20 @@ module stdlib_linalg_lapack_q character, intent(in) :: norm integer(ilp), intent(out) :: info integer(ilp), intent(in) :: kl, ku, ldab, n - real(qp), intent(in) :: anorm - real(qp), intent(out) :: rcond + real(${rk}$), intent(in) :: anorm + real(${rk}$), intent(out) :: rcond ! Array Arguments integer(ilp), intent(in) :: ipiv(*) integer(ilp), intent(out) :: iwork(*) - real(qp), intent(in) :: ab(ldab,*) - real(qp), intent(out) :: work(*) + real(${rk}$), intent(in) :: ab(ldab,*) + real(${rk}$), intent(out) :: work(*) ! ===================================================================== ! Local Scalars logical(lk) :: lnoti, onenrm character :: normin integer(ilp) :: ix, j, jp, kase, kase1, kd, lm - real(qp) :: ainvnm, scale, smlnum, t + real(${rk}$) :: ainvnm, scale, smlnum, t ! Local Arrays integer(ilp) :: isave(3) ! Intrinsic Functions @@ -2280,7 +2281,7 @@ module stdlib_linalg_lapack_q else if( anorm==zero ) then return end if - smlnum = stdlib_qlamch( 'SAFE MINIMUM' ) + smlnum = stdlib_${ri}$lamch( 'SAFE MINIMUM' ) ! estimate the norm of inv(a). ainvnm = zero normin = 'N' @@ -2293,7 +2294,7 @@ module stdlib_linalg_lapack_q lnoti = kl>0 kase = 0 10 continue - call stdlib_qlacn2( n, work( n+1 ), work, iwork, ainvnm, kase, isave ) + call stdlib_${ri}$lacn2( n, work( n+1 ), work, iwork, ainvnm, kase, isave ) if( kase/=0 ) then if( kase==kase1 ) then ! multiply by inv(l). @@ -2306,21 +2307,21 @@ module stdlib_linalg_lapack_q work( jp ) = work( j ) work( j ) = t end if - call stdlib_qaxpy( lm, -t, ab( kd+1, j ), 1, work( j+1 ), 1 ) + call stdlib_${ri}$axpy( lm, -t, ab( kd+1, j ), 1, work( j+1 ), 1 ) end do end if ! multiply by inv(u). - call stdlib_qlatbs( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', normin, n,kl+ku, ab, & + call stdlib_${ri}$latbs( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', normin, n,kl+ku, ab, & ldab, work, scale, work( 2*n+1 ),info ) else ! multiply by inv(u**t). - call stdlib_qlatbs( 'UPPER', 'TRANSPOSE', 'NON-UNIT', normin, n,kl+ku, ab, ldab, & + call stdlib_${ri}$latbs( 'UPPER', 'TRANSPOSE', 'NON-UNIT', normin, n,kl+ku, ab, ldab, & work, scale, work( 2*n+1 ),info ) ! multiply by inv(l**t). if( lnoti ) then do j = n - 1, 1, -1 lm = min( kl, n-j ) - work( j ) = work( j ) - stdlib_qdot( lm, ab( kd+1, j ), 1,work( j+1 ), 1 ) + work( j ) = work( j ) - stdlib_${ri}$dot( lm, ab( kd+1, j ), 1,work( j+1 ), 1 ) jp = ipiv( j ) if( jp/=j ) then @@ -2334,9 +2335,9 @@ module stdlib_linalg_lapack_q ! divide x by 1/scale if doing so will not cause overflow. normin = 'Y' if( scale/=one ) then - ix = stdlib_iqamax( n, work, 1 ) + ix = stdlib_i${ri}$amax( n, work, 1 ) if( scaleeps .and. two*berr( j )<=lstres .and.count<=itmax ) then ! update solution and try again. - call stdlib_qgbtrs( trans, n, kl, ku, 1, afb, ldafb, ipiv,work( n+1 ), n, info ) + call stdlib_${ri}$gbtrs( trans, n, kl, ku, 1, afb, ldafb, ipiv,work( n+1 ), n, info ) - call stdlib_qaxpy( n, one, work( n+1 ), 1, x( 1, j ), 1 ) + call stdlib_${ri}$axpy( n, one, work( n+1 ), 1, x( 1, j ), 1 ) lstres = berr( j ) count = count + 1 go to 20 @@ -2780,7 +2781,7 @@ module stdlib_linalg_lapack_q ! the i-th component of abs(r)+nz*eps*(abs(op(a))*abs(x)+abs(b)) ! is incremented by safe1 if the i-th component of ! abs(op(a))*abs(x) + abs(b) is less than safe2. - ! use stdlib_qlacn2 to estimate the infinity-norm of the matrix + ! use stdlib_${ri}$lacn2 to estimate the infinity-norm of the matrix ! inv(op(a)) * diag(w), ! where w = abs(r) + nz*eps*( abs(op(a))*abs(x)+abs(b) ))) do i = 1, n @@ -2792,12 +2793,12 @@ module stdlib_linalg_lapack_q end do kase = 0 100 continue - call stdlib_qlacn2( n, work( 2*n+1 ), work( n+1 ), iwork, ferr( j ),kase, isave ) + call stdlib_${ri}$lacn2( n, work( 2*n+1 ), work( n+1 ), iwork, ferr( j ),kase, isave ) if( kase/=0 ) then if( kase==1 ) then ! multiply by diag(w)*inv(op(a)**t). - call stdlib_qgbtrs( transt, n, kl, ku, 1, afb, ldafb, ipiv,work( n+1 ), n, & + call stdlib_${ri}$gbtrs( transt, n, kl, ku, 1, afb, ldafb, ipiv,work( n+1 ), n, & info ) do i = 1, n work( n+i ) = work( n+i )*work( i ) @@ -2807,7 +2808,7 @@ module stdlib_linalg_lapack_q do i = 1, n work( n+i ) = work( n+i )*work( i ) end do - call stdlib_qgbtrs( trans, n, kl, ku, 1, afb, ldafb, ipiv,work( n+1 ), n, & + call stdlib_${ri}$gbtrs( trans, n, kl, ku, 1, afb, ldafb, ipiv,work( n+1 ), n, & info ) end if go to 100 @@ -2820,10 +2821,10 @@ module stdlib_linalg_lapack_q if( lstres/=zero )ferr( j ) = ferr( j ) / lstres end do loop_140 return - end subroutine stdlib_qgbrfs + end subroutine stdlib_${ri}$gbrfs - pure subroutine stdlib_qgbsv( n, kl, ku, nrhs, ab, ldab, ipiv, b, ldb, info ) + pure subroutine stdlib_${ri}$gbsv( n, kl, ku, nrhs, ab, ldab, ipiv, b, ldb, info ) !! DGBSV: computes the solution to a real system of linear equations !! A * X = B, where A is a band matrix of order N with KL subdiagonals !! and KU superdiagonals, and X and B are N-by-NRHS matrices. @@ -2840,7 +2841,7 @@ module stdlib_linalg_lapack_q integer(ilp), intent(in) :: kl, ku, ldab, ldb, n, nrhs ! Array Arguments integer(ilp), intent(out) :: ipiv(*) - real(qp), intent(inout) :: ab(ldab,*), b(ldb,*) + real(${rk}$), intent(inout) :: ab(ldab,*), b(ldb,*) ! ===================================================================== ! Intrinsic Functions intrinsic :: max @@ -2865,17 +2866,17 @@ module stdlib_linalg_lapack_q return end if ! compute the lu factorization of the band matrix a. - call stdlib_qgbtrf( n, n, kl, ku, ab, ldab, ipiv, info ) + call stdlib_${ri}$gbtrf( n, n, kl, ku, ab, ldab, ipiv, info ) if( info==0 ) then ! solve the system a*x = b, overwriting b with x. - call stdlib_qgbtrs( 'NO TRANSPOSE', n, kl, ku, nrhs, ab, ldab, ipiv,b, ldb, info ) + call stdlib_${ri}$gbtrs( 'NO TRANSPOSE', n, kl, ku, nrhs, ab, ldab, ipiv,b, ldb, info ) end if return - end subroutine stdlib_qgbsv + end subroutine stdlib_${ri}$gbsv - subroutine stdlib_qgbsvx( fact, trans, n, kl, ku, nrhs, ab, ldab, afb,ldafb, ipiv, equed, r, & + subroutine stdlib_${ri}$gbsvx( fact, trans, n, kl, ku, nrhs, ab, ldab, afb,ldafb, ipiv, equed, r, & !! DGBSVX: uses the LU factorization to compute the solution to a real !! system of linear equations A * X = B, A**T * X = B, or A**H * X = B, !! where A is a band matrix of order N with KL subdiagonals and KU @@ -2891,19 +2892,19 @@ module stdlib_linalg_lapack_q character, intent(in) :: fact, trans integer(ilp), intent(out) :: info integer(ilp), intent(in) :: kl, ku, ldab, ldafb, ldb, ldx, n, nrhs - real(qp), intent(out) :: rcond + real(${rk}$), intent(out) :: rcond ! Array Arguments integer(ilp), intent(inout) :: ipiv(*) integer(ilp), intent(out) :: iwork(*) - real(qp), intent(inout) :: ab(ldab,*), afb(ldafb,*), b(ldb,*), c(*), r(*) - real(qp), intent(out) :: berr(*), ferr(*), work(*), x(ldx,*) + real(${rk}$), intent(inout) :: ab(ldab,*), afb(ldafb,*), b(ldb,*), c(*), r(*) + real(${rk}$), intent(out) :: berr(*), ferr(*), work(*), x(ldx,*) ! ===================================================================== ! Local Scalars logical(lk) :: colequ, equil, nofact, notran, rowequ character :: norm integer(ilp) :: i, infequ, j, j1, j2 - real(qp) :: amax, anorm, bignum, colcnd, rcmax, rcmin, rowcnd, rpvgrw, smlnum + real(${rk}$) :: amax, anorm, bignum, colcnd, rcmax, rcmin, rowcnd, rpvgrw, smlnum ! Intrinsic Functions intrinsic :: abs,max,min ! Executable Statements @@ -2918,7 +2919,7 @@ module stdlib_linalg_lapack_q else rowequ = stdlib_lsame( equed, 'R' ) .or. stdlib_lsame( equed, 'B' ) colequ = stdlib_lsame( equed, 'C' ) .or. stdlib_lsame( equed, 'B' ) - smlnum = stdlib_qlamch( 'SAFE MINIMUM' ) + smlnum = stdlib_${ri}$lamch( 'SAFE MINIMUM' ) bignum = one / smlnum end if ! test the input parameters. @@ -2987,11 +2988,11 @@ module stdlib_linalg_lapack_q end if if( equil ) then ! compute row and column scalings to equilibrate the matrix a. - call stdlib_qgbequ( n, n, kl, ku, ab, ldab, r, c, rowcnd, colcnd,amax, infequ ) + call stdlib_${ri}$gbequ( n, n, kl, ku, ab, ldab, r, c, rowcnd, colcnd,amax, infequ ) if( infequ==0 ) then ! equilibrate the matrix. - call stdlib_qlaqgb( n, n, kl, ku, ab, ldab, r, c, rowcnd, colcnd,amax, equed ) + call stdlib_${ri}$laqgb( n, n, kl, ku, ab, ldab, r, c, rowcnd, colcnd,amax, equed ) rowequ = stdlib_lsame( equed, 'R' ) .or. stdlib_lsame( equed, 'B' ) colequ = stdlib_lsame( equed, 'C' ) .or. stdlib_lsame( equed, 'B' ) @@ -3018,10 +3019,10 @@ module stdlib_linalg_lapack_q do j = 1, n j1 = max( j-ku, 1 ) j2 = min( j+kl, n ) - call stdlib_qcopy( j2-j1+1, ab( ku+1-j+j1, j ), 1,afb( kl+ku+1-j+j1, j ), 1 ) + call stdlib_${ri}$copy( j2-j1+1, ab( ku+1-j+j1, j ), 1,afb( kl+ku+1-j+j1, j ), 1 ) end do - call stdlib_qgbtrf( n, n, kl, ku, afb, ldafb, ipiv, info ) + call stdlib_${ri}$gbtrf( n, n, kl, ku, afb, ldafb, ipiv, info ) ! return if info is non-zero. if( info>0 ) then ! compute the reciprocal pivot growth factor of the @@ -3032,7 +3033,7 @@ module stdlib_linalg_lapack_q anorm = max( anorm, abs( ab( i, j ) ) ) end do end do - rpvgrw = stdlib_qlantb( 'M', 'U', 'N', info, min( info-1, kl+ku ),afb( max( 1, & + rpvgrw = stdlib_${ri}$lantb( 'M', 'U', 'N', info, min( info-1, kl+ku ),afb( max( 1, & kl+ku+2-info ), 1 ), ldafb,work ) if( rpvgrw==zero ) then rpvgrw = one @@ -3051,22 +3052,22 @@ module stdlib_linalg_lapack_q else norm = 'I' end if - anorm = stdlib_qlangb( norm, n, kl, ku, ab, ldab, work ) - rpvgrw = stdlib_qlantb( 'M', 'U', 'N', n, kl+ku, afb, ldafb, work ) + anorm = stdlib_${ri}$langb( norm, n, kl, ku, ab, ldab, work ) + rpvgrw = stdlib_${ri}$lantb( 'M', 'U', 'N', n, kl+ku, afb, ldafb, work ) if( rpvgrw==zero ) then rpvgrw = one else - rpvgrw = stdlib_qlangb( 'M', n, kl, ku, ab, ldab, work ) / rpvgrw + rpvgrw = stdlib_${ri}$langb( 'M', n, kl, ku, ab, ldab, work ) / rpvgrw end if ! compute the reciprocal of the condition number of a. - call stdlib_qgbcon( norm, n, kl, ku, afb, ldafb, ipiv, anorm, rcond,work, iwork, info ) + call stdlib_${ri}$gbcon( norm, n, kl, ku, afb, ldafb, ipiv, anorm, rcond,work, iwork, info ) ! compute the solution matrix x. - call stdlib_qlacpy( 'FULL', n, nrhs, b, ldb, x, ldx ) - call stdlib_qgbtrs( trans, n, kl, ku, nrhs, afb, ldafb, ipiv, x, ldx,info ) + call stdlib_${ri}$lacpy( 'FULL', n, nrhs, b, ldb, x, ldx ) + call stdlib_${ri}$gbtrs( trans, n, kl, ku, nrhs, afb, ldafb, ipiv, x, ldx,info ) ! use iterative refinement to improve the computed solution and ! compute error bounds and backward error estimates for it. - call stdlib_qgbrfs( trans, n, kl, ku, nrhs, ab, ldab, afb, ldafb, ipiv,b, ldb, x, ldx, & + call stdlib_${ri}$gbrfs( trans, n, kl, ku, nrhs, ab, ldab, afb, ldafb, ipiv,b, ldb, x, ldx, & ferr, berr, work, iwork, info ) ! transform the solution matrix x to a solution of the original ! system. @@ -3092,13 +3093,13 @@ module stdlib_linalg_lapack_q end do end if ! set info = n+1 if the matrix is singular to working precision. - if( rcond0 ) then ! compute multipliers. - call stdlib_qscal( km, one / ab( kv+1, j ), ab( kv+2, j ), 1 ) + call stdlib_${ri}$scal( km, one / ab( kv+1, j ), ab( kv+2, j ), 1 ) ! update trailing submatrix within the band. - if( ju>j )call stdlib_qger( km, ju-j, -one, ab( kv+2, j ), 1,ab( kv, j+1 ), & + if( ju>j )call stdlib_${ri}$ger( km, ju-j, -one, ab( kv+2, j ), 1,ab( kv, j+1 ), & ldab-1, ab( kv+1, j+1 ),ldab-1 ) end if else @@ -3181,10 +3182,10 @@ module stdlib_linalg_lapack_q end if end do loop_40 return - end subroutine stdlib_qgbtf2 + end subroutine stdlib_${ri}$gbtf2 - pure subroutine stdlib_qgbtrf( m, n, kl, ku, ab, ldab, ipiv, info ) + pure subroutine stdlib_${ri}$gbtrf( m, n, kl, ku, ab, ldab, ipiv, info ) !! DGBTRF: computes an LU factorization of a real m-by-n band matrix A !! using partial pivoting with row interchanges. !! This is the blocked version of the algorithm, calling Level 3 BLAS. @@ -3196,7 +3197,7 @@ module stdlib_linalg_lapack_q integer(ilp), intent(in) :: kl, ku, ldab, m, n ! Array Arguments integer(ilp), intent(out) :: ipiv(*) - real(qp), intent(inout) :: ab(ldab,*) + real(${rk}$), intent(inout) :: ab(ldab,*) ! ===================================================================== ! Parameters integer(ilp), parameter :: nbmax = 64 @@ -3206,9 +3207,9 @@ module stdlib_linalg_lapack_q ! Local Scalars integer(ilp) :: i, i2, i3, ii, ip, j, j2, j3, jb, jj, jm, jp, ju, k2, km, kv, nb, & nw - real(qp) :: temp + real(${rk}$) :: temp ! Local Arrays - real(qp) :: work13(ldwork,nbmax), work31(ldwork,nbmax) + real(${rk}$) :: work13(ldwork,nbmax), work31(ldwork,nbmax) ! Intrinsic Functions intrinsic :: max,min ! Executable Statements @@ -3241,7 +3242,7 @@ module stdlib_linalg_lapack_q nb = min( nb, nbmax ) if( nb<=1 .or. nb>kl ) then ! use unblocked code - call stdlib_qgbtf2( m, n, kl, ku, ab, ldab, ipiv, info ) + call stdlib_${ri}$gbtf2( m, n, kl, ku, ab, ldab, ipiv, info ) else ! use blocked code ! zero the superdiagonal elements of the work array work13 @@ -3291,31 +3292,31 @@ module stdlib_linalg_lapack_q ! find pivot and test for singularity. km is the number of ! subdiagonal elements in the current column. km = min( kl, m-jj ) - jp = stdlib_iqamax( km+1, ab( kv+1, jj ), 1 ) + jp = stdlib_i${ri}$amax( km+1, ab( kv+1, jj ), 1 ) ipiv( jj ) = jp + jj - j if( ab( kv+jp, jj )/=zero ) then ju = max( ju, min( jj+ku+jp-1, n ) ) if( jp/=1 ) then ! apply interchange to columns j to j+jb-1 if( jp+jj-1jj )call stdlib_qger( km, jm-jj, -one, ab( kv+2, jj ), 1,ab( kv, jj+& + if( jm>jj )call stdlib_${ri}$ger( km, jm-jj, -one, ab( kv+2, jj ), 1,ab( kv, jj+& 1 ), ldab-1,ab( kv+1, jj+1 ), ldab-1 ) else ! if pivot is zero, set info to the index of the pivot @@ -3324,16 +3325,16 @@ module stdlib_linalg_lapack_q end if ! copy current column of a31 into the work array work31 nw = min( jj-j+1, i3 ) - if( nw>0 )call stdlib_qcopy( nw, ab( kv+kl+1-jj+j, jj ), 1,work31( 1, jj-j+1 )& + if( nw>0 )call stdlib_${ri}$copy( nw, ab( kv+kl+1-jj+j, jj ), 1,work31( 1, jj-j+1 )& , 1 ) end do loop_80 if( j+jb<=n ) then ! apply the row interchanges to the other blocks. j2 = min( ju-j+1, kv ) - jb j3 = max( 0, ju-j-kv+1 ) - ! use stdlib_qlaswp to apply the row interchanges to a12, a22, and + ! use stdlib_${ri}$laswp to apply the row interchanges to a12, a22, and ! a32. - call stdlib_qlaswp( j2, ab( kv+1-jb, j+jb ), ldab-1, 1, jb,ipiv( j ), 1 ) + call stdlib_${ri}$laswp( j2, ab( kv+1-jb, j+jb ), ldab-1, 1, jb,ipiv( j ), 1 ) ! adjust the pivot indices. do i = j, j + jb - 1 @@ -3356,17 +3357,17 @@ module stdlib_linalg_lapack_q ! update the relevant part of the trailing submatrix if( j2>0 ) then ! update a12 - call stdlib_qtrsm( 'LEFT', 'LOWER', 'NO TRANSPOSE', 'UNIT',jb, j2, one, ab(& + call stdlib_${ri}$trsm( 'LEFT', 'LOWER', 'NO TRANSPOSE', 'UNIT',jb, j2, one, ab(& kv+1, j ), ldab-1,ab( kv+1-jb, j+jb ), ldab-1 ) if( i2>0 ) then ! update a22 - call stdlib_qgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', i2, j2,jb, -one, ab( & + call stdlib_${ri}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', i2, j2,jb, -one, ab( & kv+1+jb, j ), ldab-1,ab( kv+1-jb, j+jb ), ldab-1, one,ab( kv+1, j+jb ), & ldab-1 ) end if if( i3>0 ) then ! update a32 - call stdlib_qgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', i3, j2,jb, -one, & + call stdlib_${ri}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', i3, j2,jb, -one, & work31, ldwork,ab( kv+1-jb, j+jb ), ldab-1, one,ab( kv+kl+1-jb, j+jb ), & ldab-1 ) end if @@ -3380,17 +3381,17 @@ module stdlib_linalg_lapack_q end do end do ! update a13 in the work array - call stdlib_qtrsm( 'LEFT', 'LOWER', 'NO TRANSPOSE', 'UNIT',jb, j3, one, ab(& + call stdlib_${ri}$trsm( 'LEFT', 'LOWER', 'NO TRANSPOSE', 'UNIT',jb, j3, one, ab(& kv+1, j ), ldab-1,work13, ldwork ) if( i2>0 ) then ! update a23 - call stdlib_qgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', i2, j3,jb, -one, ab( & + call stdlib_${ri}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', i2, j3,jb, -one, ab( & kv+1+jb, j ), ldab-1,work13, ldwork, one, ab( 1+jb, j+kv ),ldab-1 ) end if if( i3>0 ) then ! update a33 - call stdlib_qgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', i3, j3,jb, -one, & + call stdlib_${ri}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', i3, j3,jb, -one, & work31, ldwork, work13,ldwork, one, ab( 1+kl, j+kv ), ldab-1 ) end if ! copy the lower triangle of a13 back into place @@ -3415,26 +3416,26 @@ module stdlib_linalg_lapack_q ! apply interchange to columns j to jj-1 if( jp+jj-10 )call stdlib_qcopy( nw, work31( 1, jj-j+1 ), 1,ab( kv+kl+1-jj+j, jj )& + if( nw>0 )call stdlib_${ri}$copy( nw, work31( 1, jj-j+1 ), 1,ab( kv+kl+1-jj+j, jj )& , 1 ) end do end do loop_180 end if return - end subroutine stdlib_qgbtrf + end subroutine stdlib_${ri}$gbtrf - pure subroutine stdlib_qgbtrs( trans, n, kl, ku, nrhs, ab, ldab, ipiv, b, ldb,info ) + pure subroutine stdlib_${ri}$gbtrs( trans, n, kl, ku, nrhs, ab, ldab, ipiv, b, ldb,info ) !! DGBTRS: solves a system of linear equations !! A * X = B or A**T * X = B !! with a general band matrix A using the LU factorization computed @@ -3448,8 +3449,8 @@ module stdlib_linalg_lapack_q integer(ilp), intent(in) :: kl, ku, ldab, ldb, n, nrhs ! Array Arguments integer(ilp), intent(in) :: ipiv(*) - real(qp), intent(in) :: ab(ldab,*) - real(qp), intent(inout) :: b(ldb,*) + real(${rk}$), intent(in) :: ab(ldab,*) + real(${rk}$), intent(inout) :: b(ldb,*) ! ===================================================================== ! Local Scalars @@ -3496,39 +3497,39 @@ module stdlib_linalg_lapack_q do j = 1, n - 1 lm = min( kl, n-j ) l = ipiv( j ) - if( l/=j )call stdlib_qswap( nrhs, b( l, 1 ), ldb, b( j, 1 ), ldb ) - call stdlib_qger( lm, nrhs, -one, ab( kd+1, j ), 1, b( j, 1 ),ldb, b( j+1, 1 )& + if( l/=j )call stdlib_${ri}$swap( nrhs, b( l, 1 ), ldb, b( j, 1 ), ldb ) + call stdlib_${ri}$ger( lm, nrhs, -one, ab( kd+1, j ), 1, b( j, 1 ),ldb, b( j+1, 1 )& , ldb ) end do end if do i = 1, nrhs ! solve u*x = b, overwriting b with x. - call stdlib_qtbsv( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', n, kl+ku,ab, ldab, b( 1, & + call stdlib_${ri}$tbsv( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', n, kl+ku,ab, ldab, b( 1, & i ), 1 ) end do else ! solve a**t*x = b. do i = 1, nrhs ! solve u**t*x = b, overwriting b with x. - call stdlib_qtbsv( 'UPPER', 'TRANSPOSE', 'NON-UNIT', n, kl+ku, ab,ldab, b( 1, i )& + call stdlib_${ri}$tbsv( 'UPPER', 'TRANSPOSE', 'NON-UNIT', n, kl+ku, ab,ldab, b( 1, i )& , 1 ) end do ! solve l**t*x = b, overwriting b with x. if( lnoti ) then do j = n - 1, 1, -1 lm = min( kl, n-j ) - call stdlib_qgemv( 'TRANSPOSE', lm, nrhs, -one, b( j+1, 1 ),ldb, ab( kd+1, j )& + call stdlib_${ri}$gemv( 'TRANSPOSE', lm, nrhs, -one, b( j+1, 1 ),ldb, ab( kd+1, j )& , 1, one, b( j, 1 ), ldb ) l = ipiv( j ) - if( l/=j )call stdlib_qswap( nrhs, b( l, 1 ), ldb, b( j, 1 ), ldb ) + if( l/=j )call stdlib_${ri}$swap( nrhs, b( l, 1 ), ldb, b( j, 1 ), ldb ) end do end if end if return - end subroutine stdlib_qgbtrs + end subroutine stdlib_${ri}$gbtrs - pure subroutine stdlib_qgebak( job, side, n, ilo, ihi, scale, m, v, ldv,info ) + pure subroutine stdlib_${ri}$gebak( job, side, n, ilo, ihi, scale, m, v, ldv,info ) !! DGEBAK: forms the right or left eigenvectors of a real general matrix !! by backward transformation on the computed eigenvectors of the !! balanced matrix output by DGEBAL. @@ -3540,14 +3541,14 @@ module stdlib_linalg_lapack_q integer(ilp), intent(in) :: ihi, ilo, ldv, m, n integer(ilp), intent(out) :: info ! Array Arguments - real(qp), intent(in) :: scale(*) - real(qp), intent(inout) :: v(ldv,*) + real(${rk}$), intent(in) :: scale(*) + real(${rk}$), intent(inout) :: v(ldv,*) ! ===================================================================== ! Local Scalars logical(lk) :: leftv, rightv integer(ilp) :: i, ii, k - real(qp) :: s + real(${rk}$) :: s ! Intrinsic Functions intrinsic :: max,min ! Executable Statements @@ -3585,13 +3586,13 @@ module stdlib_linalg_lapack_q if( rightv ) then do i = ilo, ihi s = scale( i ) - call stdlib_qscal( m, s, v( i, 1 ), ldv ) + call stdlib_${ri}$scal( m, s, v( i, 1 ), ldv ) end do end if if( leftv ) then do i = ilo, ihi s = one / scale( i ) - call stdlib_qscal( m, s, v( i, 1 ), ldv ) + call stdlib_${ri}$scal( m, s, v( i, 1 ), ldv ) end do end if end if @@ -3607,7 +3608,7 @@ module stdlib_linalg_lapack_q if( i=g .or. max( f, c, ca )>=sfmax2 .or.min( r, g, ra )<=sfmin2 )go to 170 - if( stdlib_qisnan( c+f+ca+r+g+ra ) ) then + if( stdlib_${ri}$isnan( c+f+ca+r+g+ra ) ) then ! exit if nan to avoid infinite loop info = -3 call stdlib_xerbla( 'DGEBAL', -info ) @@ -3782,18 +3783,18 @@ module stdlib_linalg_lapack_q g = one / f scale( i ) = scale( i )*f noconv = .true. - call stdlib_qscal( n-k+1, g, a( i, k ), lda ) - call stdlib_qscal( l, f, a( 1, i ), 1 ) + call stdlib_${ri}$scal( n-k+1, g, a( i, k ), lda ) + call stdlib_${ri}$scal( l, f, a( 1, i ), 1 ) end do loop_200 if( noconv )go to 140 210 continue ilo = k ihi = l return - end subroutine stdlib_qgebal + end subroutine stdlib_${ri}$gebal - pure subroutine stdlib_qgebd2( m, n, a, lda, d, e, tauq, taup, work, info ) + pure subroutine stdlib_${ri}$gebd2( m, n, a, lda, d, e, tauq, taup, work, info ) !! DGEBD2: reduces a real general m by n matrix A to upper or lower !! bidiagonal form B by an orthogonal transformation: Q**T * A * P = B. !! If m >= n, B is upper bidiagonal; if m < n, B is lower bidiagonal. @@ -3804,8 +3805,8 @@ module stdlib_linalg_lapack_q integer(ilp), intent(out) :: info integer(ilp), intent(in) :: lda, m, n ! Array Arguments - real(qp), intent(inout) :: a(lda,*) - real(qp), intent(out) :: d(*), e(*), taup(*), tauq(*), work(*) + real(${rk}$), intent(inout) :: a(lda,*) + real(${rk}$), intent(out) :: d(*), e(*), taup(*), tauq(*), work(*) ! ===================================================================== ! Local Scalars @@ -3830,23 +3831,23 @@ module stdlib_linalg_lapack_q ! reduce to upper bidiagonal form do i = 1, n ! generate elementary reflector h(i) to annihilate a(i+1:m,i) - call stdlib_qlarfg( m-i+1, a( i, i ), a( min( i+1, m ), i ), 1,tauq( i ) ) + call stdlib_${ri}$larfg( m-i+1, a( i, i ), a( min( i+1, m ), i ), 1,tauq( i ) ) d( i ) = a( i, i ) a( i, i ) = one ! apply h(i) to a(i:m,i+1:n) from the left - if( i= n, B is upper bidiagonal; if m < n, B is lower bidiagonal. @@ -3896,8 +3897,8 @@ module stdlib_linalg_lapack_q integer(ilp), intent(out) :: info integer(ilp), intent(in) :: lda, lwork, m, n ! Array Arguments - real(qp), intent(inout) :: a(lda,*) - real(qp), intent(out) :: d(*), e(*), taup(*), tauq(*), work(*) + real(${rk}$), intent(inout) :: a(lda,*) + real(${rk}$), intent(out) :: d(*), e(*), taup(*), tauq(*), work(*) ! ===================================================================== ! Local Scalars @@ -3910,7 +3911,7 @@ module stdlib_linalg_lapack_q info = 0 nb = max( 1, stdlib_ilaenv( 1, 'DGEBRD', ' ', m, n, -1, -1 ) ) lwkopt = ( m+n )*nb - work( 1 ) = real( lwkopt,KIND=qp) + work( 1 ) = real( lwkopt,KIND=${rk}$) lquery = ( lwork==-1 ) if( m<0 ) then info = -1 @@ -3961,13 +3962,13 @@ module stdlib_linalg_lapack_q ! reduce rows and columns i:i+nb-1 to bidiagonal form and return ! the matrices x and y which are needed to update the unreduced ! part of the matrix - call stdlib_qlabrd( m-i+1, n-i+1, nb, a( i, i ), lda, d( i ), e( i ),tauq( i ), & + call stdlib_${ri}$labrd( m-i+1, n-i+1, nb, a( i, i ), lda, d( i ), e( i ),tauq( i ), & taup( i ), work, ldwrkx,work( ldwrkx*nb+1 ), ldwrky ) ! update the trailing submatrix a(i+nb:m,i+nb:n), using an update ! of the form a := a - v*y**t - x*u**t - call stdlib_qgemm( 'NO TRANSPOSE', 'TRANSPOSE', m-i-nb+1, n-i-nb+1,nb, -one, a( i+& + call stdlib_${ri}$gemm( 'NO TRANSPOSE', 'TRANSPOSE', m-i-nb+1, n-i-nb+1,nb, -one, a( i+& nb, i ), lda,work( ldwrkx*nb+nb+1 ), ldwrky, one,a( i+nb, i+nb ), lda ) - call stdlib_qgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', m-i-nb+1, n-i-nb+1,nb, -one, & + call stdlib_${ri}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', m-i-nb+1, n-i-nb+1,nb, -one, & work( nb+1 ), ldwrkx, a( i, i+nb ), lda,one, a( i+nb, i+nb ), lda ) ! copy diagonal and off-diagonal elements of b back into a if( m>=n ) then @@ -3983,14 +3984,14 @@ module stdlib_linalg_lapack_q end if end do ! use unblocked code to reduce the remainder of the matrix - call stdlib_qgebd2( m-i+1, n-i+1, a( i, i ), lda, d( i ), e( i ),tauq( i ), taup( i ), & + call stdlib_${ri}$gebd2( m-i+1, n-i+1, a( i, i ), lda, d( i ), e( i ),tauq( i ), taup( i ), & work, iinfo ) work( 1 ) = ws return - end subroutine stdlib_qgebrd + end subroutine stdlib_${ri}$gebrd - pure subroutine stdlib_qgecon( norm, n, a, lda, anorm, rcond, work, iwork,info ) + pure subroutine stdlib_${ri}$gecon( norm, n, a, lda, anorm, rcond, work, iwork,info ) !! DGECON: estimates the reciprocal of the condition number of a general !! real matrix A, in either the 1-norm or the infinity-norm, using !! the LU factorization computed by DGETRF. @@ -4004,19 +4005,19 @@ module stdlib_linalg_lapack_q character, intent(in) :: norm integer(ilp), intent(out) :: info integer(ilp), intent(in) :: lda, n - real(qp), intent(in) :: anorm - real(qp), intent(out) :: rcond + real(${rk}$), intent(in) :: anorm + real(${rk}$), intent(out) :: rcond ! Array Arguments integer(ilp), intent(out) :: iwork(*) - real(qp), intent(inout) :: a(lda,*) - real(qp), intent(out) :: work(*) + real(${rk}$), intent(inout) :: a(lda,*) + real(${rk}$), intent(out) :: work(*) ! ===================================================================== ! Local Scalars logical(lk) :: onenrm character :: normin integer(ilp) :: ix, kase, kase1 - real(qp) :: ainvnm, scale, sl, smlnum, su + real(${rk}$) :: ainvnm, scale, sl, smlnum, su ! Local Arrays integer(ilp) :: isave(3) ! Intrinsic Functions @@ -4046,7 +4047,7 @@ module stdlib_linalg_lapack_q else if( anorm==zero ) then return end if - smlnum = stdlib_qlamch( 'SAFE MINIMUM' ) + smlnum = stdlib_${ri}$lamch( 'SAFE MINIMUM' ) ! estimate the norm of inv(a). ainvnm = zero normin = 'N' @@ -4057,30 +4058,30 @@ module stdlib_linalg_lapack_q end if kase = 0 10 continue - call stdlib_qlacn2( n, work( n+1 ), work, iwork, ainvnm, kase, isave ) + call stdlib_${ri}$lacn2( n, work( n+1 ), work, iwork, ainvnm, kase, isave ) if( kase/=0 ) then if( kase==kase1 ) then ! multiply by inv(l). - call stdlib_qlatrs( 'LOWER', 'NO TRANSPOSE', 'UNIT', normin, n, a,lda, work, sl, & + call stdlib_${ri}$latrs( 'LOWER', 'NO TRANSPOSE', 'UNIT', normin, n, a,lda, work, sl, & work( 2*n+1 ), info ) ! multiply by inv(u). - call stdlib_qlatrs( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', normin, n,a, lda, work, & + call stdlib_${ri}$latrs( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', normin, n,a, lda, work, & su, work( 3*n+1 ), info ) else ! multiply by inv(u**t). - call stdlib_qlatrs( 'UPPER', 'TRANSPOSE', 'NON-UNIT', normin, n, a,lda, work, su,& + call stdlib_${ri}$latrs( 'UPPER', 'TRANSPOSE', 'NON-UNIT', normin, n, a,lda, work, su,& work( 3*n+1 ), info ) ! multiply by inv(l**t). - call stdlib_qlatrs( 'LOWER', 'TRANSPOSE', 'UNIT', normin, n, a,lda, work, sl, & + call stdlib_${ri}$latrs( 'LOWER', 'TRANSPOSE', 'UNIT', normin, n, a,lda, work, sl, & work( 2*n+1 ), info ) end if ! divide x by 1/(sl*su) if doing so will not cause overflow. scale = sl*su normin = 'Y' if( scale/=one ) then - ix = stdlib_iqamax( n, work, 1 ) + ix = stdlib_i${ri}$amax( n, work, 1 ) if( scalezero .and. anrm0 )info = ieval ! sort eigenvalues if desired if( wantst .and. info==0 ) then if( scalea ) then - call stdlib_qlascl( 'G', 0, 0, cscale, anrm, n, 1, wr, n, ierr ) - call stdlib_qlascl( 'G', 0, 0, cscale, anrm, n, 1, wi, n, ierr ) + call stdlib_${ri}$lascl( 'G', 0, 0, cscale, anrm, n, 1, wr, n, ierr ) + call stdlib_${ri}$lascl( 'G', 0, 0, cscale, anrm, n, 1, wi, n, ierr ) end if do i = 1, n bwork( i ) = select( wr( i ), wi( i ) ) end do ! reorder eigenvalues and transform schur vectors ! (workspace: none needed) - call stdlib_qtrsen( 'N', jobvs, bwork, n, a, lda, vs, ldvs, wr, wi,sdim, s, sep, & + call stdlib_${ri}$trsen( 'N', jobvs, bwork, n, a, lda, vs, ldvs, wr, wi,sdim, s, sep, & work( iwrk ), lwork-iwrk+1, idum, 1,icond ) if( icond>0 )info = n + icond end if if( wantvs ) then ! undo balancing ! (workspace: need n) - call stdlib_qgebak( 'P', 'R', n, ilo, ihi, work( ibal ), n, vs, ldvs,ierr ) + call stdlib_${ri}$gebak( 'P', 'R', n, ilo, ihi, work( ibal ), n, vs, ldvs,ierr ) end if if( scalea ) then ! undo scaling for the schur form of a - call stdlib_qlascl( 'H', 0, 0, cscale, anrm, n, n, a, lda, ierr ) - call stdlib_qcopy( n, a, lda+1, wr, 1 ) + call stdlib_${ri}$lascl( 'H', 0, 0, cscale, anrm, n, n, a, lda, ierr ) + call stdlib_${ri}$copy( n, a, lda+1, wr, 1 ) if( cscale==smlnum ) then ! if scaling back towards underflow, adjust wi if an ! offdiagonal element of a 2-by-2 block in the schur form @@ -4527,7 +4528,7 @@ module stdlib_linalg_lapack_q if( ieval>0 ) then i1 = ieval + 1 i2 = ihi - 1 - call stdlib_qlascl( 'G', 0, 0, cscale, anrm, ilo-1, 1, wi,max( ilo-1, 1 ), & + call stdlib_${ri}$lascl( 'G', 0, 0, cscale, anrm, ilo-1, 1, wi,max( ilo-1, 1 ), & ierr ) else if( wantst ) then i1 = 1 @@ -4548,11 +4549,11 @@ module stdlib_linalg_lapack_q else if( a( i+1, i )/=zero .and. a( i, i+1 )==zero ) then wi( i ) = zero wi( i+1 ) = zero - if( i>1 )call stdlib_qswap( i-1, a( 1, i ), 1, a( 1, i+1 ), 1 ) - if( n>i+1 )call stdlib_qswap( n-i-1, a( i, i+2 ), lda,a( i+1, i+2 ), & + if( i>1 )call stdlib_${ri}$swap( i-1, a( 1, i ), 1, a( 1, i+1 ), 1 ) + if( n>i+1 )call stdlib_${ri}$swap( n-i-1, a( i, i+2 ), lda,a( i+1, i+2 ), & lda ) if( wantvs ) then - call stdlib_qswap( n, vs( 1, i ), 1, vs( 1, i+1 ), 1 ) + call stdlib_${ri}$swap( n, vs( 1, i ), 1, vs( 1, i+1 ), 1 ) end if a( i, i+1 ) = a( i+1, i ) a( i+1, i ) = zero @@ -4562,7 +4563,7 @@ module stdlib_linalg_lapack_q end do loop_20 end if ! undo scaling for the imaginary part of the eigenvalues - call stdlib_qlascl( 'G', 0, 0, cscale, anrm, n-ieval, 1,wi( ieval+1 ), max( n-ieval,& + call stdlib_${ri}$lascl( 'G', 0, 0, cscale, anrm, n-ieval, 1,wi( ieval+1 ), max( n-ieval,& 1 ), ierr ) end if if( wantst .and. info==0 ) then @@ -4596,10 +4597,10 @@ module stdlib_linalg_lapack_q end if work( 1 ) = maxwrk return - end subroutine stdlib_qgees + end subroutine stdlib_${ri}$gees - subroutine stdlib_qgeesx( jobvs, sort, select, sense, n, a, lda, sdim,wr, wi, vs, ldvs, & + subroutine stdlib_${ri}$geesx( jobvs, sort, select, sense, n, a, lda, sdim,wr, wi, vs, ldvs, & !! DGEESX: computes for an N-by-N real nonsymmetric matrix A, the !! eigenvalues, the real Schur form T, and, optionally, the matrix of !! Schur vectors Z. This gives the Schur factorization A = Z*T*(Z**T). @@ -4611,7 +4612,7 @@ module stdlib_linalg_lapack_q !! selected eigenvalues (RCONDV). The leading columns of Z form an !! orthonormal basis for this invariant subspace. !! For further explanation of the reciprocal condition numbers RCONDE - !! and RCONDV, see Section 4.10_qp of the LAPACK Users' Guide (where + !! and RCONDV, see Section 4.10_${rk}$ of the LAPACK Users' Guide (where !! these quantities are called s and sep respectively). !! A real matrix is in real Schur form if it is upper quasi-triangular !! with 1-by-1 and 2-by-2 blocks. 2-by-2 blocks will be standardized in @@ -4627,14 +4628,14 @@ module stdlib_linalg_lapack_q character, intent(in) :: jobvs, sense, sort integer(ilp), intent(out) :: info, sdim integer(ilp), intent(in) :: lda, ldvs, liwork, lwork, n - real(qp), intent(out) :: rconde, rcondv + real(${rk}$), intent(out) :: rconde, rcondv ! Array Arguments logical(lk), intent(out) :: bwork(*) integer(ilp), intent(out) :: iwork(*) - real(qp), intent(inout) :: a(lda,*) - real(qp), intent(out) :: vs(ldvs,*), wi(*), work(*), wr(*) + real(${rk}$), intent(inout) :: a(lda,*) + real(${rk}$), intent(out) :: vs(ldvs,*), wi(*), work(*), wr(*) ! Function Arguments - procedure(stdlib_select_q) :: select + procedure(stdlib_select_${ri}$) :: select ! ===================================================================== ! Local Scalars @@ -4642,9 +4643,9 @@ module stdlib_linalg_lapack_q wantsv, wantvs integer(ilp) :: hswork, i, i1, i2, ibal, icond, ierr, ieval, ihi, ilo, inxt, ip, itau, & iwrk, liwrk, lwrk, maxwrk, minwrk - real(qp) :: anrm, bignum, cscale, eps, smlnum + real(${rk}$) :: anrm, bignum, cscale, eps, smlnum ! Local Arrays - real(qp) :: dum(1) + real(${rk}$) :: dum(1) ! Intrinsic Functions intrinsic :: max,sqrt ! Executable Statements @@ -4678,11 +4679,11 @@ module stdlib_linalg_lapack_q ! iworkspace refers to integer workspace. ! nb refers to the optimal block size for the immediately ! following subroutine, as returned by stdlib_ilaenv. - ! hswork refers to the workspace preferred by stdlib_qhseqr, as + ! hswork refers to the workspace preferred by stdlib_${ri}$hseqr, as ! calculated below. hswork is computed assuming ilo=1 and ihi=n, ! the worst case. ! if sense = 'e', 'v' or 'b', then the amount of workspace needed - ! depends on sdim, which is computed by the routine stdlib_qtrsen later + ! depends on sdim, which is computed by the routine stdlib_${ri}$trsen later ! in the code.) if( info==0 ) then liwrk = 1 @@ -4692,7 +4693,7 @@ module stdlib_linalg_lapack_q else maxwrk = 2*n + n*stdlib_ilaenv( 1, 'DGEHRD', ' ', n, 1, n, 0 ) minwrk = 3*n - call stdlib_qhseqr( 'S', jobvs, n, 1, n, a, lda, wr, wi, vs, ldvs,work, -1, & + call stdlib_${ri}$hseqr( 'S', jobvs, n, 1, n, a, lda, wr, wi, vs, ldvs,work, -1, & ieval ) hswork = work( 1 ) if( .not.wantvs ) then @@ -4726,14 +4727,14 @@ module stdlib_linalg_lapack_q return end if ! get machine constants - eps = stdlib_qlamch( 'P' ) - smlnum = stdlib_qlamch( 'S' ) + eps = stdlib_${ri}$lamch( 'P' ) + smlnum = stdlib_${ri}$lamch( 'S' ) bignum = one / smlnum - call stdlib_qlabad( smlnum, bignum ) + call stdlib_${ri}$labad( smlnum, bignum ) smlnum = sqrt( smlnum ) / eps bignum = one / smlnum ! scale a if max element outside range [smlnum,bignum] - anrm = stdlib_qlange( 'M', n, n, a, lda, dum ) + anrm = stdlib_${ri}$lange( 'M', n, n, a, lda, dum ) scalea = .false. if( anrm>zero .and. anrm0 )info = ieval ! sort eigenvalues if desired if( wantst .and. info==0 ) then if( scalea ) then - call stdlib_qlascl( 'G', 0, 0, cscale, anrm, n, 1, wr, n, ierr ) - call stdlib_qlascl( 'G', 0, 0, cscale, anrm, n, 1, wi, n, ierr ) + call stdlib_${ri}$lascl( 'G', 0, 0, cscale, anrm, n, 1, wr, n, ierr ) + call stdlib_${ri}$lascl( 'G', 0, 0, cscale, anrm, n, 1, wi, n, ierr ) end if do i = 1, n bwork( i ) = select( wr( i ), wi( i ) ) @@ -4783,7 +4784,7 @@ module stdlib_linalg_lapack_q ! otherwise, need n ) ! (iworkspace: if sense is 'v' or 'b', need sdim*(n-sdim) ! otherwise, need 0 ) - call stdlib_qtrsen( sense, jobvs, bwork, n, a, lda, vs, ldvs, wr, wi,sdim, rconde, & + call stdlib_${ri}$trsen( sense, jobvs, bwork, n, a, lda, vs, ldvs, wr, wi,sdim, rconde, & rcondv, work( iwrk ), lwork-iwrk+1,iwork, liwork, icond ) if( .not.wantsn )maxwrk = max( maxwrk, n+2*sdim*( n-sdim ) ) if( icond==-15 ) then @@ -4793,22 +4794,22 @@ module stdlib_linalg_lapack_q ! not enough integer workspace info = -18 else if( icond>0 ) then - ! stdlib_qtrsen failed to reorder or to restore standard schur form + ! stdlib_${ri}$trsen failed to reorder or to restore standard schur form info = icond + n end if end if if( wantvs ) then ! undo balancing ! (rworkspace: need n) - call stdlib_qgebak( 'P', 'R', n, ilo, ihi, work( ibal ), n, vs, ldvs,ierr ) + call stdlib_${ri}$gebak( 'P', 'R', n, ilo, ihi, work( ibal ), n, vs, ldvs,ierr ) end if if( scalea ) then ! undo scaling for the schur form of a - call stdlib_qlascl( 'H', 0, 0, cscale, anrm, n, n, a, lda, ierr ) - call stdlib_qcopy( n, a, lda+1, wr, 1 ) + call stdlib_${ri}$lascl( 'H', 0, 0, cscale, anrm, n, n, a, lda, ierr ) + call stdlib_${ri}$copy( n, a, lda+1, wr, 1 ) if( ( wantsv .or. wantsb ) .and. info==0 ) then dum( 1 ) = rcondv - call stdlib_qlascl( 'G', 0, 0, cscale, anrm, 1, 1, dum, 1, ierr ) + call stdlib_${ri}$lascl( 'G', 0, 0, cscale, anrm, 1, 1, dum, 1, ierr ) rcondv = dum( 1 ) end if if( cscale==smlnum ) then @@ -4818,7 +4819,7 @@ module stdlib_linalg_lapack_q if( ieval>0 ) then i1 = ieval + 1 i2 = ihi - 1 - call stdlib_qlascl( 'G', 0, 0, cscale, anrm, ilo-1, 1, wi, n,ierr ) + call stdlib_${ri}$lascl( 'G', 0, 0, cscale, anrm, ilo-1, 1, wi, n,ierr ) else if( wantst ) then i1 = 1 i2 = n - 1 @@ -4838,11 +4839,11 @@ module stdlib_linalg_lapack_q else if( a( i+1, i )/=zero .and. a( i, i+1 )==zero ) then wi( i ) = zero wi( i+1 ) = zero - if( i>1 )call stdlib_qswap( i-1, a( 1, i ), 1, a( 1, i+1 ), 1 ) - if( n>i+1 )call stdlib_qswap( n-i-1, a( i, i+2 ), lda,a( i+1, i+2 ), & + if( i>1 )call stdlib_${ri}$swap( i-1, a( 1, i ), 1, a( 1, i+1 ), 1 ) + if( n>i+1 )call stdlib_${ri}$swap( n-i-1, a( i, i+2 ), lda,a( i+1, i+2 ), & lda ) if( wantvs ) then - call stdlib_qswap( n, vs( 1, i ), 1, vs( 1, i+1 ), 1 ) + call stdlib_${ri}$swap( n, vs( 1, i ), 1, vs( 1, i+1 ), 1 ) end if a( i, i+1 ) = a( i+1, i ) a( i+1, i ) = zero @@ -4851,7 +4852,7 @@ module stdlib_linalg_lapack_q end if end do loop_20 end if - call stdlib_qlascl( 'G', 0, 0, cscale, anrm, n-ieval, 1,wi( ieval+1 ), max( n-ieval,& + call stdlib_${ri}$lascl( 'G', 0, 0, cscale, anrm, n-ieval, 1,wi( ieval+1 ), max( n-ieval,& 1 ), ierr ) end if if( wantst .and. info==0 ) then @@ -4890,10 +4891,10 @@ module stdlib_linalg_lapack_q iwork( 1 ) = 1 end if return - end subroutine stdlib_qgeesx + end subroutine stdlib_${ri}$geesx - subroutine stdlib_qgeev( jobvl, jobvr, n, a, lda, wr, wi, vl, ldvl, vr,ldvr, work, lwork, & + subroutine stdlib_${ri}$geev( jobvl, jobvr, n, a, lda, wr, wi, vl, ldvl, vr,ldvr, work, lwork, & !! DGEEV: computes for an N-by-N real nonsymmetric matrix A, the !! eigenvalues and, optionally, the left and/or right eigenvectors. !! The right eigenvector v(j) of A satisfies @@ -4913,8 +4914,8 @@ module stdlib_linalg_lapack_q integer(ilp), intent(out) :: info integer(ilp), intent(in) :: lda, ldvl, ldvr, lwork, n ! Array Arguments - real(qp), intent(inout) :: a(lda,*) - real(qp), intent(out) :: vl(ldvl,*), vr(ldvr,*), wi(*), work(*), wr(*) + real(${rk}$), intent(inout) :: a(lda,*) + real(${rk}$), intent(out) :: vl(ldvl,*), vr(ldvr,*), wi(*), work(*), wr(*) ! ===================================================================== ! Local Scalars @@ -4922,10 +4923,10 @@ module stdlib_linalg_lapack_q character :: side integer(ilp) :: hswork, i, ibal, ierr, ihi, ilo, itau, iwrk, k, lwork_trevc, maxwrk, & minwrk, nout - real(qp) :: anrm, bignum, cs, cscale, eps, r, scl, smlnum, sn + real(${rk}$) :: anrm, bignum, cs, cscale, eps, r, scl, smlnum, sn ! Local Arrays logical(lk) :: select(1) - real(qp) :: dum(1) + real(${rk}$) :: dum(1) ! Intrinsic Functions intrinsic :: max,sqrt ! Executable Statements @@ -4953,7 +4954,7 @@ module stdlib_linalg_lapack_q ! as well as the preferred amount for good performance. ! nb refers to the optimal block size for the immediately ! following subroutine, as returned by stdlib_ilaenv. - ! hswork refers to the workspace preferred by stdlib_qhseqr, as + ! hswork refers to the workspace preferred by stdlib_${ri}$hseqr, as ! calculated below. hswork is computed assuming ilo=1 and ihi=n, ! the worst case.) if( info==0 ) then @@ -4966,11 +4967,11 @@ module stdlib_linalg_lapack_q minwrk = 4*n maxwrk = max( maxwrk, 2*n + ( n - 1 )*stdlib_ilaenv( 1,'DORGHR', ' ', n, 1, n,& -1 ) ) - call stdlib_qhseqr( 'S', 'V', n, 1, n, a, lda, wr, wi, vl, ldvl,work, -1, & + call stdlib_${ri}$hseqr( 'S', 'V', n, 1, n, a, lda, wr, wi, vl, ldvl,work, -1, & info ) hswork = int( work(1),KIND=ilp) maxwrk = max( maxwrk, n + 1, n + hswork ) - call stdlib_qtrevc3( 'L', 'B', select, n, a, lda,vl, ldvl, vr, ldvr, n, nout,& + call stdlib_${ri}$trevc3( 'L', 'B', select, n, a, lda,vl, ldvl, vr, ldvr, n, nout,& work, -1, ierr ) lwork_trevc = int( work(1),KIND=ilp) maxwrk = max( maxwrk, n + lwork_trevc ) @@ -4979,18 +4980,18 @@ module stdlib_linalg_lapack_q minwrk = 4*n maxwrk = max( maxwrk, 2*n + ( n - 1 )*stdlib_ilaenv( 1,'DORGHR', ' ', n, 1, n,& -1 ) ) - call stdlib_qhseqr( 'S', 'V', n, 1, n, a, lda, wr, wi, vr, ldvr,work, -1, & + call stdlib_${ri}$hseqr( 'S', 'V', n, 1, n, a, lda, wr, wi, vr, ldvr,work, -1, & info ) hswork = int( work(1),KIND=ilp) maxwrk = max( maxwrk, n + 1, n + hswork ) - call stdlib_qtrevc3( 'R', 'B', select, n, a, lda,vl, ldvl, vr, ldvr, n, nout,& + call stdlib_${ri}$trevc3( 'R', 'B', select, n, a, lda,vl, ldvl, vr, ldvr, n, nout,& work, -1, ierr ) lwork_trevc = int( work(1),KIND=ilp) maxwrk = max( maxwrk, n + lwork_trevc ) maxwrk = max( maxwrk, 4*n ) else minwrk = 3*n - call stdlib_qhseqr( 'E', 'N', n, 1, n, a, lda, wr, wi, vr, ldvr,work, -1, & + call stdlib_${ri}$hseqr( 'E', 'N', n, 1, n, a, lda, wr, wi, vr, ldvr,work, -1, & info ) hswork = int( work(1),KIND=ilp) maxwrk = max( maxwrk, n + 1, n + hswork ) @@ -5011,14 +5012,14 @@ module stdlib_linalg_lapack_q ! quick return if possible if( n==0 )return ! get machine constants - eps = stdlib_qlamch( 'P' ) - smlnum = stdlib_qlamch( 'S' ) + eps = stdlib_${ri}$lamch( 'P' ) + smlnum = stdlib_${ri}$lamch( 'S' ) bignum = one / smlnum - call stdlib_qlabad( smlnum, bignum ) + call stdlib_${ri}$labad( smlnum, bignum ) smlnum = sqrt( smlnum ) / eps bignum = one / smlnum ! scale a if max element outside range [smlnum,bignum] - anrm = stdlib_qlange( 'M', n, n, a, lda, dum ) + anrm = stdlib_${ri}$lange( 'M', n, n, a, lda, dum ) scalea = .false. if( anrm>zero .and. anrmzero ) then - scl = one / stdlib_qlapy2( stdlib_qnrm2( n, vl( 1, i ), 1 ),stdlib_qnrm2( n, & + scl = one / stdlib_${ri}$lapy2( stdlib_${ri}$nrm2( n, vl( 1, i ), 1 ),stdlib_${ri}$nrm2( n, & vl( 1, i+1 ), 1 ) ) - call stdlib_qscal( n, scl, vl( 1, i ), 1 ) - call stdlib_qscal( n, scl, vl( 1, i+1 ), 1 ) + call stdlib_${ri}$scal( n, scl, vl( 1, i ), 1 ) + call stdlib_${ri}$scal( n, scl, vl( 1, i+1 ), 1 ) do k = 1, n work( iwrk+k-1 ) = vl( k, i )**2 + vl( k, i+1 )**2 end do - k = stdlib_iqamax( n, work( iwrk ), 1 ) - call stdlib_qlartg( vl( k, i ), vl( k, i+1 ), cs, sn, r ) - call stdlib_qrot( n, vl( 1, i ), 1, vl( 1, i+1 ), 1, cs, sn ) + k = stdlib_i${ri}$amax( n, work( iwrk ), 1 ) + call stdlib_${ri}$lartg( vl( k, i ), vl( k, i+1 ), cs, sn, r ) + call stdlib_${ri}$rot( n, vl( 1, i ), 1, vl( 1, i+1 ), 1, cs, sn ) vl( k, i+1 ) = zero end if end do @@ -5114,23 +5115,23 @@ module stdlib_linalg_lapack_q if( wantvr ) then ! undo balancing of right eigenvectors ! (workspace: need n) - call stdlib_qgebak( 'B', 'R', n, ilo, ihi, work( ibal ), n, vr, ldvr,ierr ) + call stdlib_${ri}$gebak( 'B', 'R', n, ilo, ihi, work( ibal ), n, vr, ldvr,ierr ) ! normalize right eigenvectors and make largest component real do i = 1, n if( wi( i )==zero ) then - scl = one / stdlib_qnrm2( n, vr( 1, i ), 1 ) - call stdlib_qscal( n, scl, vr( 1, i ), 1 ) + scl = one / stdlib_${ri}$nrm2( n, vr( 1, i ), 1 ) + call stdlib_${ri}$scal( n, scl, vr( 1, i ), 1 ) else if( wi( i )>zero ) then - scl = one / stdlib_qlapy2( stdlib_qnrm2( n, vr( 1, i ), 1 ),stdlib_qnrm2( n, & + scl = one / stdlib_${ri}$lapy2( stdlib_${ri}$nrm2( n, vr( 1, i ), 1 ),stdlib_${ri}$nrm2( n, & vr( 1, i+1 ), 1 ) ) - call stdlib_qscal( n, scl, vr( 1, i ), 1 ) - call stdlib_qscal( n, scl, vr( 1, i+1 ), 1 ) + call stdlib_${ri}$scal( n, scl, vr( 1, i ), 1 ) + call stdlib_${ri}$scal( n, scl, vr( 1, i+1 ), 1 ) do k = 1, n work( iwrk+k-1 ) = vr( k, i )**2 + vr( k, i+1 )**2 end do - k = stdlib_iqamax( n, work( iwrk ), 1 ) - call stdlib_qlartg( vr( k, i ), vr( k, i+1 ), cs, sn, r ) - call stdlib_qrot( n, vr( 1, i ), 1, vr( 1, i+1 ), 1, cs, sn ) + k = stdlib_i${ri}$amax( n, work( iwrk ), 1 ) + call stdlib_${ri}$lartg( vr( k, i ), vr( k, i+1 ), cs, sn, r ) + call stdlib_${ri}$rot( n, vr( 1, i ), 1, vr( 1, i+1 ), 1, cs, sn ) vr( k, i+1 ) = zero end if end do @@ -5138,21 +5139,21 @@ module stdlib_linalg_lapack_q ! undo scaling if necessary 50 continue if( scalea ) then - call stdlib_qlascl( 'G', 0, 0, cscale, anrm, n-info, 1, wr( info+1 ),max( n-info, 1 & + call stdlib_${ri}$lascl( 'G', 0, 0, cscale, anrm, n-info, 1, wr( info+1 ),max( n-info, 1 & ), ierr ) - call stdlib_qlascl( 'G', 0, 0, cscale, anrm, n-info, 1, wi( info+1 ),max( n-info, 1 & + call stdlib_${ri}$lascl( 'G', 0, 0, cscale, anrm, n-info, 1, wi( info+1 ),max( n-info, 1 & ), ierr ) if( info>0 ) then - call stdlib_qlascl( 'G', 0, 0, cscale, anrm, ilo-1, 1, wr, n,ierr ) - call stdlib_qlascl( 'G', 0, 0, cscale, anrm, ilo-1, 1, wi, n,ierr ) + call stdlib_${ri}$lascl( 'G', 0, 0, cscale, anrm, ilo-1, 1, wr, n,ierr ) + call stdlib_${ri}$lascl( 'G', 0, 0, cscale, anrm, ilo-1, 1, wi, n,ierr ) end if end if work( 1 ) = maxwrk return - end subroutine stdlib_qgeev + end subroutine stdlib_${ri}$geev - subroutine stdlib_qgeevx( balanc, jobvl, jobvr, sense, n, a, lda, wr, wi,vl, ldvl, vr, ldvr, & + subroutine stdlib_${ri}$geevx( balanc, jobvl, jobvr, sense, n, a, lda, wr, wi,vl, ldvl, vr, ldvr, & !! DGEEVX: computes for an N-by-N real nonsymmetric matrix A, the !! eigenvalues and, optionally, the left and/or right eigenvectors. !! Optionally also, it computes a balancing transformation to improve @@ -5176,7 +5177,7 @@ module stdlib_linalg_lapack_q !! reciprocal condition numbers correspond to the balanced matrix. !! Permuting rows and columns will not change the condition numbers !! (in exact arithmetic) but diagonal scaling will. For further - !! explanation of balancing, see section 4.10.2_qp of the LAPACK + !! explanation of balancing, see section 4.10.2_${rk}$ of the LAPACK !! Users' Guide. ilo, ihi, scale, abnrm,rconde, rcondv, work, lwork, iwork, info ) ! -- lapack driver routine -- @@ -5186,11 +5187,11 @@ module stdlib_linalg_lapack_q character, intent(in) :: balanc, jobvl, jobvr, sense integer(ilp), intent(out) :: ihi, ilo, info integer(ilp), intent(in) :: lda, ldvl, ldvr, lwork, n - real(qp), intent(out) :: abnrm + real(${rk}$), intent(out) :: abnrm ! Array Arguments integer(ilp), intent(out) :: iwork(*) - real(qp), intent(inout) :: a(lda,*) - real(qp), intent(out) :: rconde(*), rcondv(*), scale(*), vl(ldvl,*), vr(ldvr,*), wi(*),& + real(${rk}$), intent(inout) :: a(lda,*) + real(${rk}$), intent(out) :: rconde(*), rcondv(*), scale(*), vl(ldvl,*), vr(ldvr,*), wi(*),& work(*), wr(*) ! ===================================================================== @@ -5199,10 +5200,10 @@ module stdlib_linalg_lapack_q character :: job, side integer(ilp) :: hswork, i, icond, ierr, itau, iwrk, k, lwork_trevc, maxwrk, minwrk, & nout - real(qp) :: anrm, bignum, cs, cscale, eps, r, scl, smlnum, sn + real(${rk}$) :: anrm, bignum, cs, cscale, eps, r, scl, smlnum, sn ! Local Arrays logical(lk) :: select(1) - real(qp) :: dum(1) + real(${rk}$) :: dum(1) ! Intrinsic Functions intrinsic :: max,sqrt ! Executable Statements @@ -5240,7 +5241,7 @@ module stdlib_linalg_lapack_q ! as well as the preferred amount for good performance. ! nb refers to the optimal block size for the immediately ! following subroutine, as returned by stdlib_ilaenv. - ! hswork refers to the workspace preferred by stdlib_qhseqr, as + ! hswork refers to the workspace preferred by stdlib_${ri}$hseqr, as ! calculated below. hswork is computed assuming ilo=1 and ihi=n, ! the worst case.) if( info==0 ) then @@ -5250,25 +5251,25 @@ module stdlib_linalg_lapack_q else maxwrk = n + n*stdlib_ilaenv( 1, 'DGEHRD', ' ', n, 1, n, 0 ) if( wantvl ) then - call stdlib_qtrevc3( 'L', 'B', select, n, a, lda,vl, ldvl, vr, ldvr,n, nout, & + call stdlib_${ri}$trevc3( 'L', 'B', select, n, a, lda,vl, ldvl, vr, ldvr,n, nout, & work, -1, ierr ) lwork_trevc = int( work(1),KIND=ilp) maxwrk = max( maxwrk, n + lwork_trevc ) - call stdlib_qhseqr( 'S', 'V', n, 1, n, a, lda, wr, wi, vl, ldvl,work, -1, & + call stdlib_${ri}$hseqr( 'S', 'V', n, 1, n, a, lda, wr, wi, vl, ldvl,work, -1, & info ) else if( wantvr ) then - call stdlib_qtrevc3( 'R', 'B', select, n, a, lda,vl, ldvl, vr, ldvr,n, nout, & + call stdlib_${ri}$trevc3( 'R', 'B', select, n, a, lda,vl, ldvl, vr, ldvr,n, nout, & work, -1, ierr ) lwork_trevc = int( work(1),KIND=ilp) maxwrk = max( maxwrk, n + lwork_trevc ) - call stdlib_qhseqr( 'S', 'V', n, 1, n, a, lda, wr, wi, vr, ldvr,work, -1, & + call stdlib_${ri}$hseqr( 'S', 'V', n, 1, n, a, lda, wr, wi, vr, ldvr,work, -1, & info ) else if( wntsnn ) then - call stdlib_qhseqr( 'E', 'N', n, 1, n, a, lda, wr, wi, vr,ldvr, work, -1, & + call stdlib_${ri}$hseqr( 'E', 'N', n, 1, n, a, lda, wr, wi, vr,ldvr, work, -1, & info ) else - call stdlib_qhseqr( 'S', 'N', n, 1, n, a, lda, wr, wi, vr,ldvr, work, -1, & + call stdlib_${ri}$hseqr( 'S', 'N', n, 1, n, a, lda, wr, wi, vr,ldvr, work, -1, & info ) end if end if @@ -5305,15 +5306,15 @@ module stdlib_linalg_lapack_q ! quick return if possible if( n==0 )return ! get machine constants - eps = stdlib_qlamch( 'P' ) - smlnum = stdlib_qlamch( 'S' ) + eps = stdlib_${ri}$lamch( 'P' ) + smlnum = stdlib_${ri}$lamch( 'S' ) bignum = one / smlnum - call stdlib_qlabad( smlnum, bignum ) + call stdlib_${ri}$labad( smlnum, bignum ) smlnum = sqrt( smlnum ) / eps bignum = one / smlnum ! scale a if max element outside range [smlnum,bignum] icond = 0 - anrm = stdlib_qlange( 'M', n, n, a, lda, dum ) + anrm = stdlib_${ri}$lange( 'M', n, n, a, lda, dum ) scalea = .false. if( anrm>zero .and. anrmzero ) then - scl = one / stdlib_qlapy2( stdlib_qnrm2( n, vl( 1, i ), 1 ),stdlib_qnrm2( n, & + scl = one / stdlib_${ri}$lapy2( stdlib_${ri}$nrm2( n, vl( 1, i ), 1 ),stdlib_${ri}$nrm2( n, & vl( 1, i+1 ), 1 ) ) - call stdlib_qscal( n, scl, vl( 1, i ), 1 ) - call stdlib_qscal( n, scl, vl( 1, i+1 ), 1 ) + call stdlib_${ri}$scal( n, scl, vl( 1, i ), 1 ) + call stdlib_${ri}$scal( n, scl, vl( 1, i+1 ), 1 ) do k = 1, n work( k ) = vl( k, i )**2 + vl( k, i+1 )**2 end do - k = stdlib_iqamax( n, work, 1 ) - call stdlib_qlartg( vl( k, i ), vl( k, i+1 ), cs, sn, r ) - call stdlib_qrot( n, vl( 1, i ), 1, vl( 1, i+1 ), 1, cs, sn ) + k = stdlib_i${ri}$amax( n, work, 1 ) + call stdlib_${ri}$lartg( vl( k, i ), vl( k, i+1 ), cs, sn, r ) + call stdlib_${ri}$rot( n, vl( 1, i ), 1, vl( 1, i+1 ), 1, cs, sn ) vl( k, i+1 ) = zero end if end do end if if( wantvr ) then ! undo balancing of right eigenvectors - call stdlib_qgebak( balanc, 'R', n, ilo, ihi, scale, n, vr, ldvr,ierr ) + call stdlib_${ri}$gebak( balanc, 'R', n, ilo, ihi, scale, n, vr, ldvr,ierr ) ! normalize right eigenvectors and make largest component real do i = 1, n if( wi( i )==zero ) then - scl = one / stdlib_qnrm2( n, vr( 1, i ), 1 ) - call stdlib_qscal( n, scl, vr( 1, i ), 1 ) + scl = one / stdlib_${ri}$nrm2( n, vr( 1, i ), 1 ) + call stdlib_${ri}$scal( n, scl, vr( 1, i ), 1 ) else if( wi( i )>zero ) then - scl = one / stdlib_qlapy2( stdlib_qnrm2( n, vr( 1, i ), 1 ),stdlib_qnrm2( n, & + scl = one / stdlib_${ri}$lapy2( stdlib_${ri}$nrm2( n, vr( 1, i ), 1 ),stdlib_${ri}$nrm2( n, & vr( 1, i+1 ), 1 ) ) - call stdlib_qscal( n, scl, vr( 1, i ), 1 ) - call stdlib_qscal( n, scl, vr( 1, i+1 ), 1 ) + call stdlib_${ri}$scal( n, scl, vr( 1, i ), 1 ) + call stdlib_${ri}$scal( n, scl, vr( 1, i+1 ), 1 ) do k = 1, n work( k ) = vr( k, i )**2 + vr( k, i+1 )**2 end do - k = stdlib_iqamax( n, work, 1 ) - call stdlib_qlartg( vr( k, i ), vr( k, i+1 ), cs, sn, r ) - call stdlib_qrot( n, vr( 1, i ), 1, vr( 1, i+1 ), 1, cs, sn ) + k = stdlib_i${ri}$amax( n, work, 1 ) + call stdlib_${ri}$lartg( vr( k, i ), vr( k, i+1 ), cs, sn, r ) + call stdlib_${ri}$rot( n, vr( 1, i ), 1, vr( 1, i+1 ), 1, cs, sn ) vr( k, i+1 ) = zero end if end do @@ -5447,24 +5448,24 @@ module stdlib_linalg_lapack_q ! undo scaling if necessary 50 continue if( scalea ) then - call stdlib_qlascl( 'G', 0, 0, cscale, anrm, n-info, 1, wr( info+1 ),max( n-info, 1 & + call stdlib_${ri}$lascl( 'G', 0, 0, cscale, anrm, n-info, 1, wr( info+1 ),max( n-info, 1 & ), ierr ) - call stdlib_qlascl( 'G', 0, 0, cscale, anrm, n-info, 1, wi( info+1 ),max( n-info, 1 & + call stdlib_${ri}$lascl( 'G', 0, 0, cscale, anrm, n-info, 1, wi( info+1 ),max( n-info, 1 & ), ierr ) if( info==0 ) then - if( ( wntsnv .or. wntsnb ) .and. icond==0 )call stdlib_qlascl( 'G', 0, 0, cscale,& + if( ( wntsnv .or. wntsnb ) .and. icond==0 )call stdlib_${ri}$lascl( 'G', 0, 0, cscale,& anrm, n, 1, rcondv, n,ierr ) else - call stdlib_qlascl( 'G', 0, 0, cscale, anrm, ilo-1, 1, wr, n,ierr ) - call stdlib_qlascl( 'G', 0, 0, cscale, anrm, ilo-1, 1, wi, n,ierr ) + call stdlib_${ri}$lascl( 'G', 0, 0, cscale, anrm, ilo-1, 1, wr, n,ierr ) + call stdlib_${ri}$lascl( 'G', 0, 0, cscale, anrm, ilo-1, 1, wi, n,ierr ) end if end if work( 1 ) = maxwrk return - end subroutine stdlib_qgeevx + end subroutine stdlib_${ri}$geevx - pure subroutine stdlib_qgehd2( n, ilo, ihi, a, lda, tau, work, info ) + pure subroutine stdlib_${ri}$gehd2( n, ilo, ihi, a, lda, tau, work, info ) !! DGEHD2: reduces a real general matrix A to upper Hessenberg form H by !! an orthogonal similarity transformation: Q**T * A * Q = H . ! -- lapack computational routine -- @@ -5474,13 +5475,13 @@ module stdlib_linalg_lapack_q integer(ilp), intent(in) :: ihi, ilo, lda, n integer(ilp), intent(out) :: info ! Array Arguments - real(qp), intent(inout) :: a(lda,*) - real(qp), intent(out) :: tau(*), work(*) + real(${rk}$), intent(inout) :: a(lda,*) + real(${rk}$), intent(out) :: tau(*), work(*) ! ===================================================================== ! Local Scalars integer(ilp) :: i - real(qp) :: aii + real(${rk}$) :: aii ! Intrinsic Functions intrinsic :: max,min ! Executable Statements @@ -5501,22 +5502,22 @@ module stdlib_linalg_lapack_q end if do i = ilo, ihi - 1 ! compute elementary reflector h(i) to annihilate a(i+2:ihi,i) - call stdlib_qlarfg( ihi-i, a( i+1, i ), a( min( i+2, n ), i ), 1,tau( i ) ) + call stdlib_${ri}$larfg( ihi-i, a( i+1, i ), a( min( i+2, n ), i ), 1,tau( i ) ) aii = a( i+1, i ) a( i+1, i ) = one ! apply h(i) to a(1:ihi,i+1:ihi) from the right - call stdlib_qlarf( 'RIGHT', ihi, ihi-i, a( i+1, i ), 1, tau( i ),a( 1, i+1 ), lda, & + call stdlib_${ri}$larf( 'RIGHT', ihi, ihi-i, a( i+1, i ), 1, tau( i ),a( 1, i+1 ), lda, & work ) ! apply h(i) to a(i+1:ihi,i+1:n) from the left - call stdlib_qlarf( 'LEFT', ihi-i, n-i, a( i+1, i ), 1, tau( i ),a( i+1, i+1 ), lda, & + call stdlib_${ri}$larf( 'LEFT', ihi-i, n-i, a( i+1, i ), 1, tau( i ),a( i+1, i+1 ), lda, & work ) a( i+1, i ) = aii end do return - end subroutine stdlib_qgehd2 + end subroutine stdlib_${ri}$gehd2 - pure subroutine stdlib_qgehrd( n, ilo, ihi, a, lda, tau, work, lwork, info ) + pure subroutine stdlib_${ri}$gehrd( n, ilo, ihi, a, lda, tau, work, lwork, info ) !! DGEHRD: reduces a real general matrix A to upper Hessenberg form H by !! an orthogonal similarity transformation: Q**T * A * Q = H . ! -- lapack computational routine -- @@ -5526,8 +5527,8 @@ module stdlib_linalg_lapack_q integer(ilp), intent(in) :: ihi, ilo, lda, lwork, n integer(ilp), intent(out) :: info ! Array Arguments - real(qp), intent(inout) :: a(lda,*) - real(qp), intent(out) :: tau(*), work(*) + real(${rk}$), intent(inout) :: a(lda,*) + real(${rk}$), intent(out) :: tau(*), work(*) ! ===================================================================== ! Parameters integer(ilp), parameter :: nbmax = 64 @@ -5538,7 +5539,7 @@ module stdlib_linalg_lapack_q ! Local Scalars logical(lk) :: lquery integer(ilp) :: i, ib, iinfo, iwt, j, ldwork, lwkopt, nb, nbmin, nh, nx - real(qp) :: ei + real(${rk}$) :: ei ! Intrinsic Functions intrinsic :: max,min ! Executable Statements @@ -5615,37 +5616,37 @@ module stdlib_linalg_lapack_q ! reduce columns i:i+ib-1 to hessenberg form, returning the ! matrices v and t of the block reflector h = i - v*t*v**t ! which performs the reduction, and also the matrix y = a*v*t - call stdlib_qlahr2( ihi, i, ib, a( 1, i ), lda, tau( i ),work( iwt ), ldt, work, & + call stdlib_${ri}$lahr2( ihi, i, ib, a( 1, i ), lda, tau( i ),work( iwt ), ldt, work, & ldwork ) ! apply the block reflector h to a(1:ihi,i+ib:ihi) from the ! right, computing a := a - y * v**t. v(i+ib,ib-1) must be set ! to 1 ei = a( i+ib, i+ib-1 ) a( i+ib, i+ib-1 ) = one - call stdlib_qgemm( 'NO TRANSPOSE', 'TRANSPOSE',ihi, ihi-i-ib+1,ib, -one, work, & + call stdlib_${ri}$gemm( 'NO TRANSPOSE', 'TRANSPOSE',ihi, ihi-i-ib+1,ib, -one, work, & ldwork, a( i+ib, i ), lda, one,a( 1, i+ib ), lda ) a( i+ib, i+ib-1 ) = ei ! apply the block reflector h to a(1:i,i+1:i+ib-1) from the ! right - call stdlib_qtrmm( 'RIGHT', 'LOWER', 'TRANSPOSE','UNIT', i, ib-1,one, a( i+1, i )& + call stdlib_${ri}$trmm( 'RIGHT', 'LOWER', 'TRANSPOSE','UNIT', i, ib-1,one, a( i+1, i )& , lda, work, ldwork ) do j = 0, ib-2 - call stdlib_qaxpy( i, -one, work( ldwork*j+1 ), 1,a( 1, i+j+1 ), 1 ) + call stdlib_${ri}$axpy( i, -one, work( ldwork*j+1 ), 1,a( 1, i+j+1 ), 1 ) end do ! apply the block reflector h to a(i+1:ihi,i+ib:n) from the ! left - call stdlib_qlarfb( 'LEFT', 'TRANSPOSE', 'FORWARD','COLUMNWISE',ihi-i, n-i-ib+1, & + call stdlib_${ri}$larfb( 'LEFT', 'TRANSPOSE', 'FORWARD','COLUMNWISE',ihi-i, n-i-ib+1, & ib, a( i+1, i ), lda,work( iwt ), ldt, a( i+1, i+ib ), lda,work, ldwork ) end do end if ! use unblocked code to reduce the rest of the matrix - call stdlib_qgehd2( n, i, ihi, a, lda, tau, work, iinfo ) + call stdlib_${ri}$gehd2( n, i, ihi, a, lda, tau, work, iinfo ) work( 1 ) = lwkopt return - end subroutine stdlib_qgehrd + end subroutine stdlib_${ri}$gehrd - pure subroutine stdlib_qgejsv( joba, jobu, jobv, jobr, jobt, jobp,m, n, a, lda, sva, u, ldu, & + pure subroutine stdlib_${ri}$gejsv( joba, jobu, jobv, jobr, jobt, jobp,m, n, a, lda, sva, u, ldu, & !! DGEJSV: computes the singular value decomposition (SVD) of a real M-by-N !! matrix [A], where M >= N. The SVD of [A] is written as !! [A] = [U] * [SIGMA] * [V]^t, @@ -5666,14 +5667,14 @@ module stdlib_linalg_lapack_q integer(ilp), intent(out) :: info integer(ilp), intent(in) :: lda, ldu, ldv, lwork, m, n ! Array Arguments - real(qp), intent(inout) :: a(lda,*) - real(qp), intent(out) :: sva(n), u(ldu,*), v(ldv,*), work(lwork) + real(${rk}$), intent(inout) :: a(lda,*) + real(${rk}$), intent(out) :: sva(n), u(ldu,*), v(ldv,*), work(lwork) integer(ilp), intent(out) :: iwork(*) character, intent(in) :: joba, jobp, jobr, jobt, jobu, jobv ! =========================================================================== ! Local Scalars - real(qp) :: aapp, aaqq, aatmax, aatmin, big, big1, cond_ok, condr1, condr2, entra, & + real(${rk}$) :: aapp, aaqq, aatmax, aatmin, big, big1, cond_ok, condr1, condr2, entra, & entrat, epsln, maxprj, scalem, sconda, sfmin, small, temp1, uscal1, uscal2, xsc integer(ilp) :: ierr, n1, nr, numrank, p, q, warning logical(lk) :: almort, defr, errest, goscal, jracc, kill, lsvec, l2aber, l2kill, & @@ -5746,23 +5747,23 @@ module stdlib_linalg_lapack_q if ( stdlib_lsame( jobu, 'F' ) ) n1 = m end if ! set numerical parameters - ! ! note: make sure stdlib_qlamch() does not fail on the target architecture. - epsln = stdlib_qlamch('EPSILON') - sfmin = stdlib_qlamch('SAFEMINIMUM') + ! ! note: make sure stdlib_${ri}$lamch() does not fail on the target architecture. + epsln = stdlib_${ri}$lamch('EPSILON') + sfmin = stdlib_${ri}$lamch('SAFEMINIMUM') small = sfmin / epsln - big = stdlib_qlamch('O') + big = stdlib_${ri}$lamch('O') ! big = one / sfmin ! initialize sva(1:n) = diag( ||a e_i||_2 )_1^n ! (!) if necessary, scale sva() to protect the largest norm from ! overflow. it is possible that this scaling pushes the smallest ! column norm left from the underflow threshold (extreme case). - scalem = one / sqrt(real(m,KIND=qp)*real(n,KIND=qp)) + scalem = one / sqrt(real(m,KIND=${rk}$)*real(n,KIND=${rk}$)) noscal = .true. goscal = .true. do p = 1, n aapp = zero aaqq = one - call stdlib_qlassq( m, a(1,p), 1, aapp, aaqq ) + call stdlib_${ri}$lassq( m, a(1,p), 1, aapp, aaqq ) if ( aapp > big ) then info = - 9 call stdlib_xerbla( 'DGEJSV', -info ) @@ -5776,7 +5777,7 @@ module stdlib_linalg_lapack_q sva(p) = aapp * ( aaqq * scalem ) if ( goscal ) then goscal = .false. - call stdlib_qscal( p-1, scalem, sva, 1 ) + call stdlib_${ri}$scal( p-1, scalem, sva, 1 ) end if end if end do @@ -5790,8 +5791,8 @@ module stdlib_linalg_lapack_q ! quick return for zero m x n matrix ! #:) if ( aapp == zero ) then - if ( lsvec ) call stdlib_qlaset( 'G', m, n1, zero, one, u, ldu ) - if ( rsvec ) call stdlib_qlaset( 'G', n, n, zero, one, v, ldv ) + if ( lsvec ) call stdlib_${ri}$laset( 'G', m, n1, zero, one, u, ldu ) + if ( rsvec ) call stdlib_${ri}$laset( 'G', n, n, zero, one, v, ldv ) work(1) = one work(2) = one if ( errest ) work(3) = one @@ -5822,13 +5823,13 @@ module stdlib_linalg_lapack_q ! #:) if ( n == 1 ) then if ( lsvec ) then - call stdlib_qlascl( 'G',0,0,sva(1),scalem, m,1,a(1,1),lda,ierr ) - call stdlib_qlacpy( 'A', m, 1, a, lda, u, ldu ) + call stdlib_${ri}$lascl( 'G',0,0,sva(1),scalem, m,1,a(1,1),lda,ierr ) + call stdlib_${ri}$lacpy( 'A', m, 1, a, lda, u, ldu ) ! computing all m left singular vectors of the m x 1 matrix if ( n1 /= n ) then - call stdlib_qgeqrf( m, n, u,ldu, work, work(n+1),lwork-n,ierr ) - call stdlib_qorgqr( m,n1,1, u,ldu,work,work(n+1),lwork-n,ierr ) - call stdlib_qcopy( m, a(1,1), 1, u(1,1), 1 ) + call stdlib_${ri}$geqrf( m, n, u,ldu, work, work(n+1),lwork-n,ierr ) + call stdlib_${ri}$orgqr( m,n1,1, u,ldu,work,work(n+1),lwork-n,ierr ) + call stdlib_${ri}$copy( m, a(1,1), 1, u(1,1), 1 ) end if end if if ( rsvec ) then @@ -5876,8 +5877,8 @@ module stdlib_linalg_lapack_q do p = 1, m xsc = zero temp1 = one - call stdlib_qlassq( n, a(p,1), lda, xsc, temp1 ) - ! stdlib_qlassq gets both the ell_2 and the ell_infinity norm + call stdlib_${ri}$lassq( n, a(p,1), lda, xsc, temp1 ) + ! stdlib_${ri}$lassq gets both the ell_2 and the ell_infinity norm ! in one pass through the vector work(m+n+p) = xsc * scalem work(n+p) = xsc * (scalem*sqrt(temp1)) @@ -5886,7 +5887,7 @@ module stdlib_linalg_lapack_q end do else do p = 1, m - work(m+n+p) = scalem*abs( a(p,stdlib_iqamax(n,a(p,1),lda)) ) + work(m+n+p) = scalem*abs( a(p,stdlib_i${ri}$amax(n,a(p,1),lda)) ) aatmax = max( aatmax, work(m+n+p) ) aatmin = min( aatmin, work(m+n+p) ) end do @@ -5903,14 +5904,14 @@ module stdlib_linalg_lapack_q if ( l2tran ) then xsc = zero temp1 = one - call stdlib_qlassq( n, sva, 1, xsc, temp1 ) + call stdlib_${ri}$lassq( n, sva, 1, xsc, temp1 ) temp1 = one / temp1 entra = zero do p = 1, n big1 = ( ( sva(p) / xsc )**2 ) * temp1 if ( big1 /= zero ) entra = entra + big1 * log(big1) end do - entra = - entra / log(real(n,KIND=qp)) + entra = - entra / log(real(n,KIND=${rk}$)) ! now, sva().^2/trace(a^t * a) is a point in the probability simplex. ! it is derived from the diagonal of a^t * a. do the same with the ! diagonal of a * a^t, compute the entropy of the corresponding @@ -5921,7 +5922,7 @@ module stdlib_linalg_lapack_q big1 = ( ( work(p) / xsc )**2 ) * temp1 if ( big1 /= zero ) entrat = entrat + big1 * log(big1) end do - entrat = - entrat / log(real(m,KIND=qp)) + entrat = - entrat / log(real(m,KIND=${rk}$)) ! analyze the entropies and decide a or a^t. smaller entropy ! usually means better input for the algorithm. transp = ( entrat < entra ) @@ -5957,22 +5958,22 @@ module stdlib_linalg_lapack_q ! scale the matrix so that its maximal singular value remains less ! than sqrt(big) -- the matrix is scaled so that its maximal column ! has euclidean norm equal to sqrt(big/n). the only reason to keep - ! sqrt(big) instead of big is the fact that stdlib_qgejsv uses lapack and + ! sqrt(big) instead of big is the fact that stdlib_${ri}$gejsv uses lapack and ! blas routines that, in some implementations, are not capable of ! working in the full interval [sfmin,big] and that they may provoke ! overflows in the intermediate results. if the singular values spread - ! from sfmin to big, then stdlib_qgesvj will compute them. so, in that case, - ! one should use stdlib_qgesvj instead of stdlib_qgejsv. + ! from sfmin to big, then stdlib_${ri}$gesvj will compute them. so, in that case, + ! one should use stdlib_${ri}$gesvj instead of stdlib_${ri}$gejsv. big1 = sqrt( big ) - temp1 = sqrt( big / real(n,KIND=qp) ) - call stdlib_qlascl( 'G', 0, 0, aapp, temp1, n, 1, sva, n, ierr ) + temp1 = sqrt( big / real(n,KIND=${rk}$) ) + call stdlib_${ri}$lascl( 'G', 0, 0, aapp, temp1, n, 1, sva, n, ierr ) if ( aaqq > (aapp * sfmin) ) then aaqq = ( aaqq / aapp ) * temp1 else aaqq = ( aaqq * temp1 ) / aapp end if temp1 = temp1 * scalem - call stdlib_qlascl( 'G', 0, 0, aapp, temp1, m, n, a, lda, ierr ) + call stdlib_${ri}$lascl( 'G', 0, 0, aapp, temp1, m, n, a, lda, ierr ) ! to undo scaling at the end of this procedure, multiply the ! computed singular values with uscal2 / uscal1. uscal1 = temp1 @@ -5986,7 +5987,7 @@ module stdlib_linalg_lapack_q xsc = small ! now, if the condition number of a is too big, ! sigma_max(a) / sigma_min(a) > sqrt(big/n) * epsln / sfmin, - ! as a precaution measure, the full svd is computed using stdlib_qgesvj + ! as a precaution measure, the full svd is computed using stdlib_${ri}$gesvj ! with accumulated jacobi rotations. this provides numerically ! more robust computation, at the cost of slightly increased run ! time. depending on the concrete implementation of blas and lapack @@ -5999,7 +6000,7 @@ module stdlib_linalg_lapack_q if ( aaqq < xsc ) then do p = 1, n if ( sva(p) < xsc ) then - call stdlib_qlaset( 'A', m, 1, zero, zero, a(1,p), lda ) + call stdlib_${ri}$laset( 'A', m, 1, zero, zero, a(1,p), lda ) sva(p) = zero end if end do @@ -6012,7 +6013,7 @@ module stdlib_linalg_lapack_q ! has similar effect as powell-reid complete pivoting. ! the ell-infinity norms of a are made nonincreasing. do p = 1, m - 1 - q = stdlib_iqamax( m-p+1, work(m+n+p), 1 ) + p - 1 + q = stdlib_i${ri}$amax( m-p+1, work(m+n+p), 1 ) + p - 1 iwork(2*n+p) = q if ( p /= q ) then temp1 = work(m+n+p) @@ -6020,31 +6021,31 @@ module stdlib_linalg_lapack_q work(m+n+q) = temp1 end if end do - call stdlib_qlaswp( n, a, lda, 1, m-1, iwork(2*n+1), 1 ) + call stdlib_${ri}$laswp( n, a, lda, 1, m-1, iwork(2*n+1), 1 ) end if ! end of the preparation phase (scaling, optional sorting and ! transposing, optional flushing of small columns). ! preconditioning ! if the full svd is needed, the right singular vectors are computed ! from a matrix equation, and for that we need theoretical analysis - ! of the businger-golub pivoting. so we use stdlib_qgeqp3 as the first rr qrf. + ! of the businger-golub pivoting. so we use stdlib_${ri}$geqp3 as the first rr qrf. ! in all other cases the first rr qrf can be chosen by other criteria ! (eg speed by replacing global with restricted window pivoting, such ! as in sgeqpx from toms # 782). good results will be obtained using ! sgeqpx with properly (!) chosen numerical parameters. - ! any improvement of stdlib_qgeqp3 improves overall performance of stdlib_qgejsv. + ! any improvement of stdlib_${ri}$geqp3 improves overall performance of stdlib_${ri}$gejsv. ! a * p1 = q1 * [ r1^t 0]^t: do p = 1, n ! All Columns Are Free Columns iwork(p) = 0 end do - call stdlib_qgeqp3( m,n,a,lda, iwork,work, work(n+1),lwork-n, ierr ) + call stdlib_${ri}$geqp3( m,n,a,lda, iwork,work, work(n+1),lwork-n, ierr ) ! the upper triangular matrix r1 from the first qrf is inspected for ! rank deficiency and possibilities for deflation, or possible ! ill-conditioning. depending on the user specified flag l2rank, ! the procedure explores possibilities to reduce the numerical ! rank by inspecting the computed upper triangular factor. if - ! l2rank or l2aber are up, then stdlib_qgejsv will compute the svd of + ! l2rank or l2aber are up, then stdlib_${ri}$gejsv will compute the svd of ! a + da, where ||da|| <= f(m,n)*epsln. nr = 1 if ( l2aber ) then @@ -6052,7 +6053,7 @@ module stdlib_linalg_lapack_q ! sigma_i < n*epsln*||a|| are flushed to zero. this is an ! aggressive enforcement of lower numerical rank by introducing a ! backward error of the order of n*epsln*||a||. - temp1 = sqrt(real(n,KIND=qp))*epsln + temp1 = sqrt(real(n,KIND=${rk}$))*epsln do p = 2, n if ( abs(a(p,p)) >= (temp1*abs(a(1,1))) ) then nr = nr + 1 @@ -6095,7 +6096,7 @@ module stdlib_linalg_lapack_q temp1 = abs(a(p,p)) / sva(iwork(p)) maxprj = min( maxprj, temp1 ) end do - if ( maxprj**2 >= one - real(n,KIND=qp)*epsln ) almort = .true. + if ( maxprj**2 >= one - real(n,KIND=${rk}$)*epsln ) almort = .true. end if sconda = - one condr1 = - one @@ -6104,30 +6105,30 @@ module stdlib_linalg_lapack_q if ( n == nr ) then if ( rsvec ) then ! V Is Available As Workspace - call stdlib_qlacpy( 'U', n, n, a, lda, v, ldv ) + call stdlib_${ri}$lacpy( 'U', n, n, a, lda, v, ldv ) do p = 1, n temp1 = sva(iwork(p)) - call stdlib_qscal( p, one/temp1, v(1,p), 1 ) + call stdlib_${ri}$scal( p, one/temp1, v(1,p), 1 ) end do - call stdlib_qpocon( 'U', n, v, ldv, one, temp1,work(n+1), iwork(2*n+m+1), & + call stdlib_${ri}$pocon( 'U', n, v, ldv, one, temp1,work(n+1), iwork(2*n+m+1), & ierr ) else if ( lsvec ) then ! U Is Available As Workspace - call stdlib_qlacpy( 'U', n, n, a, lda, u, ldu ) + call stdlib_${ri}$lacpy( 'U', n, n, a, lda, u, ldu ) do p = 1, n temp1 = sva(iwork(p)) - call stdlib_qscal( p, one/temp1, u(1,p), 1 ) + call stdlib_${ri}$scal( p, one/temp1, u(1,p), 1 ) end do - call stdlib_qpocon( 'U', n, u, ldu, one, temp1,work(n+1), iwork(2*n+m+1), & + call stdlib_${ri}$pocon( 'U', n, u, ldu, one, temp1,work(n+1), iwork(2*n+m+1), & ierr ) else - call stdlib_qlacpy( 'U', n, n, a, lda, work(n+1), n ) + call stdlib_${ri}$lacpy( 'U', n, n, a, lda, work(n+1), n ) do p = 1, n temp1 = sva(iwork(p)) - call stdlib_qscal( p, one/temp1, work(n+(p-1)*n+1), 1 ) + call stdlib_${ri}$scal( p, one/temp1, work(n+(p-1)*n+1), 1 ) end do ! The Columns Of R Are Scaled To Have Unit Euclidean Lengths - call stdlib_qpocon( 'U', n, work(n+1), n, one, temp1,work(n+n*n+1), iwork(2*n+& + call stdlib_${ri}$pocon( 'U', n, work(n+1), n, one, temp1,work(n+n*n+1), iwork(2*n+& m+1), ierr ) end if sconda = one / sqrt(temp1) @@ -6144,7 +6145,7 @@ module stdlib_linalg_lapack_q ! singular values only ! .. transpose a(1:nr,1:n) do p = 1, min( n-1, nr ) - call stdlib_qcopy( n-p, a(p,p+1), lda, a(p+1,p), 1 ) + call stdlib_${ri}$copy( n-p, a(p,p+1), lda, a(p+1,p), 1 ) end do ! the following two do-loops introduce small relative perturbation ! into the strict upper triangle of the lower triangular matrix. @@ -6160,7 +6161,7 @@ module stdlib_linalg_lapack_q if ( .not. almort ) then if ( l2pert ) then ! xsc = sqrt(small) - xsc = epsln / real(n,KIND=qp) + xsc = epsln / real(n,KIND=${rk}$) do q = 1, nr temp1 = xsc*abs(a(q,q)) do p = 1, n @@ -6169,13 +6170,13 @@ module stdlib_linalg_lapack_q end do end do else - call stdlib_qlaset( 'U', nr-1,nr-1, zero,zero, a(1,2),lda ) + call stdlib_${ri}$laset( 'U', nr-1,nr-1, zero,zero, a(1,2),lda ) end if ! Second Preconditioning Using The Qr Factorization - call stdlib_qgeqrf( n,nr, a,lda, work, work(n+1),lwork-n, ierr ) + call stdlib_${ri}$geqrf( n,nr, a,lda, work, work(n+1),lwork-n, ierr ) ! And Transpose Upper To Lower Triangular do p = 1, nr - 1 - call stdlib_qcopy( nr-p, a(p,p+1), lda, a(p+1,p), 1 ) + call stdlib_${ri}$copy( nr-p, a(p,p+1), lda, a(p+1,p), 1 ) end do end if ! row-cyclic jacobi svd algorithm with column pivoting @@ -6183,7 +6184,7 @@ module stdlib_linalg_lapack_q ! to drown denormals if ( l2pert ) then ! xsc = sqrt(small) - xsc = epsln / real(n,KIND=qp) + xsc = epsln / real(n,KIND=${rk}$) do q = 1, nr temp1 = xsc*abs(a(q,q)) do p = 1, nr @@ -6192,12 +6193,12 @@ module stdlib_linalg_lapack_q end do end do else - call stdlib_qlaset( 'U', nr-1, nr-1, zero, zero, a(1,2), lda ) + call stdlib_${ri}$laset( 'U', nr-1, nr-1, zero, zero, a(1,2), lda ) end if ! .. and one-sided jacobi rotations are started on a lower ! triangular matrix (plus perturbation which is ignored in ! the part which destroys triangular form (confusing?!)) - call stdlib_qgesvj( 'L', 'NOU', 'NOV', nr, nr, a, lda, sva,n, v, ldv, work, & + call stdlib_${ri}$gesvj( 'L', 'NOU', 'NOV', nr, nr, a, lda, sva,n, v, ldv, work, & lwork, info ) scalem = work(1) numrank = nint(work(2),KIND=ilp) @@ -6206,78 +6207,78 @@ module stdlib_linalg_lapack_q if ( almort ) then ! In This Case Nr Equals N do p = 1, nr - call stdlib_qcopy( n-p+1, a(p,p), lda, v(p,p), 1 ) + call stdlib_${ri}$copy( n-p+1, a(p,p), lda, v(p,p), 1 ) end do - call stdlib_qlaset( 'UPPER', nr-1, nr-1, zero, zero, v(1,2), ldv ) - call stdlib_qgesvj( 'L','U','N', n, nr, v,ldv, sva, nr, a,lda,work, lwork, info ) + call stdlib_${ri}$laset( 'UPPER', nr-1, nr-1, zero, zero, v(1,2), ldv ) + call stdlib_${ri}$gesvj( 'L','U','N', n, nr, v,ldv, sva, nr, a,lda,work, lwork, info ) scalem = work(1) numrank = nint(work(2),KIND=ilp) else ! .. two more qr factorizations ( one qrf is not enough, two require ! accumulated product of jacobi rotations, three are perfect ) - call stdlib_qlaset( 'LOWER', nr-1, nr-1, zero, zero, a(2,1), lda ) - call stdlib_qgelqf( nr, n, a, lda, work, work(n+1), lwork-n, ierr) - call stdlib_qlacpy( 'LOWER', nr, nr, a, lda, v, ldv ) - call stdlib_qlaset( 'UPPER', nr-1, nr-1, zero, zero, v(1,2), ldv ) - call stdlib_qgeqrf( nr, nr, v, ldv, work(n+1), work(2*n+1),lwork-2*n, ierr ) + call stdlib_${ri}$laset( 'LOWER', nr-1, nr-1, zero, zero, a(2,1), lda ) + call stdlib_${ri}$gelqf( nr, n, a, lda, work, work(n+1), lwork-n, ierr) + call stdlib_${ri}$lacpy( 'LOWER', nr, nr, a, lda, v, ldv ) + call stdlib_${ri}$laset( 'UPPER', nr-1, nr-1, zero, zero, v(1,2), ldv ) + call stdlib_${ri}$geqrf( nr, nr, v, ldv, work(n+1), work(2*n+1),lwork-2*n, ierr ) do p = 1, nr - call stdlib_qcopy( nr-p+1, v(p,p), ldv, v(p,p), 1 ) + call stdlib_${ri}$copy( nr-p+1, v(p,p), ldv, v(p,p), 1 ) end do - call stdlib_qlaset( 'UPPER', nr-1, nr-1, zero, zero, v(1,2), ldv ) - call stdlib_qgesvj( 'LOWER', 'U','N', nr, nr, v,ldv, sva, nr, u,ldu, work(n+1), & + call stdlib_${ri}$laset( 'UPPER', nr-1, nr-1, zero, zero, v(1,2), ldv ) + call stdlib_${ri}$gesvj( 'LOWER', 'U','N', nr, nr, v,ldv, sva, nr, u,ldu, work(n+1), & lwork, info ) scalem = work(n+1) numrank = nint(work(n+2),KIND=ilp) if ( nr < n ) then - call stdlib_qlaset( 'A',n-nr, nr, zero,zero, v(nr+1,1), ldv ) - call stdlib_qlaset( 'A',nr, n-nr, zero,zero, v(1,nr+1), ldv ) - call stdlib_qlaset( 'A',n-nr,n-nr,zero,one, v(nr+1,nr+1), ldv ) + call stdlib_${ri}$laset( 'A',n-nr, nr, zero,zero, v(nr+1,1), ldv ) + call stdlib_${ri}$laset( 'A',nr, n-nr, zero,zero, v(1,nr+1), ldv ) + call stdlib_${ri}$laset( 'A',n-nr,n-nr,zero,one, v(nr+1,nr+1), ldv ) end if - call stdlib_qormlq( 'LEFT', 'TRANSPOSE', n, n, nr, a, lda, work,v, ldv, work(n+1), & + call stdlib_${ri}$ormlq( 'LEFT', 'TRANSPOSE', n, n, nr, a, lda, work,v, ldv, work(n+1), & lwork-n, ierr ) end if do p = 1, n - call stdlib_qcopy( n, v(p,1), ldv, a(iwork(p),1), lda ) + call stdlib_${ri}$copy( n, v(p,1), ldv, a(iwork(p),1), lda ) end do - call stdlib_qlacpy( 'ALL', n, n, a, lda, v, ldv ) + call stdlib_${ri}$lacpy( 'ALL', n, n, a, lda, v, ldv ) if ( transp ) then - call stdlib_qlacpy( 'ALL', n, n, v, ldv, u, ldu ) + call stdlib_${ri}$lacpy( 'ALL', n, n, v, ldv, u, ldu ) end if else if ( lsvec .and. ( .not. rsvec ) ) then ! Singular Values And Left Singular Vectors ! Second Preconditioning Step To Avoid Need To Accumulate ! jacobi rotations in the jacobi iterations. do p = 1, nr - call stdlib_qcopy( n-p+1, a(p,p), lda, u(p,p), 1 ) + call stdlib_${ri}$copy( n-p+1, a(p,p), lda, u(p,p), 1 ) end do - call stdlib_qlaset( 'UPPER', nr-1, nr-1, zero, zero, u(1,2), ldu ) - call stdlib_qgeqrf( n, nr, u, ldu, work(n+1), work(2*n+1),lwork-2*n, ierr ) + call stdlib_${ri}$laset( 'UPPER', nr-1, nr-1, zero, zero, u(1,2), ldu ) + call stdlib_${ri}$geqrf( n, nr, u, ldu, work(n+1), work(2*n+1),lwork-2*n, ierr ) do p = 1, nr - 1 - call stdlib_qcopy( nr-p, u(p,p+1), ldu, u(p+1,p), 1 ) + call stdlib_${ri}$copy( nr-p, u(p,p+1), ldu, u(p+1,p), 1 ) end do - call stdlib_qlaset( 'UPPER', nr-1, nr-1, zero, zero, u(1,2), ldu ) - call stdlib_qgesvj( 'LOWER', 'U', 'N', nr,nr, u, ldu, sva, nr, a,lda, work(n+1), & + call stdlib_${ri}$laset( 'UPPER', nr-1, nr-1, zero, zero, u(1,2), ldu ) + call stdlib_${ri}$gesvj( 'LOWER', 'U', 'N', nr,nr, u, ldu, sva, nr, a,lda, work(n+1), & lwork-n, info ) scalem = work(n+1) numrank = nint(work(n+2),KIND=ilp) if ( nr < m ) then - call stdlib_qlaset( 'A', m-nr, nr,zero, zero, u(nr+1,1), ldu ) + call stdlib_${ri}$laset( 'A', m-nr, nr,zero, zero, u(nr+1,1), ldu ) if ( nr < n1 ) then - call stdlib_qlaset( 'A',nr, n1-nr, zero, zero, u(1,nr+1), ldu ) - call stdlib_qlaset( 'A',m-nr,n1-nr,zero,one,u(nr+1,nr+1), ldu ) + call stdlib_${ri}$laset( 'A',nr, n1-nr, zero, zero, u(1,nr+1), ldu ) + call stdlib_${ri}$laset( 'A',m-nr,n1-nr,zero,one,u(nr+1,nr+1), ldu ) end if end if - call stdlib_qormqr( 'LEFT', 'NO TR', m, n1, n, a, lda, work, u,ldu, work(n+1), & + call stdlib_${ri}$ormqr( 'LEFT', 'NO TR', m, n1, n, a, lda, work, u,ldu, work(n+1), & lwork-n, ierr ) - if ( rowpiv )call stdlib_qlaswp( n1, u, ldu, 1, m-1, iwork(2*n+1), -1 ) + if ( rowpiv )call stdlib_${ri}$laswp( n1, u, ldu, 1, m-1, iwork(2*n+1), -1 ) do p = 1, n1 - xsc = one / stdlib_qnrm2( m, u(1,p), 1 ) - call stdlib_qscal( m, xsc, u(1,p), 1 ) + xsc = one / stdlib_${ri}$nrm2( m, u(1,p), 1 ) + call stdlib_${ri}$scal( m, xsc, u(1,p), 1 ) end do if ( transp ) then - call stdlib_qlacpy( 'ALL', n, n, u, ldu, v, ldv ) + call stdlib_${ri}$lacpy( 'ALL', n, n, u, ldu, v, ldv ) end if else ! Full Svd @@ -6288,9 +6289,9 @@ module stdlib_linalg_lapack_q ! equivalent to an lqf call. since in many libraries the qrf ! seems to be better optimized than the lqf, we do explicit ! transpose and use the qrf. this is subject to changes in an - ! optimized implementation of stdlib_qgejsv. + ! optimized implementation of stdlib_${ri}$gejsv. do p = 1, nr - call stdlib_qcopy( n-p+1, a(p,p), lda, v(p,p), 1 ) + call stdlib_${ri}$copy( n-p+1, a(p,p), lda, v(p,p), 1 ) end do ! The Following Two Loops Perturb Small Entries To Avoid ! denormals in the second qr factorization, where they are @@ -6314,31 +6315,31 @@ module stdlib_linalg_lapack_q end do end do else - call stdlib_qlaset( 'U', nr-1, nr-1, zero, zero, v(1,2), ldv ) + call stdlib_${ri}$laset( 'U', nr-1, nr-1, zero, zero, v(1,2), ldv ) end if ! estimate the row scaled condition number of r1 ! (if r1 is rectangular, n > nr, then the condition number ! of the leading nr x nr submatrix is estimated.) - call stdlib_qlacpy( 'L', nr, nr, v, ldv, work(2*n+1), nr ) + call stdlib_${ri}$lacpy( 'L', nr, nr, v, ldv, work(2*n+1), nr ) do p = 1, nr - temp1 = stdlib_qnrm2(nr-p+1,work(2*n+(p-1)*nr+p),1) - call stdlib_qscal(nr-p+1,one/temp1,work(2*n+(p-1)*nr+p),1) + temp1 = stdlib_${ri}$nrm2(nr-p+1,work(2*n+(p-1)*nr+p),1) + call stdlib_${ri}$scal(nr-p+1,one/temp1,work(2*n+(p-1)*nr+p),1) end do - call stdlib_qpocon('LOWER',nr,work(2*n+1),nr,one,temp1,work(2*n+nr*nr+1),iwork(m+& + call stdlib_${ri}$pocon('LOWER',nr,work(2*n+1),nr,one,temp1,work(2*n+nr*nr+1),iwork(m+& 2*n+1),ierr) condr1 = one / sqrt(temp1) ! Here Need A Second Opinion On The Condition Number ! Then Assume Worst Case Scenario - ! r1 is ok for inverse <=> condr1 < real(n,KIND=qp) - ! more conservative <=> condr1 < sqrt(real(n,KIND=qp)) - cond_ok = sqrt(real(nr,KIND=qp)) + ! r1 is ok for inverse <=> condr1 < real(n,KIND=${rk}$) + ! more conservative <=> condr1 < sqrt(real(n,KIND=${rk}$)) + cond_ok = sqrt(real(nr,KIND=${rk}$)) ! [tp] cond_ok is a tuning parameter. if ( condr1 < cond_ok ) then ! .. the second qrf without pivoting. note: in an optimized ! implementation, this qrf should be implemented as the qrf ! of a lower triangular matrix. ! r1^t = q2 * r2 - call stdlib_qgeqrf( n, nr, v, ldv, work(n+1), work(2*n+1),lwork-2*n, ierr ) + call stdlib_${ri}$geqrf( n, nr, v, ldv, work(n+1), work(2*n+1),lwork-2*n, ierr ) if ( l2pert ) then xsc = sqrt(small)/epsln @@ -6349,27 +6350,27 @@ module stdlib_linalg_lapack_q end do end do end if - if ( nr /= n )call stdlib_qlacpy( 'A', n, nr, v, ldv, work(2*n+1), n ) + if ( nr /= n )call stdlib_${ri}$lacpy( 'A', n, nr, v, ldv, work(2*n+1), n ) ! .. save ... ! This Transposed Copy Should Be Better Than Naive do p = 1, nr - 1 - call stdlib_qcopy( nr-p, v(p,p+1), ldv, v(p+1,p), 1 ) + call stdlib_${ri}$copy( nr-p, v(p,p+1), ldv, v(p+1,p), 1 ) end do condr2 = condr1 else ! .. ill-conditioned case: second qrf with pivoting ! note that windowed pivoting would be equally good ! numerically, and more run-time efficient. so, in - ! an optimal implementation, the next call to stdlib_qgeqp3 + ! an optimal implementation, the next call to stdlib_${ri}$geqp3 ! should be replaced with eg. call sgeqpx (acm toms #782) ! with properly (carefully) chosen parameters. ! r1^t * p2 = q2 * r2 do p = 1, nr iwork(n+p) = 0 end do - call stdlib_qgeqp3( n, nr, v, ldv, iwork(n+1), work(n+1),work(2*n+1), lwork-& + call stdlib_${ri}$geqp3( n, nr, v, ldv, iwork(n+1), work(n+1),work(2*n+1), lwork-& 2*n, ierr ) - ! * call stdlib_qgeqrf( n, nr, v, ldv, work(n+1), work(2*n+1), + ! * call stdlib_${ri}$geqrf( n, nr, v, ldv, work(n+1), work(2*n+1), ! * $ lwork-2*n, ierr ) if ( l2pert ) then xsc = sqrt(small) @@ -6380,7 +6381,7 @@ module stdlib_linalg_lapack_q end do end do end if - call stdlib_qlacpy( 'A', n, nr, v, ldv, work(2*n+1), n ) + call stdlib_${ri}$lacpy( 'A', n, nr, v, ldv, work(2*n+1), n ) if ( l2pert ) then xsc = sqrt(small) do p = 2, nr @@ -6390,18 +6391,18 @@ module stdlib_linalg_lapack_q end do end do else - call stdlib_qlaset( 'L',nr-1,nr-1,zero,zero,v(2,1),ldv ) + call stdlib_${ri}$laset( 'L',nr-1,nr-1,zero,zero,v(2,1),ldv ) end if ! now, compute r2 = l3 * q3, the lq factorization. - call stdlib_qgelqf( nr, nr, v, ldv, work(2*n+n*nr+1),work(2*n+n*nr+nr+1), & + call stdlib_${ri}$gelqf( nr, nr, v, ldv, work(2*n+n*nr+1),work(2*n+n*nr+nr+1), & lwork-2*n-n*nr-nr, ierr ) ! And Estimate The Condition Number - call stdlib_qlacpy( 'L',nr,nr,v,ldv,work(2*n+n*nr+nr+1),nr ) + call stdlib_${ri}$lacpy( 'L',nr,nr,v,ldv,work(2*n+n*nr+nr+1),nr ) do p = 1, nr - temp1 = stdlib_qnrm2( p, work(2*n+n*nr+nr+p), nr ) - call stdlib_qscal( p, one/temp1, work(2*n+n*nr+nr+p), nr ) + temp1 = stdlib_${ri}$nrm2( p, work(2*n+n*nr+nr+p), nr ) + call stdlib_${ri}$scal( p, one/temp1, work(2*n+n*nr+nr+p), nr ) end do - call stdlib_qpocon( 'L',nr,work(2*n+n*nr+nr+1),nr,one,temp1,work(2*n+n*nr+nr+& + call stdlib_${ri}$pocon( 'L',nr,work(2*n+n*nr+nr+1),nr,one,temp1,work(2*n+n*nr+nr+& nr*nr+1),iwork(m+2*n+1),ierr ) condr2 = one / sqrt(temp1) if ( condr2 >= cond_ok ) then @@ -6409,7 +6410,7 @@ module stdlib_linalg_lapack_q ! (this overwrites the copy of r2, as it will not be ! needed in this branch, but it does not overwritte the ! huseholder vectors of q2.). - call stdlib_qlacpy( 'U', nr, nr, v, ldv, work(2*n+1), n ) + call stdlib_${ri}$lacpy( 'U', nr, nr, v, ldv, work(2*n+1), n ) ! And The Rest Of The Information On Q3 Is In ! work(2*n+n*nr+1:2*n+n*nr+n) end if @@ -6424,40 +6425,40 @@ module stdlib_linalg_lapack_q end do end do else - call stdlib_qlaset( 'U', nr-1,nr-1, zero,zero, v(1,2), ldv ) + call stdlib_${ri}$laset( 'U', nr-1,nr-1, zero,zero, v(1,2), ldv ) end if ! second preconditioning finished; continue with jacobi svd ! the input matrix is lower trinagular. ! recover the right singular vectors as solution of a well ! conditioned triangular matrix equation. if ( condr1 < cond_ok ) then - call stdlib_qgesvj( 'L','U','N',nr,nr,v,ldv,sva,nr,u,ldu,work(2*n+n*nr+nr+1),& + call stdlib_${ri}$gesvj( 'L','U','N',nr,nr,v,ldv,sva,nr,u,ldu,work(2*n+n*nr+nr+1),& lwork-2*n-n*nr-nr,info ) scalem = work(2*n+n*nr+nr+1) numrank = nint(work(2*n+n*nr+nr+2),KIND=ilp) do p = 1, nr - call stdlib_qcopy( nr, v(1,p), 1, u(1,p), 1 ) - call stdlib_qscal( nr, sva(p), v(1,p), 1 ) + call stdlib_${ri}$copy( nr, v(1,p), 1, u(1,p), 1 ) + call stdlib_${ri}$scal( nr, sva(p), v(1,p), 1 ) end do ! Pick The Right Matrix Equation And Solve It if ( nr == n ) then ! :)) .. best case, r1 is inverted. the solution of this matrix ! equation is q2*v2 = the product of the jacobi rotations - ! used in stdlib_qgesvj, premultiplied with the orthogonal matrix + ! used in stdlib_${ri}$gesvj, premultiplied with the orthogonal matrix ! from the second qr factorization. - call stdlib_qtrsm( 'L','U','N','N', nr,nr,one, a,lda, v,ldv ) + call stdlib_${ri}$trsm( 'L','U','N','N', nr,nr,one, a,lda, v,ldv ) else ! .. r1 is well conditioned, but non-square. transpose(r2) ! is inverted to get the product of the jacobi rotations - ! used in stdlib_qgesvj. the q-factor from the second qr + ! used in stdlib_${ri}$gesvj. the q-factor from the second qr ! factorization is then built in explicitly. - call stdlib_qtrsm('L','U','T','N',nr,nr,one,work(2*n+1),n,v,ldv) + call stdlib_${ri}$trsm('L','U','T','N',nr,nr,one,work(2*n+1),n,v,ldv) if ( nr < n ) then - call stdlib_qlaset('A',n-nr,nr,zero,zero,v(nr+1,1),ldv) - call stdlib_qlaset('A',nr,n-nr,zero,zero,v(1,nr+1),ldv) - call stdlib_qlaset('A',n-nr,n-nr,zero,one,v(nr+1,nr+1),ldv) + call stdlib_${ri}$laset('A',n-nr,nr,zero,zero,v(nr+1,1),ldv) + call stdlib_${ri}$laset('A',nr,n-nr,zero,zero,v(1,nr+1),ldv) + call stdlib_${ri}$laset('A',n-nr,n-nr,zero,one,v(nr+1,nr+1),ldv) end if - call stdlib_qormqr('L','N',n,n,nr,work(2*n+1),n,work(n+1),v,ldv,work(2*n+& + call stdlib_${ri}$ormqr('L','N',n,n,nr,work(2*n+1),n,work(n+1),v,ldv,work(2*n+& n*nr+nr+1),lwork-2*n-n*nr-nr,ierr) end if else if ( condr2 < cond_ok ) then @@ -6467,15 +6468,15 @@ module stdlib_linalg_lapack_q ! is q3^t*v3 = the product of the jacobi rotations (appplied to ! the lower triangular l3 from the lq factorization of ! r2=l3*q3), pre-multiplied with the transposed q3. - call stdlib_qgesvj( 'L', 'U', 'N', nr, nr, v, ldv, sva, nr, u,ldu, work(2*n+& + call stdlib_${ri}$gesvj( 'L', 'U', 'N', nr, nr, v, ldv, sva, nr, u,ldu, work(2*n+& n*nr+nr+1), lwork-2*n-n*nr-nr, info ) scalem = work(2*n+n*nr+nr+1) numrank = nint(work(2*n+n*nr+nr+2),KIND=ilp) do p = 1, nr - call stdlib_qcopy( nr, v(1,p), 1, u(1,p), 1 ) - call stdlib_qscal( nr, sva(p), u(1,p), 1 ) + call stdlib_${ri}$copy( nr, v(1,p), 1, u(1,p), 1 ) + call stdlib_${ri}$scal( nr, sva(p), u(1,p), 1 ) end do - call stdlib_qtrsm('L','U','N','N',nr,nr,one,work(2*n+1),n,u,ldu) + call stdlib_${ri}$trsm('L','U','N','N',nr,nr,one,work(2*n+1),n,u,ldu) ! Apply The Permutation From The Second Qr Factorization do q = 1, nr do p = 1, nr @@ -6486,11 +6487,11 @@ module stdlib_linalg_lapack_q end do end do if ( nr < n ) then - call stdlib_qlaset( 'A',n-nr,nr,zero,zero,v(nr+1,1),ldv ) - call stdlib_qlaset( 'A',nr,n-nr,zero,zero,v(1,nr+1),ldv ) - call stdlib_qlaset( 'A',n-nr,n-nr,zero,one,v(nr+1,nr+1),ldv ) + call stdlib_${ri}$laset( 'A',n-nr,nr,zero,zero,v(nr+1,1),ldv ) + call stdlib_${ri}$laset( 'A',nr,n-nr,zero,zero,v(1,nr+1),ldv ) + call stdlib_${ri}$laset( 'A',n-nr,n-nr,zero,one,v(nr+1,nr+1),ldv ) end if - call stdlib_qormqr( 'L','N',n,n,nr,work(2*n+1),n,work(n+1),v,ldv,work(2*n+& + call stdlib_${ri}$ormqr( 'L','N',n,n,nr,work(2*n+1),n,work(n+1),v,ldv,work(2*n+& n*nr+nr+1),lwork-2*n-n*nr-nr,ierr ) else ! last line of defense. @@ -6501,21 +6502,21 @@ module stdlib_linalg_lapack_q ! is set very close to one (which is unnecessary). normally, ! this branch should never be executed, but in rare cases of ! failure of the rrqr or condition estimator, the last line of - ! defense ensures that stdlib_qgejsv completes the task. - ! compute the full svd of l3 using stdlib_qgesvj with explicit + ! defense ensures that stdlib_${ri}$gejsv completes the task. + ! compute the full svd of l3 using stdlib_${ri}$gesvj with explicit ! accumulation of jacobi rotations. - call stdlib_qgesvj( 'L', 'U', 'V', nr, nr, v, ldv, sva, nr, u,ldu, work(2*n+& + call stdlib_${ri}$gesvj( 'L', 'U', 'V', nr, nr, v, ldv, sva, nr, u,ldu, work(2*n+& n*nr+nr+1), lwork-2*n-n*nr-nr, info ) scalem = work(2*n+n*nr+nr+1) numrank = nint(work(2*n+n*nr+nr+2),KIND=ilp) if ( nr < n ) then - call stdlib_qlaset( 'A',n-nr,nr,zero,zero,v(nr+1,1),ldv ) - call stdlib_qlaset( 'A',nr,n-nr,zero,zero,v(1,nr+1),ldv ) - call stdlib_qlaset( 'A',n-nr,n-nr,zero,one,v(nr+1,nr+1),ldv ) + call stdlib_${ri}$laset( 'A',n-nr,nr,zero,zero,v(nr+1,1),ldv ) + call stdlib_${ri}$laset( 'A',nr,n-nr,zero,zero,v(1,nr+1),ldv ) + call stdlib_${ri}$laset( 'A',n-nr,n-nr,zero,one,v(nr+1,nr+1),ldv ) end if - call stdlib_qormqr( 'L','N',n,n,nr,work(2*n+1),n,work(n+1),v,ldv,work(2*n+& + call stdlib_${ri}$ormqr( 'L','N',n,n,nr,work(2*n+1),n,work(n+1),v,ldv,work(2*n+& n*nr+nr+1),lwork-2*n-n*nr-nr,ierr ) - call stdlib_qormlq( 'L', 'T', nr, nr, nr, work(2*n+1), n,work(2*n+n*nr+1), u, & + call stdlib_${ri}$ormlq( 'L', 'T', nr, nr, nr, work(2*n+1), n,work(2*n+n*nr+1), u, & ldu, work(2*n+n*nr+nr+1),lwork-2*n-n*nr-nr, ierr ) do q = 1, nr do p = 1, nr @@ -6529,7 +6530,7 @@ module stdlib_linalg_lapack_q ! permute the rows of v using the (column) permutation from the ! first qrf. also, scale the columns to make them unit in ! euclidean norm. this applies to all cases. - temp1 = sqrt(real(n,KIND=qp)) * epsln + temp1 = sqrt(real(n,KIND=${rk}$)) * epsln do q = 1, n do p = 1, n work(2*n+n*nr+nr+iwork(p)) = v(p,q) @@ -6537,37 +6538,37 @@ module stdlib_linalg_lapack_q do p = 1, n v(p,q) = work(2*n+n*nr+nr+p) end do - xsc = one / stdlib_qnrm2( n, v(1,q), 1 ) - if ( (xsc < (one-temp1)) .or. (xsc > (one+temp1)) )call stdlib_qscal( n, xsc, & + xsc = one / stdlib_${ri}$nrm2( n, v(1,q), 1 ) + if ( (xsc < (one-temp1)) .or. (xsc > (one+temp1)) )call stdlib_${ri}$scal( n, xsc, & v(1,q), 1 ) end do ! at this moment, v contains the right singular vectors of a. ! next, assemble the left singular vector matrix u (m x n). if ( nr < m ) then - call stdlib_qlaset( 'A', m-nr, nr, zero, zero, u(nr+1,1), ldu ) + call stdlib_${ri}$laset( 'A', m-nr, nr, zero, zero, u(nr+1,1), ldu ) if ( nr < n1 ) then - call stdlib_qlaset('A',nr,n1-nr,zero,zero,u(1,nr+1),ldu) - call stdlib_qlaset('A',m-nr,n1-nr,zero,one,u(nr+1,nr+1),ldu) + call stdlib_${ri}$laset('A',nr,n1-nr,zero,zero,u(1,nr+1),ldu) + call stdlib_${ri}$laset('A',m-nr,n1-nr,zero,one,u(nr+1,nr+1),ldu) end if end if ! the q matrix from the first qrf is built into the left singular ! matrix u. this applies to all cases. - call stdlib_qormqr( 'LEFT', 'NO_TR', m, n1, n, a, lda, work, u,ldu, work(n+1), & + call stdlib_${ri}$ormqr( 'LEFT', 'NO_TR', m, n1, n, a, lda, work, u,ldu, work(n+1), & lwork-n, ierr ) ! the columns of u are normalized. the cost is o(m*n) flops. - temp1 = sqrt(real(m,KIND=qp)) * epsln + temp1 = sqrt(real(m,KIND=${rk}$)) * epsln do p = 1, nr - xsc = one / stdlib_qnrm2( m, u(1,p), 1 ) - if ( (xsc < (one-temp1)) .or. (xsc > (one+temp1)) )call stdlib_qscal( m, xsc, & + xsc = one / stdlib_${ri}$nrm2( m, u(1,p), 1 ) + if ( (xsc < (one-temp1)) .or. (xsc > (one+temp1)) )call stdlib_${ri}$scal( m, xsc, & u(1,p), 1 ) end do ! if the initial qrf is computed with row pivoting, the left ! singular vectors must be adjusted. - if ( rowpiv )call stdlib_qlaswp( n1, u, ldu, 1, m-1, iwork(2*n+1), -1 ) + if ( rowpiv )call stdlib_${ri}$laswp( n1, u, ldu, 1, m-1, iwork(2*n+1), -1 ) else ! The Initial Matrix A Has Almost Orthogonal Columns And ! the second qrf is not needed - call stdlib_qlacpy( 'UPPER', n, n, a, lda, work(n+1), n ) + call stdlib_${ri}$lacpy( 'UPPER', n, n, a, lda, work(n+1), n ) if ( l2pert ) then xsc = sqrt(small) do p = 2, n @@ -6577,44 +6578,44 @@ module stdlib_linalg_lapack_q end do end do else - call stdlib_qlaset( 'LOWER',n-1,n-1,zero,zero,work(n+2),n ) + call stdlib_${ri}$laset( 'LOWER',n-1,n-1,zero,zero,work(n+2),n ) end if - call stdlib_qgesvj( 'UPPER', 'U', 'N', n, n, work(n+1), n, sva,n, u, ldu, work(n+& + call stdlib_${ri}$gesvj( 'UPPER', 'U', 'N', n, n, work(n+1), n, sva,n, u, ldu, work(n+& n*n+1), lwork-n-n*n, info ) scalem = work(n+n*n+1) numrank = nint(work(n+n*n+2),KIND=ilp) do p = 1, n - call stdlib_qcopy( n, work(n+(p-1)*n+1), 1, u(1,p), 1 ) - call stdlib_qscal( n, sva(p), work(n+(p-1)*n+1), 1 ) + call stdlib_${ri}$copy( n, work(n+(p-1)*n+1), 1, u(1,p), 1 ) + call stdlib_${ri}$scal( n, sva(p), work(n+(p-1)*n+1), 1 ) end do - call stdlib_qtrsm( 'LEFT', 'UPPER', 'NOTRANS', 'NO UD', n, n,one, a, lda, work(n+& + call stdlib_${ri}$trsm( 'LEFT', 'UPPER', 'NOTRANS', 'NO UD', n, n,one, a, lda, work(n+& 1), n ) do p = 1, n - call stdlib_qcopy( n, work(n+p), n, v(iwork(p),1), ldv ) + call stdlib_${ri}$copy( n, work(n+p), n, v(iwork(p),1), ldv ) end do - temp1 = sqrt(real(n,KIND=qp))*epsln + temp1 = sqrt(real(n,KIND=${rk}$))*epsln do p = 1, n - xsc = one / stdlib_qnrm2( n, v(1,p), 1 ) - if ( (xsc < (one-temp1)) .or. (xsc > (one+temp1)) )call stdlib_qscal( n, xsc, & + xsc = one / stdlib_${ri}$nrm2( n, v(1,p), 1 ) + if ( (xsc < (one-temp1)) .or. (xsc > (one+temp1)) )call stdlib_${ri}$scal( n, xsc, & v(1,p), 1 ) end do ! assemble the left singular vector matrix u (m x n). if ( n < m ) then - call stdlib_qlaset( 'A', m-n, n, zero, zero, u(n+1,1), ldu ) + call stdlib_${ri}$laset( 'A', m-n, n, zero, zero, u(n+1,1), ldu ) if ( n < n1 ) then - call stdlib_qlaset( 'A',n, n1-n, zero, zero, u(1,n+1),ldu ) - call stdlib_qlaset( 'A',m-n,n1-n, zero, one,u(n+1,n+1),ldu ) + call stdlib_${ri}$laset( 'A',n, n1-n, zero, zero, u(1,n+1),ldu ) + call stdlib_${ri}$laset( 'A',m-n,n1-n, zero, one,u(n+1,n+1),ldu ) end if end if - call stdlib_qormqr( 'LEFT', 'NO TR', m, n1, n, a, lda, work, u,ldu, work(n+1), & + call stdlib_${ri}$ormqr( 'LEFT', 'NO TR', m, n1, n, a, lda, work, u,ldu, work(n+1), & lwork-n, ierr ) - temp1 = sqrt(real(m,KIND=qp))*epsln + temp1 = sqrt(real(m,KIND=${rk}$))*epsln do p = 1, n1 - xsc = one / stdlib_qnrm2( m, u(1,p), 1 ) - if ( (xsc < (one-temp1)) .or. (xsc > (one+temp1)) )call stdlib_qscal( m, xsc, & + xsc = one / stdlib_${ri}$nrm2( m, u(1,p), 1 ) + if ( (xsc < (one-temp1)) .or. (xsc > (one+temp1)) )call stdlib_${ri}$scal( m, xsc, & u(1,p), 1 ) end do - if ( rowpiv )call stdlib_qlaswp( n1, u, ldu, 1, m-1, iwork(2*n+1), -1 ) + if ( rowpiv )call stdlib_${ri}$laswp( n1, u, ldu, 1, m-1, iwork(2*n+1), -1 ) end if ! end of the >> almost orthogonal case << in the full svd else @@ -6628,7 +6629,7 @@ module stdlib_linalg_lapack_q ! implementation of blas and some lapack procedures, capable of working ! in presence of extreme values. since that is not always the case, ... do p = 1, nr - call stdlib_qcopy( n-p+1, a(p,p), lda, v(p,p), 1 ) + call stdlib_${ri}$copy( n-p+1, a(p,p), lda, v(p,p), 1 ) end do if ( l2pert ) then xsc = sqrt(small/epsln) @@ -6641,12 +6642,12 @@ module stdlib_linalg_lapack_q end do end do else - call stdlib_qlaset( 'U', nr-1, nr-1, zero, zero, v(1,2), ldv ) + call stdlib_${ri}$laset( 'U', nr-1, nr-1, zero, zero, v(1,2), ldv ) end if - call stdlib_qgeqrf( n, nr, v, ldv, work(n+1), work(2*n+1),lwork-2*n, ierr ) - call stdlib_qlacpy( 'L', n, nr, v, ldv, work(2*n+1), n ) + call stdlib_${ri}$geqrf( n, nr, v, ldv, work(n+1), work(2*n+1),lwork-2*n, ierr ) + call stdlib_${ri}$lacpy( 'L', n, nr, v, ldv, work(2*n+1), n ) do p = 1, nr - call stdlib_qcopy( nr-p+1, v(p,p), ldv, u(p,p), 1 ) + call stdlib_${ri}$copy( nr-p+1, v(p,p), ldv, u(p,p), 1 ) end do if ( l2pert ) then xsc = sqrt(small/epsln) @@ -6657,23 +6658,23 @@ module stdlib_linalg_lapack_q end do end do else - call stdlib_qlaset('U', nr-1, nr-1, zero, zero, u(1,2), ldu ) + call stdlib_${ri}$laset('U', nr-1, nr-1, zero, zero, u(1,2), ldu ) end if - call stdlib_qgesvj( 'G', 'U', 'V', nr, nr, u, ldu, sva,n, v, ldv, work(2*n+n*nr+1), & + call stdlib_${ri}$gesvj( 'G', 'U', 'V', nr, nr, u, ldu, sva,n, v, ldv, work(2*n+n*nr+1), & lwork-2*n-n*nr, info ) scalem = work(2*n+n*nr+1) numrank = nint(work(2*n+n*nr+2),KIND=ilp) if ( nr < n ) then - call stdlib_qlaset( 'A',n-nr,nr,zero,zero,v(nr+1,1),ldv ) - call stdlib_qlaset( 'A',nr,n-nr,zero,zero,v(1,nr+1),ldv ) - call stdlib_qlaset( 'A',n-nr,n-nr,zero,one,v(nr+1,nr+1),ldv ) + call stdlib_${ri}$laset( 'A',n-nr,nr,zero,zero,v(nr+1,1),ldv ) + call stdlib_${ri}$laset( 'A',nr,n-nr,zero,zero,v(1,nr+1),ldv ) + call stdlib_${ri}$laset( 'A',n-nr,n-nr,zero,one,v(nr+1,nr+1),ldv ) end if - call stdlib_qormqr( 'L','N',n,n,nr,work(2*n+1),n,work(n+1),v,ldv,work(2*n+n*nr+nr+1)& + call stdlib_${ri}$ormqr( 'L','N',n,n,nr,work(2*n+1),n,work(n+1),v,ldv,work(2*n+n*nr+nr+1)& ,lwork-2*n-n*nr-nr,ierr ) ! permute the rows of v using the (column) permutation from the ! first qrf. also, scale the columns to make them unit in ! euclidean norm. this applies to all cases. - temp1 = sqrt(real(n,KIND=qp)) * epsln + temp1 = sqrt(real(n,KIND=${rk}$)) * epsln do q = 1, n do p = 1, n work(2*n+n*nr+nr+iwork(p)) = v(p,q) @@ -6681,34 +6682,34 @@ module stdlib_linalg_lapack_q do p = 1, n v(p,q) = work(2*n+n*nr+nr+p) end do - xsc = one / stdlib_qnrm2( n, v(1,q), 1 ) - if ( (xsc < (one-temp1)) .or. (xsc > (one+temp1)) )call stdlib_qscal( n, xsc, & + xsc = one / stdlib_${ri}$nrm2( n, v(1,q), 1 ) + if ( (xsc < (one-temp1)) .or. (xsc > (one+temp1)) )call stdlib_${ri}$scal( n, xsc, & v(1,q), 1 ) end do ! at this moment, v contains the right singular vectors of a. ! next, assemble the left singular vector matrix u (m x n). if ( nr < m ) then - call stdlib_qlaset( 'A', m-nr, nr, zero, zero, u(nr+1,1), ldu ) + call stdlib_${ri}$laset( 'A', m-nr, nr, zero, zero, u(nr+1,1), ldu ) if ( nr < n1 ) then - call stdlib_qlaset( 'A',nr, n1-nr, zero, zero, u(1,nr+1),ldu ) - call stdlib_qlaset( 'A',m-nr,n1-nr, zero, one,u(nr+1,nr+1),ldu ) + call stdlib_${ri}$laset( 'A',nr, n1-nr, zero, zero, u(1,nr+1),ldu ) + call stdlib_${ri}$laset( 'A',m-nr,n1-nr, zero, one,u(nr+1,nr+1),ldu ) end if end if - call stdlib_qormqr( 'LEFT', 'NO TR', m, n1, n, a, lda, work, u,ldu, work(n+1), & + call stdlib_${ri}$ormqr( 'LEFT', 'NO TR', m, n1, n, a, lda, work, u,ldu, work(n+1), & lwork-n, ierr ) - if ( rowpiv )call stdlib_qlaswp( n1, u, ldu, 1, m-1, iwork(2*n+1), -1 ) + if ( rowpiv )call stdlib_${ri}$laswp( n1, u, ldu, 1, m-1, iwork(2*n+1), -1 ) end if if ( transp ) then ! .. swap u and v because the procedure worked on a^t do p = 1, n - call stdlib_qswap( n, u(1,p), 1, v(1,p), 1 ) + call stdlib_${ri}$swap( n, u(1,p), 1, v(1,p), 1 ) end do end if end if ! end of the full svd ! undo scaling, if necessary (and possible) if ( uscal2 <= (big/sva(1))*uscal1 ) then - call stdlib_qlascl( 'G', 0, 0, uscal1, uscal2, nr, 1, sva, n, ierr ) + call stdlib_${ri}$lascl( 'G', 0, 0, uscal1, uscal2, nr, 1, sva, n, ierr ) uscal1 = one uscal2 = one end if @@ -6732,10 +6733,10 @@ module stdlib_linalg_lapack_q iwork(2) = numrank iwork(3) = warning return - end subroutine stdlib_qgejsv + end subroutine stdlib_${ri}$gejsv - pure subroutine stdlib_qgelq( m, n, a, lda, t, tsize, work, lwork,info ) + pure subroutine stdlib_${ri}$gelq( m, n, a, lda, t, tsize, work, lwork,info ) !! DGELQ: computes an LQ factorization of a real M-by-N matrix A: !! A = ( L 0 ) * Q !! where: @@ -6749,8 +6750,8 @@ module stdlib_linalg_lapack_q integer(ilp), intent(out) :: info integer(ilp), intent(in) :: lda, m, n, tsize, lwork ! Array Arguments - real(qp), intent(inout) :: a(lda,*) - real(qp), intent(out) :: t(*), work(*) + real(${rk}$), intent(inout) :: a(lda,*) + real(${rk}$), intent(out) :: t(*), work(*) ! ===================================================================== ! Local Scalars logical(lk) :: lquery, lminws, mint, minw @@ -6851,16 +6852,16 @@ module stdlib_linalg_lapack_q end if ! the lq decomposition if( ( n<=m ) .or. ( nb<=m ) .or. ( nb>=n ) ) then - call stdlib_qgelqt( m, n, mb, a, lda, t( 6 ), mb, work, info ) + call stdlib_${ri}$gelqt( m, n, mb, a, lda, t( 6 ), mb, work, info ) else - call stdlib_qlaswlq( m, n, mb, nb, a, lda, t( 6 ), mb, work,lwork, info ) + call stdlib_${ri}$laswlq( m, n, mb, nb, a, lda, t( 6 ), mb, work,lwork, info ) end if work( 1 ) = lwreq return - end subroutine stdlib_qgelq + end subroutine stdlib_${ri}$gelq - pure subroutine stdlib_qgelq2( m, n, a, lda, tau, work, info ) + pure subroutine stdlib_${ri}$gelq2( m, n, a, lda, tau, work, info ) !! DGELQ2: computes an LQ factorization of a real m-by-n matrix A: !! A = ( L 0 ) * Q !! where: @@ -6874,13 +6875,13 @@ module stdlib_linalg_lapack_q integer(ilp), intent(out) :: info integer(ilp), intent(in) :: lda, m, n ! Array Arguments - real(qp), intent(inout) :: a(lda,*) - real(qp), intent(out) :: tau(*), work(*) + real(${rk}$), intent(inout) :: a(lda,*) + real(${rk}$), intent(out) :: tau(*), work(*) ! ===================================================================== ! Local Scalars integer(ilp) :: i, k - real(qp) :: aii + real(${rk}$) :: aii ! Intrinsic Functions intrinsic :: max,min ! Executable Statements @@ -6900,21 +6901,21 @@ module stdlib_linalg_lapack_q k = min( m, n ) do i = 1, k ! generate elementary reflector h(i) to annihilate a(i,i+1:n) - call stdlib_qlarfg( n-i+1, a( i, i ), a( i, min( i+1, n ) ), lda,tau( i ) ) + call stdlib_${ri}$larfg( n-i+1, a( i, i ), a( i, min( i+1, n ) ), lda,tau( i ) ) if( izero .and. anrmbignum ) then ! scale matrix norm down to bignum - call stdlib_qlascl( 'G', 0, 0, anrm, bignum, m, n, a, lda, info ) + call stdlib_${ri}$lascl( 'G', 0, 0, anrm, bignum, m, n, a, lda, info ) iascl = 2 else if( anrm==zero ) then ! matrix all zero. return zero solution. - call stdlib_qlaset( 'F', max( m, n ), nrhs, zero, zero, b, ldb ) + call stdlib_${ri}$laset( 'F', max( m, n ), nrhs, zero, zero, b, ldb ) go to 50 end if brow = m if( tpsd )brow = n - bnrm = stdlib_qlange( 'M', brow, nrhs, b, ldb, rwork ) + bnrm = stdlib_${ri}$lange( 'M', brow, nrhs, b, ldb, rwork ) ibscl = 0 if( bnrm>zero .and. bnrmbignum ) then ! scale matrix norm down to bignum - call stdlib_qlascl( 'G', 0, 0, bnrm, bignum, brow, nrhs, b, ldb,info ) + call stdlib_${ri}$lascl( 'G', 0, 0, bnrm, bignum, brow, nrhs, b, ldb,info ) ibscl = 2 end if if( m>=n ) then ! compute qr factorization of a - call stdlib_qgeqrf( m, n, a, lda, work( 1 ), work( mn+1 ), lwork-mn,info ) + call stdlib_${ri}$geqrf( m, n, a, lda, work( 1 ), work( mn+1 ), lwork-mn,info ) ! workspace at least n, optimally n*nb if( .not.tpsd ) then ! least-squares problem min || a * x - b || ! b(1:m,1:nrhs) := q**t * b(1:m,1:nrhs) - call stdlib_qormqr( 'LEFT', 'TRANSPOSE', m, nrhs, n, a, lda,work( 1 ), b, ldb, & + call stdlib_${ri}$ormqr( 'LEFT', 'TRANSPOSE', m, nrhs, n, a, lda,work( 1 ), b, ldb, & work( mn+1 ), lwork-mn,info ) ! workspace at least nrhs, optimally nrhs*nb ! b(1:n,1:nrhs) := inv(r) * b(1:n,1:nrhs) - call stdlib_qtrtrs( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', n, nrhs,a, lda, b, ldb, & + call stdlib_${ri}$trtrs( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', n, nrhs,a, lda, b, ldb, & info ) if( info>0 ) then return @@ -7294,7 +7295,7 @@ module stdlib_linalg_lapack_q else ! underdetermined system of equations a**t * x = b ! b(1:n,1:nrhs) := inv(r**t) * b(1:n,1:nrhs) - call stdlib_qtrtrs( 'UPPER', 'TRANSPOSE', 'NON-UNIT', n, nrhs,a, lda, b, ldb, & + call stdlib_${ri}$trtrs( 'UPPER', 'TRANSPOSE', 'NON-UNIT', n, nrhs,a, lda, b, ldb, & info ) if( info>0 ) then return @@ -7306,19 +7307,19 @@ module stdlib_linalg_lapack_q end do end do ! b(1:m,1:nrhs) := q(1:n,:) * b(1:n,1:nrhs) - call stdlib_qormqr( 'LEFT', 'NO TRANSPOSE', m, nrhs, n, a, lda,work( 1 ), b, ldb,& + call stdlib_${ri}$ormqr( 'LEFT', 'NO TRANSPOSE', m, nrhs, n, a, lda,work( 1 ), b, ldb,& work( mn+1 ), lwork-mn,info ) ! workspace at least nrhs, optimally nrhs*nb scllen = m end if else ! compute lq factorization of a - call stdlib_qgelqf( m, n, a, lda, work( 1 ), work( mn+1 ), lwork-mn,info ) + call stdlib_${ri}$gelqf( m, n, a, lda, work( 1 ), work( mn+1 ), lwork-mn,info ) ! workspace at least m, optimally m*nb. if( .not.tpsd ) then ! underdetermined system of equations a * x = b ! b(1:m,1:nrhs) := inv(l) * b(1:m,1:nrhs) - call stdlib_qtrtrs( 'LOWER', 'NO TRANSPOSE', 'NON-UNIT', m, nrhs,a, lda, b, ldb, & + call stdlib_${ri}$trtrs( 'LOWER', 'NO TRANSPOSE', 'NON-UNIT', m, nrhs,a, lda, b, ldb, & info ) if( info>0 ) then return @@ -7330,18 +7331,18 @@ module stdlib_linalg_lapack_q end do end do ! b(1:n,1:nrhs) := q(1:n,:)**t * b(1:m,1:nrhs) - call stdlib_qormlq( 'LEFT', 'TRANSPOSE', n, nrhs, m, a, lda,work( 1 ), b, ldb, & + call stdlib_${ri}$ormlq( 'LEFT', 'TRANSPOSE', n, nrhs, m, a, lda,work( 1 ), b, ldb, & work( mn+1 ), lwork-mn,info ) ! workspace at least nrhs, optimally nrhs*nb scllen = n else ! overdetermined system min || a**t * x - b || ! b(1:n,1:nrhs) := q * b(1:n,1:nrhs) - call stdlib_qormlq( 'LEFT', 'NO TRANSPOSE', n, nrhs, m, a, lda,work( 1 ), b, ldb,& + call stdlib_${ri}$ormlq( 'LEFT', 'NO TRANSPOSE', n, nrhs, m, a, lda,work( 1 ), b, ldb,& work( mn+1 ), lwork-mn,info ) ! workspace at least nrhs, optimally nrhs*nb ! b(1:m,1:nrhs) := inv(l**t) * b(1:m,1:nrhs) - call stdlib_qtrtrs( 'LOWER', 'TRANSPOSE', 'NON-UNIT', m, nrhs,a, lda, b, ldb, & + call stdlib_${ri}$trtrs( 'LOWER', 'TRANSPOSE', 'NON-UNIT', m, nrhs,a, lda, b, ldb, & info ) if( info>0 ) then return @@ -7351,22 +7352,22 @@ module stdlib_linalg_lapack_q end if ! undo scaling if( iascl==1 ) then - call stdlib_qlascl( 'G', 0, 0, anrm, smlnum, scllen, nrhs, b, ldb,info ) + call stdlib_${ri}$lascl( 'G', 0, 0, anrm, smlnum, scllen, nrhs, b, ldb,info ) else if( iascl==2 ) then - call stdlib_qlascl( 'G', 0, 0, anrm, bignum, scllen, nrhs, b, ldb,info ) + call stdlib_${ri}$lascl( 'G', 0, 0, anrm, bignum, scllen, nrhs, b, ldb,info ) end if if( ibscl==1 ) then - call stdlib_qlascl( 'G', 0, 0, smlnum, bnrm, scllen, nrhs, b, ldb,info ) + call stdlib_${ri}$lascl( 'G', 0, 0, smlnum, bnrm, scllen, nrhs, b, ldb,info ) else if( ibscl==2 ) then - call stdlib_qlascl( 'G', 0, 0, bignum, bnrm, scllen, nrhs, b, ldb,info ) + call stdlib_${ri}$lascl( 'G', 0, 0, bignum, bnrm, scllen, nrhs, b, ldb,info ) end if 50 continue - work( 1 ) = real( wsize,KIND=qp) + work( 1 ) = real( wsize,KIND=${rk}$) return - end subroutine stdlib_qgels + end subroutine stdlib_${ri}$gels - subroutine stdlib_qgelsd( m, n, nrhs, a, lda, b, ldb, s, rcond, rank,work, lwork, iwork, & + subroutine stdlib_${ri}$gelsd( m, n, nrhs, a, lda, b, ldb, s, rcond, rank,work, lwork, iwork, & !! DGELSD: computes the minimum-norm solution to a real linear least !! squares problem: !! minimize 2-norm(| b - A*x |) @@ -7399,18 +7400,18 @@ module stdlib_linalg_lapack_q ! Scalar Arguments integer(ilp), intent(out) :: info, rank integer(ilp), intent(in) :: lda, ldb, lwork, m, n, nrhs - real(qp), intent(in) :: rcond + real(${rk}$), intent(in) :: rcond ! Array Arguments integer(ilp), intent(out) :: iwork(*) - real(qp), intent(inout) :: a(lda,*), b(ldb,*) - real(qp), intent(out) :: s(*), work(*) + real(${rk}$), intent(inout) :: a(lda,*), b(ldb,*) + real(${rk}$), intent(out) :: s(*), work(*) ! ===================================================================== ! Local Scalars logical(lk) :: lquery integer(ilp) :: iascl, ibscl, ie, il, itau, itaup, itauq, ldwork, liwork, maxmn, & maxwrk, minmn, minwrk, mm, mnthr, nlvl, nwork, smlsiz, wlalsd - real(qp) :: anrm, bignum, bnrm, eps, sfmin, smlnum + real(${rk}$) :: anrm, bignum, bnrm, eps, sfmin, smlnum ! Intrinsic Functions intrinsic :: real,int,log,max,min ! Executable Statements @@ -7441,7 +7442,7 @@ module stdlib_linalg_lapack_q minwrk = 1 liwork = 1 minmn = max( 1, minmn ) - nlvl = max( int( log( real( minmn,KIND=qp) / real( smlsiz+1,KIND=qp) ) /log( two ),& + nlvl = max( int( log( real( minmn,KIND=${rk}$) / real( smlsiz+1,KIND=${rk}$) ) /log( two ),& KIND=ilp) + 1, 0 ) if( info==0 ) then maxwrk = 0 @@ -7520,43 +7521,43 @@ module stdlib_linalg_lapack_q return end if ! get machine parameters. - eps = stdlib_qlamch( 'P' ) - sfmin = stdlib_qlamch( 'S' ) + eps = stdlib_${ri}$lamch( 'P' ) + sfmin = stdlib_${ri}$lamch( 'S' ) smlnum = sfmin / eps bignum = one / smlnum - call stdlib_qlabad( smlnum, bignum ) + call stdlib_${ri}$labad( smlnum, bignum ) ! scale a if max entry outside range [smlnum,bignum]. - anrm = stdlib_qlange( 'M', m, n, a, lda, work ) + anrm = stdlib_${ri}$lange( 'M', m, n, a, lda, work ) iascl = 0 if( anrm>zero .and. anrmbignum ) then ! scale matrix norm down to bignum. - call stdlib_qlascl( 'G', 0, 0, anrm, bignum, m, n, a, lda, info ) + call stdlib_${ri}$lascl( 'G', 0, 0, anrm, bignum, m, n, a, lda, info ) iascl = 2 else if( anrm==zero ) then ! matrix all zero. return zero solution. - call stdlib_qlaset( 'F', max( m, n ), nrhs, zero, zero, b, ldb ) - call stdlib_qlaset( 'F', minmn, 1, zero, zero, s, 1 ) + call stdlib_${ri}$laset( 'F', max( m, n ), nrhs, zero, zero, b, ldb ) + call stdlib_${ri}$laset( 'F', minmn, 1, zero, zero, s, 1 ) rank = 0 go to 10 end if ! scale b if max entry outside range [smlnum,bignum]. - bnrm = stdlib_qlange( 'M', m, nrhs, b, ldb, work ) + bnrm = stdlib_${ri}$lange( 'M', m, nrhs, b, ldb, work ) ibscl = 0 if( bnrm>zero .and. bnrmbignum ) then ! scale matrix norm down to bignum. - call stdlib_qlascl( 'G', 0, 0, bnrm, bignum, m, nrhs, b, ldb, info ) + call stdlib_${ri}$lascl( 'G', 0, 0, bnrm, bignum, m, nrhs, b, ldb, info ) ibscl = 2 end if ! if m < n make sure certain entries of b are zero. - if( m=n ) then ! path 1 - overdetermined or exactly determined. @@ -7568,15 +7569,15 @@ module stdlib_linalg_lapack_q nwork = itau + n ! compute a=q*r. ! (workspace: need 2*n, prefer n+n*nb) - call stdlib_qgeqrf( m, n, a, lda, work( itau ), work( nwork ),lwork-nwork+1, & + call stdlib_${ri}$geqrf( m, n, a, lda, work( itau ), work( nwork ),lwork-nwork+1, & info ) ! multiply b by transpose(q). ! (workspace: need n+nrhs, prefer n+nrhs*nb) - call stdlib_qormqr( 'L', 'T', m, nrhs, n, a, lda, work( itau ), b,ldb, work( & + call stdlib_${ri}$ormqr( 'L', 'T', m, nrhs, n, a, lda, work( itau ), b,ldb, work( & nwork ), lwork-nwork+1, info ) ! zero out below r. if( n>1 ) then - call stdlib_qlaset( 'L', n-1, n-1, zero, zero, a( 2, 1 ), lda ) + call stdlib_${ri}$laset( 'L', n-1, n-1, zero, zero, a( 2, 1 ), lda ) end if end if ie = 1 @@ -7585,20 +7586,20 @@ module stdlib_linalg_lapack_q nwork = itaup + n ! bidiagonalize r in a. ! (workspace: need 3*n+mm, prefer 3*n+(mm+n)*nb) - call stdlib_qgebrd( mm, n, a, lda, s, work( ie ), work( itauq ),work( itaup ), work(& + call stdlib_${ri}$gebrd( mm, n, a, lda, s, work( ie ), work( itauq ),work( itaup ), work(& nwork ), lwork-nwork+1,info ) ! multiply b by transpose of left bidiagonalizing vectors of r. ! (workspace: need 3*n+nrhs, prefer 3*n+nrhs*nb) - call stdlib_qormbr( 'Q', 'L', 'T', mm, nrhs, n, a, lda, work( itauq ),b, ldb, work( & + call stdlib_${ri}$ormbr( 'Q', 'L', 'T', mm, nrhs, n, a, lda, work( itauq ),b, ldb, work( & nwork ), lwork-nwork+1, info ) ! solve the bidiagonal least squares problem. - call stdlib_qlalsd( 'U', smlsiz, n, nrhs, s, work( ie ), b, ldb,rcond, rank, work( & + call stdlib_${ri}$lalsd( 'U', smlsiz, n, nrhs, s, work( ie ), b, ldb,rcond, rank, work( & nwork ), iwork, info ) if( info/=0 ) then go to 10 end if ! multiply b by right bidiagonalizing vectors of r. - call stdlib_qormbr( 'P', 'L', 'N', n, nrhs, n, a, lda, work( itaup ),b, ldb, work( & + call stdlib_${ri}$ormbr( 'P', 'L', 'N', n, nrhs, n, a, lda, work( itaup ),b, ldb, work( & nwork ), lwork-nwork+1, info ) else if( n>=mnthr .and. lwork>=4*m+m*m+max( m, 2*m-4, nrhs, n-3*m, wlalsd ) ) & then @@ -7611,39 +7612,39 @@ module stdlib_linalg_lapack_q nwork = m + 1 ! compute a=l*q. ! (workspace: need 2*m, prefer m+m*nb) - call stdlib_qgelqf( m, n, a, lda, work( itau ), work( nwork ),lwork-nwork+1, info ) + call stdlib_${ri}$gelqf( m, n, a, lda, work( itau ), work( nwork ),lwork-nwork+1, info ) il = nwork ! copy l to work(il), zeroing out above its diagonal. - call stdlib_qlacpy( 'L', m, m, a, lda, work( il ), ldwork ) - call stdlib_qlaset( 'U', m-1, m-1, zero, zero, work( il+ldwork ),ldwork ) + call stdlib_${ri}$lacpy( 'L', m, m, a, lda, work( il ), ldwork ) + call stdlib_${ri}$laset( 'U', m-1, m-1, zero, zero, work( il+ldwork ),ldwork ) ie = il + ldwork*m itauq = ie + m itaup = itauq + m nwork = itaup + m ! bidiagonalize l in work(il). ! (workspace: need m*m+5*m, prefer m*m+4*m+2*m*nb) - call stdlib_qgebrd( m, m, work( il ), ldwork, s, work( ie ),work( itauq ), work( & + call stdlib_${ri}$gebrd( m, m, work( il ), ldwork, s, work( ie ),work( itauq ), work( & itaup ), work( nwork ),lwork-nwork+1, info ) ! multiply b by transpose of left bidiagonalizing vectors of l. ! (workspace: need m*m+4*m+nrhs, prefer m*m+4*m+nrhs*nb) - call stdlib_qormbr( 'Q', 'L', 'T', m, nrhs, m, work( il ), ldwork,work( itauq ), b, & + call stdlib_${ri}$ormbr( 'Q', 'L', 'T', m, nrhs, m, work( il ), ldwork,work( itauq ), b, & ldb, work( nwork ),lwork-nwork+1, info ) ! solve the bidiagonal least squares problem. - call stdlib_qlalsd( 'U', smlsiz, m, nrhs, s, work( ie ), b, ldb,rcond, rank, work( & + call stdlib_${ri}$lalsd( 'U', smlsiz, m, nrhs, s, work( ie ), b, ldb,rcond, rank, work( & nwork ), iwork, info ) if( info/=0 ) then go to 10 end if ! multiply b by right bidiagonalizing vectors of l. - call stdlib_qormbr( 'P', 'L', 'N', m, nrhs, m, work( il ), ldwork,work( itaup ), b, & + call stdlib_${ri}$ormbr( 'P', 'L', 'N', m, nrhs, m, work( il ), ldwork,work( itaup ), b, & ldb, work( nwork ),lwork-nwork+1, info ) ! zero out below first m rows of b. - call stdlib_qlaset( 'F', n-m, nrhs, zero, zero, b( m+1, 1 ), ldb ) + call stdlib_${ri}$laset( 'F', n-m, nrhs, zero, zero, b( m+1, 1 ), ldb ) nwork = itau + m ! multiply transpose(q) by b. ! (workspace: need m+nrhs, prefer m+nrhs*nb) - call stdlib_qormlq( 'L', 'T', n, nrhs, m, a, lda, work( itau ), b,ldb, work( nwork )& + call stdlib_${ri}$ormlq( 'L', 'T', n, nrhs, m, a, lda, work( itau ), b,ldb, work( nwork )& , lwork-nwork+1, info ) else ! path 2 - remaining underdetermined cases. @@ -7653,43 +7654,43 @@ module stdlib_linalg_lapack_q nwork = itaup + m ! bidiagonalize a. ! (workspace: need 3*m+n, prefer 3*m+(m+n)*nb) - call stdlib_qgebrd( m, n, a, lda, s, work( ie ), work( itauq ),work( itaup ), work( & + call stdlib_${ri}$gebrd( m, n, a, lda, s, work( ie ), work( itauq ),work( itaup ), work( & nwork ), lwork-nwork+1,info ) ! multiply b by transpose of left bidiagonalizing vectors. ! (workspace: need 3*m+nrhs, prefer 3*m+nrhs*nb) - call stdlib_qormbr( 'Q', 'L', 'T', m, nrhs, n, a, lda, work( itauq ),b, ldb, work( & + call stdlib_${ri}$ormbr( 'Q', 'L', 'T', m, nrhs, n, a, lda, work( itauq ),b, ldb, work( & nwork ), lwork-nwork+1, info ) ! solve the bidiagonal least squares problem. - call stdlib_qlalsd( 'L', smlsiz, m, nrhs, s, work( ie ), b, ldb,rcond, rank, work( & + call stdlib_${ri}$lalsd( 'L', smlsiz, m, nrhs, s, work( ie ), b, ldb,rcond, rank, work( & nwork ), iwork, info ) if( info/=0 ) then go to 10 end if ! multiply b by right bidiagonalizing vectors of a. - call stdlib_qormbr( 'P', 'L', 'N', n, nrhs, m, a, lda, work( itaup ),b, ldb, work( & + call stdlib_${ri}$ormbr( 'P', 'L', 'N', n, nrhs, m, a, lda, work( itaup ),b, ldb, work( & nwork ), lwork-nwork+1, info ) end if ! undo scaling. if( iascl==1 ) then - call stdlib_qlascl( 'G', 0, 0, anrm, smlnum, n, nrhs, b, ldb, info ) - call stdlib_qlascl( 'G', 0, 0, smlnum, anrm, minmn, 1, s, minmn,info ) + call stdlib_${ri}$lascl( 'G', 0, 0, anrm, smlnum, n, nrhs, b, ldb, info ) + call stdlib_${ri}$lascl( 'G', 0, 0, smlnum, anrm, minmn, 1, s, minmn,info ) else if( iascl==2 ) then - call stdlib_qlascl( 'G', 0, 0, anrm, bignum, n, nrhs, b, ldb, info ) - call stdlib_qlascl( 'G', 0, 0, bignum, anrm, minmn, 1, s, minmn,info ) + call stdlib_${ri}$lascl( 'G', 0, 0, anrm, bignum, n, nrhs, b, ldb, info ) + call stdlib_${ri}$lascl( 'G', 0, 0, bignum, anrm, minmn, 1, s, minmn,info ) end if if( ibscl==1 ) then - call stdlib_qlascl( 'G', 0, 0, smlnum, bnrm, n, nrhs, b, ldb, info ) + call stdlib_${ri}$lascl( 'G', 0, 0, smlnum, bnrm, n, nrhs, b, ldb, info ) else if( ibscl==2 ) then - call stdlib_qlascl( 'G', 0, 0, bignum, bnrm, n, nrhs, b, ldb, info ) + call stdlib_${ri}$lascl( 'G', 0, 0, bignum, bnrm, n, nrhs, b, ldb, info ) end if 10 continue work( 1 ) = maxwrk iwork( 1 ) = liwork return - end subroutine stdlib_qgelsd + end subroutine stdlib_${ri}$gelsd - subroutine stdlib_qgelss( m, n, nrhs, a, lda, b, ldb, s, rcond, rank,work, lwork, info ) + subroutine stdlib_${ri}$gelss( m, n, nrhs, a, lda, b, ldb, s, rcond, rank,work, lwork, info ) !! DGELSS: computes the minimum norm solution to a real linear least !! squares problem: !! Minimize 2-norm(| b - A*x |). @@ -7709,10 +7710,10 @@ module stdlib_linalg_lapack_q ! Scalar Arguments integer(ilp), intent(out) :: info, rank integer(ilp), intent(in) :: lda, ldb, lwork, m, n, nrhs - real(qp), intent(in) :: rcond + real(${rk}$), intent(in) :: rcond ! Array Arguments - real(qp), intent(inout) :: a(lda,*), b(ldb,*) - real(qp), intent(out) :: s(*), work(*) + real(${rk}$), intent(inout) :: a(lda,*), b(ldb,*) + real(${rk}$), intent(out) :: s(*), work(*) ! ===================================================================== ! Local Scalars @@ -7721,9 +7722,9 @@ module stdlib_linalg_lapack_q ldwork, maxmn, maxwrk, minmn, minwrk, mm, mnthr integer(ilp) :: lwork_qgeqrf, lwork_qormqr, lwork_qgebrd, lwork_qormbr, lwork_qorgbr, & lwork_qormlq, lwork_qgelqf - real(qp) :: anrm, bignum, bnrm, eps, sfmin, smlnum, thr + real(${rk}$) :: anrm, bignum, bnrm, eps, sfmin, smlnum, thr ! Local Arrays - real(qp) :: dum(1) + real(${rk}$) :: dum(1) ! Intrinsic Functions intrinsic :: max,min ! Executable Statements @@ -7758,11 +7759,11 @@ module stdlib_linalg_lapack_q if( m>=n .and. m>=mnthr ) then ! path 1a - overdetermined, with many more rows than ! columns - ! compute space needed for stdlib_qgeqrf - call stdlib_qgeqrf( m, n, a, lda, dum(1), dum(1), -1, info ) + ! compute space needed for stdlib_${ri}$geqrf + call stdlib_${ri}$geqrf( m, n, a, lda, dum(1), dum(1), -1, info ) lwork_qgeqrf=dum(1) - ! compute space needed for stdlib_qormqr - call stdlib_qormqr( 'L', 'T', m, nrhs, n, a, lda, dum(1), b,ldb, dum(1), -1, & + ! compute space needed for stdlib_${ri}$ormqr + call stdlib_${ri}$ormqr( 'L', 'T', m, nrhs, n, a, lda, dum(1), b,ldb, dum(1), -1, & info ) lwork_qormqr=dum(1) mm = n @@ -7771,18 +7772,18 @@ module stdlib_linalg_lapack_q end if if( m>=n ) then ! path 1 - overdetermined or exactly determined - ! compute workspace needed for stdlib_qbdsqr + ! compute workspace needed for stdlib_${ri}$bdsqr bdspac = max( 1, 5*n ) - ! compute space needed for stdlib_qgebrd - call stdlib_qgebrd( mm, n, a, lda, s, dum(1), dum(1),dum(1), dum(1), -1, info & + ! compute space needed for stdlib_${ri}$gebrd + call stdlib_${ri}$gebrd( mm, n, a, lda, s, dum(1), dum(1),dum(1), dum(1), -1, info & ) lwork_qgebrd=dum(1) - ! compute space needed for stdlib_qormbr - call stdlib_qormbr( 'Q', 'L', 'T', mm, nrhs, n, a, lda, dum(1),b, ldb, dum(1),& + ! compute space needed for stdlib_${ri}$ormbr + call stdlib_${ri}$ormbr( 'Q', 'L', 'T', mm, nrhs, n, a, lda, dum(1),b, ldb, dum(1),& -1, info ) lwork_qormbr=dum(1) - ! compute space needed for stdlib_qorgbr - call stdlib_qorgbr( 'P', n, n, n, a, lda, dum(1),dum(1), -1, info ) + ! compute space needed for stdlib_${ri}$orgbr + call stdlib_${ri}$orgbr( 'P', n, n, n, a, lda, dum(1),dum(1), -1, info ) lwork_qorgbr=dum(1) ! compute total workspace needed maxwrk = max( maxwrk, 3*n + lwork_qgebrd ) @@ -7794,28 +7795,28 @@ module stdlib_linalg_lapack_q maxwrk = max( minwrk, maxwrk ) end if if( n>m ) then - ! compute workspace needed for stdlib_qbdsqr + ! compute workspace needed for stdlib_${ri}$bdsqr bdspac = max( 1, 5*m ) minwrk = max( 3*m+nrhs, 3*m+n, bdspac ) if( n>=mnthr ) then ! path 2a - underdetermined, with many more columns ! than rows - ! compute space needed for stdlib_qgelqf - call stdlib_qgelqf( m, n, a, lda, dum(1), dum(1),-1, info ) + ! compute space needed for stdlib_${ri}$gelqf + call stdlib_${ri}$gelqf( m, n, a, lda, dum(1), dum(1),-1, info ) lwork_qgelqf=dum(1) - ! compute space needed for stdlib_qgebrd - call stdlib_qgebrd( m, m, a, lda, s, dum(1), dum(1),dum(1), dum(1), -1, & + ! compute space needed for stdlib_${ri}$gebrd + call stdlib_${ri}$gebrd( m, m, a, lda, s, dum(1), dum(1),dum(1), dum(1), -1, & info ) lwork_qgebrd=dum(1) - ! compute space needed for stdlib_qormbr - call stdlib_qormbr( 'Q', 'L', 'T', m, nrhs, n, a, lda,dum(1), b, ldb, dum(& + ! compute space needed for stdlib_${ri}$ormbr + call stdlib_${ri}$ormbr( 'Q', 'L', 'T', m, nrhs, n, a, lda,dum(1), b, ldb, dum(& 1), -1, info ) lwork_qormbr=dum(1) - ! compute space needed for stdlib_qorgbr - call stdlib_qorgbr( 'P', m, m, m, a, lda, dum(1),dum(1), -1, info ) + ! compute space needed for stdlib_${ri}$orgbr + call stdlib_${ri}$orgbr( 'P', m, m, m, a, lda, dum(1),dum(1), -1, info ) lwork_qorgbr=dum(1) - ! compute space needed for stdlib_qormlq - call stdlib_qormlq( 'L', 'T', n, nrhs, m, a, lda, dum(1),b, ldb, dum(1), -& + ! compute space needed for stdlib_${ri}$ormlq + call stdlib_${ri}$ormlq( 'L', 'T', n, nrhs, m, a, lda, dum(1),b, ldb, dum(1), -& 1, info ) lwork_qormlq=dum(1) ! compute total workspace needed @@ -7832,16 +7833,16 @@ module stdlib_linalg_lapack_q maxwrk = max( maxwrk, m + lwork_qormlq ) else ! path 2 - underdetermined - ! compute space needed for stdlib_qgebrd - call stdlib_qgebrd( m, n, a, lda, s, dum(1), dum(1),dum(1), dum(1), -1, & + ! compute space needed for stdlib_${ri}$gebrd + call stdlib_${ri}$gebrd( m, n, a, lda, s, dum(1), dum(1),dum(1), dum(1), -1, & info ) lwork_qgebrd=dum(1) - ! compute space needed for stdlib_qormbr - call stdlib_qormbr( 'Q', 'L', 'T', m, nrhs, m, a, lda,dum(1), b, ldb, dum(& + ! compute space needed for stdlib_${ri}$ormbr + call stdlib_${ri}$ormbr( 'Q', 'L', 'T', m, nrhs, m, a, lda,dum(1), b, ldb, dum(& 1), -1, info ) lwork_qormbr=dum(1) - ! compute space needed for stdlib_qorgbr - call stdlib_qorgbr( 'P', m, n, m, a, lda, dum(1),dum(1), -1, info ) + ! compute space needed for stdlib_${ri}$orgbr + call stdlib_${ri}$orgbr( 'P', m, n, m, a, lda, dum(1),dum(1), -1, info ) lwork_qorgbr=dum(1) maxwrk = 3*m + lwork_qgebrd maxwrk = max( maxwrk, 3*m + lwork_qormbr ) @@ -7867,39 +7868,39 @@ module stdlib_linalg_lapack_q return end if ! get machine parameters - eps = stdlib_qlamch( 'P' ) - sfmin = stdlib_qlamch( 'S' ) + eps = stdlib_${ri}$lamch( 'P' ) + sfmin = stdlib_${ri}$lamch( 'S' ) smlnum = sfmin / eps bignum = one / smlnum - call stdlib_qlabad( smlnum, bignum ) + call stdlib_${ri}$labad( smlnum, bignum ) ! scale a if max element outside range [smlnum,bignum] - anrm = stdlib_qlange( 'M', m, n, a, lda, work ) + anrm = stdlib_${ri}$lange( 'M', m, n, a, lda, work ) iascl = 0 if( anrm>zero .and. anrmbignum ) then ! scale matrix norm down to bignum - call stdlib_qlascl( 'G', 0, 0, anrm, bignum, m, n, a, lda, info ) + call stdlib_${ri}$lascl( 'G', 0, 0, anrm, bignum, m, n, a, lda, info ) iascl = 2 else if( anrm==zero ) then ! matrix all zero. return zero solution. - call stdlib_qlaset( 'F', max( m, n ), nrhs, zero, zero, b, ldb ) - call stdlib_qlaset( 'F', minmn, 1, zero, zero, s, minmn ) + call stdlib_${ri}$laset( 'F', max( m, n ), nrhs, zero, zero, b, ldb ) + call stdlib_${ri}$laset( 'F', minmn, 1, zero, zero, s, minmn ) rank = 0 go to 70 end if ! scale b if max element outside range [smlnum,bignum] - bnrm = stdlib_qlange( 'M', m, nrhs, b, ldb, work ) + bnrm = stdlib_${ri}$lange( 'M', m, nrhs, b, ldb, work ) ibscl = 0 if( bnrm>zero .and. bnrmbignum ) then ! scale matrix norm down to bignum - call stdlib_qlascl( 'G', 0, 0, bnrm, bignum, m, nrhs, b, ldb, info ) + call stdlib_${ri}$lascl( 'G', 0, 0, bnrm, bignum, m, nrhs, b, ldb, info ) ibscl = 2 end if ! overdetermined case @@ -7913,14 +7914,14 @@ module stdlib_linalg_lapack_q iwork = itau + n ! compute a=q*r ! (workspace: need 2*n, prefer n+n*nb) - call stdlib_qgeqrf( m, n, a, lda, work( itau ), work( iwork ),lwork-iwork+1, & + call stdlib_${ri}$geqrf( m, n, a, lda, work( itau ), work( iwork ),lwork-iwork+1, & info ) ! multiply b by transpose(q) ! (workspace: need n+nrhs, prefer n+nrhs*nb) - call stdlib_qormqr( 'L', 'T', m, nrhs, n, a, lda, work( itau ), b,ldb, work( & + call stdlib_${ri}$ormqr( 'L', 'T', m, nrhs, n, a, lda, work( itau ), b,ldb, work( & iwork ), lwork-iwork+1, info ) ! zero out below r - if( n>1 )call stdlib_qlaset( 'L', n-1, n-1, zero, zero, a( 2, 1 ), lda ) + if( n>1 )call stdlib_${ri}$laset( 'L', n-1, n-1, zero, zero, a( 2, 1 ), lda ) end if ie = 1 itauq = ie + n @@ -7928,22 +7929,22 @@ module stdlib_linalg_lapack_q iwork = itaup + n ! bidiagonalize r in a ! (workspace: need 3*n+mm, prefer 3*n+(mm+n)*nb) - call stdlib_qgebrd( mm, n, a, lda, s, work( ie ), work( itauq ),work( itaup ), work(& + call stdlib_${ri}$gebrd( mm, n, a, lda, s, work( ie ), work( itauq ),work( itaup ), work(& iwork ), lwork-iwork+1,info ) ! multiply b by transpose of left bidiagonalizing vectors of r ! (workspace: need 3*n+nrhs, prefer 3*n+nrhs*nb) - call stdlib_qormbr( 'Q', 'L', 'T', mm, nrhs, n, a, lda, work( itauq ),b, ldb, work( & + call stdlib_${ri}$ormbr( 'Q', 'L', 'T', mm, nrhs, n, a, lda, work( itauq ),b, ldb, work( & iwork ), lwork-iwork+1, info ) ! generate right bidiagonalizing vectors of r in a ! (workspace: need 4*n-1, prefer 3*n+(n-1)*nb) - call stdlib_qorgbr( 'P', n, n, n, a, lda, work( itaup ),work( iwork ), lwork-iwork+& + call stdlib_${ri}$orgbr( 'P', n, n, n, a, lda, work( itaup ),work( iwork ), lwork-iwork+& 1, info ) iwork = ie + n ! perform bidiagonal qr iteration ! multiply b by transpose of left singular vectors ! compute right singular vectors in a ! (workspace: need bdspac) - call stdlib_qbdsqr( 'U', n, n, 0, nrhs, s, work( ie ), a, lda, dum,1, b, ldb, work( & + call stdlib_${ri}$bdsqr( 'U', n, n, 0, nrhs, s, work( ie ), a, lda, dum,1, b, ldb, work( & iwork ), info ) if( info/=0 )go to 70 ! multiply b by reciprocals of singular values @@ -7952,29 +7953,29 @@ module stdlib_linalg_lapack_q rank = 0 do i = 1, n if( s( i )>thr ) then - call stdlib_qrscl( nrhs, s( i ), b( i, 1 ), ldb ) + call stdlib_${ri}$rscl( nrhs, s( i ), b( i, 1 ), ldb ) rank = rank + 1 else - call stdlib_qlaset( 'F', 1, nrhs, zero, zero, b( i, 1 ), ldb ) + call stdlib_${ri}$laset( 'F', 1, nrhs, zero, zero, b( i, 1 ), ldb ) end if end do ! multiply b by right singular vectors ! (workspace: need n, prefer n*nrhs) if( lwork>=ldb*nrhs .and. nrhs>1 ) then - call stdlib_qgemm( 'T', 'N', n, nrhs, n, one, a, lda, b, ldb, zero,work, ldb ) + call stdlib_${ri}$gemm( 'T', 'N', n, nrhs, n, one, a, lda, b, ldb, zero,work, ldb ) - call stdlib_qlacpy( 'G', n, nrhs, work, ldb, b, ldb ) + call stdlib_${ri}$lacpy( 'G', n, nrhs, work, ldb, b, ldb ) else if( nrhs>1 ) then chunk = lwork / n do i = 1, nrhs, chunk bl = min( nrhs-i+1, chunk ) - call stdlib_qgemm( 'T', 'N', n, bl, n, one, a, lda, b( 1, i ),ldb, zero, work,& + call stdlib_${ri}$gemm( 'T', 'N', n, bl, n, one, a, lda, b( 1, i ),ldb, zero, work,& n ) - call stdlib_qlacpy( 'G', n, bl, work, n, b( 1, i ), ldb ) + call stdlib_${ri}$lacpy( 'G', n, bl, work, n, b( 1, i ), ldb ) end do else - call stdlib_qgemv( 'T', n, n, one, a, lda, b, 1, zero, work, 1 ) - call stdlib_qcopy( n, work, 1, b, 1 ) + call stdlib_${ri}$gemv( 'T', n, n, one, a, lda, b, 1, zero, work, 1 ) + call stdlib_${ri}$copy( n, work, 1, b, 1 ) end if else if( n>=mnthr .and. lwork>=4*m+m*m+max( m, 2*m-4, nrhs, n-3*m ) ) then ! path 2a - underdetermined, with many more columns than rows @@ -7986,34 +7987,34 @@ module stdlib_linalg_lapack_q iwork = m + 1 ! compute a=l*q ! (workspace: need 2*m, prefer m+m*nb) - call stdlib_qgelqf( m, n, a, lda, work( itau ), work( iwork ),lwork-iwork+1, info ) + call stdlib_${ri}$gelqf( m, n, a, lda, work( itau ), work( iwork ),lwork-iwork+1, info ) il = iwork ! copy l to work(il), zeroing out above it - call stdlib_qlacpy( 'L', m, m, a, lda, work( il ), ldwork ) - call stdlib_qlaset( 'U', m-1, m-1, zero, zero, work( il+ldwork ),ldwork ) + call stdlib_${ri}$lacpy( 'L', m, m, a, lda, work( il ), ldwork ) + call stdlib_${ri}$laset( 'U', m-1, m-1, zero, zero, work( il+ldwork ),ldwork ) ie = il + ldwork*m itauq = ie + m itaup = itauq + m iwork = itaup + m ! bidiagonalize l in work(il) ! (workspace: need m*m+5*m, prefer m*m+4*m+2*m*nb) - call stdlib_qgebrd( m, m, work( il ), ldwork, s, work( ie ),work( itauq ), work( & + call stdlib_${ri}$gebrd( m, m, work( il ), ldwork, s, work( ie ),work( itauq ), work( & itaup ), work( iwork ),lwork-iwork+1, info ) ! multiply b by transpose of left bidiagonalizing vectors of l ! (workspace: need m*m+4*m+nrhs, prefer m*m+4*m+nrhs*nb) - call stdlib_qormbr( 'Q', 'L', 'T', m, nrhs, m, work( il ), ldwork,work( itauq ), b, & + call stdlib_${ri}$ormbr( 'Q', 'L', 'T', m, nrhs, m, work( il ), ldwork,work( itauq ), b, & ldb, work( iwork ),lwork-iwork+1, info ) ! generate right bidiagonalizing vectors of r in work(il) ! (workspace: need m*m+5*m-1, prefer m*m+4*m+(m-1)*nb) - call stdlib_qorgbr( 'P', m, m, m, work( il ), ldwork, work( itaup ),work( iwork ), & + call stdlib_${ri}$orgbr( 'P', m, m, m, work( il ), ldwork, work( itaup ),work( iwork ), & lwork-iwork+1, info ) iwork = ie + m ! perform bidiagonal qr iteration, ! computing right singular vectors of l in work(il) and ! multiplying b by transpose of left singular vectors ! (workspace: need m*m+m+bdspac) - call stdlib_qbdsqr( 'U', m, m, 0, nrhs, s, work( ie ), work( il ),ldwork, a, lda, b,& + call stdlib_${ri}$bdsqr( 'U', m, m, 0, nrhs, s, work( ie ), work( il ),ldwork, a, lda, b,& ldb, work( iwork ), info ) if( info/=0 )go to 70 ! multiply b by reciprocals of singular values @@ -8022,38 +8023,38 @@ module stdlib_linalg_lapack_q rank = 0 do i = 1, m if( s( i )>thr ) then - call stdlib_qrscl( nrhs, s( i ), b( i, 1 ), ldb ) + call stdlib_${ri}$rscl( nrhs, s( i ), b( i, 1 ), ldb ) rank = rank + 1 else - call stdlib_qlaset( 'F', 1, nrhs, zero, zero, b( i, 1 ), ldb ) + call stdlib_${ri}$laset( 'F', 1, nrhs, zero, zero, b( i, 1 ), ldb ) end if end do iwork = ie ! multiply b by right singular vectors of l in work(il) ! (workspace: need m*m+2*m, prefer m*m+m+m*nrhs) if( lwork>=ldb*nrhs+iwork-1 .and. nrhs>1 ) then - call stdlib_qgemm( 'T', 'N', m, nrhs, m, one, work( il ), ldwork,b, ldb, zero, & + call stdlib_${ri}$gemm( 'T', 'N', m, nrhs, m, one, work( il ), ldwork,b, ldb, zero, & work( iwork ), ldb ) - call stdlib_qlacpy( 'G', m, nrhs, work( iwork ), ldb, b, ldb ) + call stdlib_${ri}$lacpy( 'G', m, nrhs, work( iwork ), ldb, b, ldb ) else if( nrhs>1 ) then chunk = ( lwork-iwork+1 ) / m do i = 1, nrhs, chunk bl = min( nrhs-i+1, chunk ) - call stdlib_qgemm( 'T', 'N', m, bl, m, one, work( il ), ldwork,b( 1, i ), ldb,& + call stdlib_${ri}$gemm( 'T', 'N', m, bl, m, one, work( il ), ldwork,b( 1, i ), ldb,& zero, work( iwork ), m ) - call stdlib_qlacpy( 'G', m, bl, work( iwork ), m, b( 1, i ),ldb ) + call stdlib_${ri}$lacpy( 'G', m, bl, work( iwork ), m, b( 1, i ),ldb ) end do else - call stdlib_qgemv( 'T', m, m, one, work( il ), ldwork, b( 1, 1 ),1, zero, work( & + call stdlib_${ri}$gemv( 'T', m, m, one, work( il ), ldwork, b( 1, 1 ),1, zero, work( & iwork ), 1 ) - call stdlib_qcopy( m, work( iwork ), 1, b( 1, 1 ), 1 ) + call stdlib_${ri}$copy( m, work( iwork ), 1, b( 1, 1 ), 1 ) end if ! zero out below first m rows of b - call stdlib_qlaset( 'F', n-m, nrhs, zero, zero, b( m+1, 1 ), ldb ) + call stdlib_${ri}$laset( 'F', n-m, nrhs, zero, zero, b( m+1, 1 ), ldb ) iwork = itau + m ! multiply transpose(q) by b ! (workspace: need m+nrhs, prefer m+nrhs*nb) - call stdlib_qormlq( 'L', 'T', n, nrhs, m, a, lda, work( itau ), b,ldb, work( iwork )& + call stdlib_${ri}$ormlq( 'L', 'T', n, nrhs, m, a, lda, work( itau ), b,ldb, work( iwork )& , lwork-iwork+1, info ) else ! path 2 - remaining underdetermined cases @@ -8063,22 +8064,22 @@ module stdlib_linalg_lapack_q iwork = itaup + m ! bidiagonalize a ! (workspace: need 3*m+n, prefer 3*m+(m+n)*nb) - call stdlib_qgebrd( m, n, a, lda, s, work( ie ), work( itauq ),work( itaup ), work( & + call stdlib_${ri}$gebrd( m, n, a, lda, s, work( ie ), work( itauq ),work( itaup ), work( & iwork ), lwork-iwork+1,info ) ! multiply b by transpose of left bidiagonalizing vectors ! (workspace: need 3*m+nrhs, prefer 3*m+nrhs*nb) - call stdlib_qormbr( 'Q', 'L', 'T', m, nrhs, n, a, lda, work( itauq ),b, ldb, work( & + call stdlib_${ri}$ormbr( 'Q', 'L', 'T', m, nrhs, n, a, lda, work( itauq ),b, ldb, work( & iwork ), lwork-iwork+1, info ) ! generate right bidiagonalizing vectors in a ! (workspace: need 4*m, prefer 3*m+m*nb) - call stdlib_qorgbr( 'P', m, n, m, a, lda, work( itaup ),work( iwork ), lwork-iwork+& + call stdlib_${ri}$orgbr( 'P', m, n, m, a, lda, work( itaup ),work( iwork ), lwork-iwork+& 1, info ) iwork = ie + m ! perform bidiagonal qr iteration, ! computing right singular vectors of a in a and ! multiplying b by transpose of left singular vectors ! (workspace: need bdspac) - call stdlib_qbdsqr( 'L', m, n, 0, nrhs, s, work( ie ), a, lda, dum,1, b, ldb, work( & + call stdlib_${ri}$bdsqr( 'L', m, n, 0, nrhs, s, work( ie ), a, lda, dum,1, b, ldb, work( & iwork ), info ) if( info/=0 )go to 70 ! multiply b by reciprocals of singular values @@ -8087,51 +8088,51 @@ module stdlib_linalg_lapack_q rank = 0 do i = 1, m if( s( i )>thr ) then - call stdlib_qrscl( nrhs, s( i ), b( i, 1 ), ldb ) + call stdlib_${ri}$rscl( nrhs, s( i ), b( i, 1 ), ldb ) rank = rank + 1 else - call stdlib_qlaset( 'F', 1, nrhs, zero, zero, b( i, 1 ), ldb ) + call stdlib_${ri}$laset( 'F', 1, nrhs, zero, zero, b( i, 1 ), ldb ) end if end do ! multiply b by right singular vectors of a ! (workspace: need n, prefer n*nrhs) if( lwork>=ldb*nrhs .and. nrhs>1 ) then - call stdlib_qgemm( 'T', 'N', n, nrhs, m, one, a, lda, b, ldb, zero,work, ldb ) + call stdlib_${ri}$gemm( 'T', 'N', n, nrhs, m, one, a, lda, b, ldb, zero,work, ldb ) - call stdlib_qlacpy( 'F', n, nrhs, work, ldb, b, ldb ) + call stdlib_${ri}$lacpy( 'F', n, nrhs, work, ldb, b, ldb ) else if( nrhs>1 ) then chunk = lwork / n do i = 1, nrhs, chunk bl = min( nrhs-i+1, chunk ) - call stdlib_qgemm( 'T', 'N', n, bl, m, one, a, lda, b( 1, i ),ldb, zero, work,& + call stdlib_${ri}$gemm( 'T', 'N', n, bl, m, one, a, lda, b( 1, i ),ldb, zero, work,& n ) - call stdlib_qlacpy( 'F', n, bl, work, n, b( 1, i ), ldb ) + call stdlib_${ri}$lacpy( 'F', n, bl, work, n, b( 1, i ), ldb ) end do else - call stdlib_qgemv( 'T', m, n, one, a, lda, b, 1, zero, work, 1 ) - call stdlib_qcopy( n, work, 1, b, 1 ) + call stdlib_${ri}$gemv( 'T', m, n, one, a, lda, b, 1, zero, work, 1 ) + call stdlib_${ri}$copy( n, work, 1, b, 1 ) end if end if ! undo scaling if( iascl==1 ) then - call stdlib_qlascl( 'G', 0, 0, anrm, smlnum, n, nrhs, b, ldb, info ) - call stdlib_qlascl( 'G', 0, 0, smlnum, anrm, minmn, 1, s, minmn,info ) + call stdlib_${ri}$lascl( 'G', 0, 0, anrm, smlnum, n, nrhs, b, ldb, info ) + call stdlib_${ri}$lascl( 'G', 0, 0, smlnum, anrm, minmn, 1, s, minmn,info ) else if( iascl==2 ) then - call stdlib_qlascl( 'G', 0, 0, anrm, bignum, n, nrhs, b, ldb, info ) - call stdlib_qlascl( 'G', 0, 0, bignum, anrm, minmn, 1, s, minmn,info ) + call stdlib_${ri}$lascl( 'G', 0, 0, anrm, bignum, n, nrhs, b, ldb, info ) + call stdlib_${ri}$lascl( 'G', 0, 0, bignum, anrm, minmn, 1, s, minmn,info ) end if if( ibscl==1 ) then - call stdlib_qlascl( 'G', 0, 0, smlnum, bnrm, n, nrhs, b, ldb, info ) + call stdlib_${ri}$lascl( 'G', 0, 0, smlnum, bnrm, n, nrhs, b, ldb, info ) else if( ibscl==2 ) then - call stdlib_qlascl( 'G', 0, 0, bignum, bnrm, n, nrhs, b, ldb, info ) + call stdlib_${ri}$lascl( 'G', 0, 0, bignum, bnrm, n, nrhs, b, ldb, info ) end if 70 continue work( 1 ) = maxwrk return - end subroutine stdlib_qgelss + end subroutine stdlib_${ri}$gelss - subroutine stdlib_qgelsy( m, n, nrhs, a, lda, b, ldb, jpvt, rcond, rank,work, lwork, info ) + subroutine stdlib_${ri}$gelsy( m, n, nrhs, a, lda, b, ldb, jpvt, rcond, rank,work, lwork, info ) !! DGELSY: computes the minimum-norm solution to a real linear least !! squares problem: !! minimize || A * X - B || @@ -8171,11 +8172,11 @@ module stdlib_linalg_lapack_q ! Scalar Arguments integer(ilp), intent(out) :: info, rank integer(ilp), intent(in) :: lda, ldb, lwork, m, n, nrhs - real(qp), intent(in) :: rcond + real(${rk}$), intent(in) :: rcond ! Array Arguments integer(ilp), intent(inout) :: jpvt(*) - real(qp), intent(inout) :: a(lda,*), b(ldb,*) - real(qp), intent(out) :: work(*) + real(${rk}$), intent(inout) :: a(lda,*), b(ldb,*) + real(${rk}$), intent(out) :: work(*) ! ===================================================================== ! Parameters integer(ilp), parameter :: imax = 1 @@ -8186,7 +8187,7 @@ module stdlib_linalg_lapack_q logical(lk) :: lquery integer(ilp) :: i, iascl, ibscl, ismax, ismin, j, lwkmin, lwkopt, mn, nb, nb1, nb2, & nb3, nb4 - real(qp) :: anrm, bignum, bnrm, c1, c2, s1, s2, smax, smaxpr, smin, sminpr, smlnum, & + real(${rk}$) :: anrm, bignum, bnrm, c1, c2, s1, s2, smax, smaxpr, smin, sminpr, smlnum, & wsize ! Intrinsic Functions intrinsic :: abs,max,min @@ -8239,40 +8240,40 @@ module stdlib_linalg_lapack_q return end if ! get machine parameters - smlnum = stdlib_qlamch( 'S' ) / stdlib_qlamch( 'P' ) + smlnum = stdlib_${ri}$lamch( 'S' ) / stdlib_${ri}$lamch( 'P' ) bignum = one / smlnum - call stdlib_qlabad( smlnum, bignum ) + call stdlib_${ri}$labad( smlnum, bignum ) ! scale a, b if max entries outside range [smlnum,bignum] - anrm = stdlib_qlange( 'M', m, n, a, lda, work ) + anrm = stdlib_${ri}$lange( 'M', m, n, a, lda, work ) iascl = 0 if( anrm>zero .and. anrmbignum ) then ! scale matrix norm down to bignum - call stdlib_qlascl( 'G', 0, 0, anrm, bignum, m, n, a, lda, info ) + call stdlib_${ri}$lascl( 'G', 0, 0, anrm, bignum, m, n, a, lda, info ) iascl = 2 else if( anrm==zero ) then ! matrix all zero. return zero solution. - call stdlib_qlaset( 'F', max( m, n ), nrhs, zero, zero, b, ldb ) + call stdlib_${ri}$laset( 'F', max( m, n ), nrhs, zero, zero, b, ldb ) rank = 0 go to 70 end if - bnrm = stdlib_qlange( 'M', m, nrhs, b, ldb, work ) + bnrm = stdlib_${ri}$lange( 'M', m, nrhs, b, ldb, work ) ibscl = 0 if( bnrm>zero .and. bnrmbignum ) then ! scale matrix norm down to bignum - call stdlib_qlascl( 'G', 0, 0, bnrm, bignum, m, nrhs, b, ldb, info ) + call stdlib_${ri}$lascl( 'G', 0, 0, bnrm, bignum, m, nrhs, b, ldb, info ) ibscl = 2 end if ! compute qr factorization with column pivoting of a: ! a * p = q * r - call stdlib_qgeqp3( m, n, a, lda, jpvt, work( 1 ), work( mn+1 ),lwork-mn, info ) + call stdlib_${ri}$geqp3( m, n, a, lda, jpvt, work( 1 ), work( mn+1 ),lwork-mn, info ) wsize = mn + work( mn+1 ) ! workspace: mn+2*n+nb*(n+1). @@ -8284,7 +8285,7 @@ module stdlib_linalg_lapack_q smin = smax if( abs( a( 1, 1 ) )==zero ) then rank = 0 - call stdlib_qlaset( 'F', max( m, n ), nrhs, zero, zero, b, ldb ) + call stdlib_${ri}$laset( 'F', max( m, n ), nrhs, zero, zero, b, ldb ) go to 70 else rank = 1 @@ -8292,9 +8293,9 @@ module stdlib_linalg_lapack_q 10 continue if( rank=max( m, n, & k ) ) ) then - call stdlib_qgemlqt( side, trans, m, n, k, mb, a, lda,t( 6 ), mb, c, ldc, work, info & + call stdlib_${ri}$gemlqt( side, trans, m, n, k, mb, a, lda,t( 6 ), mb, c, ldc, work, info & ) else - call stdlib_qlamswlq( side, trans, m, n, k, mb, nb, a, lda, t( 6 ),mb, c, ldc, work, & + call stdlib_${ri}$lamswlq( side, trans, m, n, k, mb, nb, a, lda, t( 6 ),mb, c, ldc, work, & lwork, info ) end if work( 1 ) = lw return - end subroutine stdlib_qgemlq + end subroutine stdlib_${ri}$gemlq - pure subroutine stdlib_qgemlqt( side, trans, m, n, k, mb, v, ldv, t, ldt,c, ldc, work, info ) + pure subroutine stdlib_${ri}$gemlqt( side, trans, m, n, k, mb, v, ldv, t, ldt,c, ldc, work, info ) !! DGEMLQT: overwrites the general real M-by-N matrix C with !! SIDE = 'L' SIDE = 'R' !! TRANS = 'N': Q C C Q @@ -8480,9 +8481,9 @@ module stdlib_linalg_lapack_q integer(ilp), intent(out) :: info integer(ilp), intent(in) :: k, ldv, ldc, m, n, mb, ldt ! Array Arguments - real(qp), intent(in) :: v(ldv,*), t(ldt,*) - real(qp), intent(inout) :: c(ldc,*) - real(qp), intent(out) :: work(*) + real(${rk}$), intent(in) :: v(ldv,*), t(ldt,*) + real(${rk}$), intent(inout) :: c(ldc,*) + real(${rk}$), intent(out) :: work(*) ! ===================================================================== ! Local Scalars logical(lk) :: left, right, tran, notran @@ -8531,35 +8532,35 @@ module stdlib_linalg_lapack_q if( left .and. notran ) then do i = 1, k, mb ib = min( mb, k-i+1 ) - call stdlib_qlarfb( 'L', 'T', 'F', 'R', m-i+1, n, ib,v( i, i ), ldv, t( 1, i ), & + call stdlib_${ri}$larfb( 'L', 'T', 'F', 'R', m-i+1, n, ib,v( i, i ), ldv, t( 1, i ), & ldt,c( i, 1 ), ldc, work, ldwork ) end do else if( right .and. tran ) then do i = 1, k, mb ib = min( mb, k-i+1 ) - call stdlib_qlarfb( 'R', 'N', 'F', 'R', m, n-i+1, ib,v( i, i ), ldv, t( 1, i ), & + call stdlib_${ri}$larfb( 'R', 'N', 'F', 'R', m, n-i+1, ib,v( i, i ), ldv, t( 1, i ), & ldt,c( 1, i ), ldc, work, ldwork ) end do else if( left .and. tran ) then kf = ((k-1)/mb)*mb+1 do i = kf, 1, -mb ib = min( mb, k-i+1 ) - call stdlib_qlarfb( 'L', 'N', 'F', 'R', m-i+1, n, ib,v( i, i ), ldv, t( 1, i ), & + call stdlib_${ri}$larfb( 'L', 'N', 'F', 'R', m-i+1, n, ib,v( i, i ), ldv, t( 1, i ), & ldt,c( i, 1 ), ldc, work, ldwork ) end do else if( right .and. notran ) then kf = ((k-1)/mb)*mb+1 do i = kf, 1, -mb ib = min( mb, k-i+1 ) - call stdlib_qlarfb( 'R', 'T', 'F', 'R', m, n-i+1, ib,v( i, i ), ldv, t( 1, i ), & + call stdlib_${ri}$larfb( 'R', 'T', 'F', 'R', m, n-i+1, ib,v( i, i ), ldv, t( 1, i ), & ldt,c( 1, i ), ldc, work, ldwork ) end do end if return - end subroutine stdlib_qgemlqt + end subroutine stdlib_${ri}$gemlqt - pure subroutine stdlib_qgemqr( side, trans, m, n, k, a, lda, t, tsize,c, ldc, work, lwork, & + pure subroutine stdlib_${ri}$gemqr( side, trans, m, n, k, a, lda, t, tsize,c, ldc, work, lwork, & !! DGEMQR: overwrites the general real M-by-N matrix C with !! SIDE = 'L' SIDE = 'R' !! TRANS = 'N': Q * C C * Q @@ -8576,9 +8577,9 @@ module stdlib_linalg_lapack_q integer(ilp), intent(out) :: info integer(ilp), intent(in) :: lda, m, n, k, tsize, lwork, ldc ! Array Arguments - real(qp), intent(in) :: a(lda,*), t(*) - real(qp), intent(inout) :: c(ldc,*) - real(qp), intent(out) :: work(*) + real(${rk}$), intent(in) :: a(lda,*), t(*) + real(${rk}$), intent(inout) :: c(ldc,*) + real(${rk}$), intent(out) :: work(*) ! ===================================================================== ! Local Scalars logical(lk) :: left, right, tran, notran, lquery @@ -8645,18 +8646,18 @@ module stdlib_linalg_lapack_q end if if( ( left .and. m<=k ) .or. ( right .and. n<=k ).or. ( mb<=k ) .or. ( mb>=max( m, n, & k ) ) ) then - call stdlib_qgemqrt( side, trans, m, n, k, nb, a, lda, t( 6 ),nb, c, ldc, work, info & + call stdlib_${ri}$gemqrt( side, trans, m, n, k, nb, a, lda, t( 6 ),nb, c, ldc, work, info & ) else - call stdlib_qlamtsqr( side, trans, m, n, k, mb, nb, a, lda, t( 6 ),nb, c, ldc, work, & + call stdlib_${ri}$lamtsqr( side, trans, m, n, k, mb, nb, a, lda, t( 6 ),nb, c, ldc, work, & lwork, info ) end if work( 1 ) = lw return - end subroutine stdlib_qgemqr + end subroutine stdlib_${ri}$gemqr - pure subroutine stdlib_qgemqrt( side, trans, m, n, k, nb, v, ldv, t, ldt,c, ldc, work, info ) + pure subroutine stdlib_${ri}$gemqrt( side, trans, m, n, k, nb, v, ldv, t, ldt,c, ldc, work, info ) !! DGEMQRT: overwrites the general real M-by-N matrix C with !! SIDE = 'L' SIDE = 'R' !! TRANS = 'N': Q C C Q @@ -8675,9 +8676,9 @@ module stdlib_linalg_lapack_q integer(ilp), intent(out) :: info integer(ilp), intent(in) :: k, ldv, ldc, m, n, nb, ldt ! Array Arguments - real(qp), intent(in) :: v(ldv,*), t(ldt,*) - real(qp), intent(inout) :: c(ldc,*) - real(qp), intent(out) :: work(*) + real(${rk}$), intent(in) :: v(ldv,*), t(ldt,*) + real(${rk}$), intent(inout) :: c(ldc,*) + real(${rk}$), intent(out) :: work(*) ! ===================================================================== ! Local Scalars logical(lk) :: left, right, tran, notran @@ -8726,35 +8727,35 @@ module stdlib_linalg_lapack_q if( left .and. tran ) then do i = 1, k, nb ib = min( nb, k-i+1 ) - call stdlib_qlarfb( 'L', 'T', 'F', 'C', m-i+1, n, ib,v( i, i ), ldv, t( 1, i ), & + call stdlib_${ri}$larfb( 'L', 'T', 'F', 'C', m-i+1, n, ib,v( i, i ), ldv, t( 1, i ), & ldt,c( i, 1 ), ldc, work, ldwork ) end do else if( right .and. notran ) then do i = 1, k, nb ib = min( nb, k-i+1 ) - call stdlib_qlarfb( 'R', 'N', 'F', 'C', m, n-i+1, ib,v( i, i ), ldv, t( 1, i ), & + call stdlib_${ri}$larfb( 'R', 'N', 'F', 'C', m, n-i+1, ib,v( i, i ), ldv, t( 1, i ), & ldt,c( 1, i ), ldc, work, ldwork ) end do else if( left .and. notran ) then kf = ((k-1)/nb)*nb+1 do i = kf, 1, -nb ib = min( nb, k-i+1 ) - call stdlib_qlarfb( 'L', 'N', 'F', 'C', m-i+1, n, ib,v( i, i ), ldv, t( 1, i ), & + call stdlib_${ri}$larfb( 'L', 'N', 'F', 'C', m-i+1, n, ib,v( i, i ), ldv, t( 1, i ), & ldt,c( i, 1 ), ldc, work, ldwork ) end do else if( right .and. tran ) then kf = ((k-1)/nb)*nb+1 do i = kf, 1, -nb ib = min( nb, k-i+1 ) - call stdlib_qlarfb( 'R', 'T', 'F', 'C', m, n-i+1, ib,v( i, i ), ldv, t( 1, i ), & + call stdlib_${ri}$larfb( 'R', 'T', 'F', 'C', m, n-i+1, ib,v( i, i ), ldv, t( 1, i ), & ldt,c( 1, i ), ldc, work, ldwork ) end do end if return - end subroutine stdlib_qgemqrt + end subroutine stdlib_${ri}$gemqrt - pure subroutine stdlib_qgeql2( m, n, a, lda, tau, work, info ) + pure subroutine stdlib_${ri}$geql2( m, n, a, lda, tau, work, info ) !! DGEQL2: computes a QL factorization of a real m by n matrix A: !! A = Q * L. ! -- lapack computational routine -- @@ -8764,13 +8765,13 @@ module stdlib_linalg_lapack_q integer(ilp), intent(out) :: info integer(ilp), intent(in) :: lda, m, n ! Array Arguments - real(qp), intent(inout) :: a(lda,*) - real(qp), intent(out) :: tau(*), work(*) + real(${rk}$), intent(inout) :: a(lda,*) + real(${rk}$), intent(out) :: tau(*), work(*) ! ===================================================================== ! Local Scalars integer(ilp) :: i, k - real(qp) :: aii + real(${rk}$) :: aii ! Intrinsic Functions intrinsic :: max,min ! Executable Statements @@ -8791,19 +8792,19 @@ module stdlib_linalg_lapack_q do i = k, 1, -1 ! generate elementary reflector h(i) to annihilate ! a(1:m-k+i-1,n-k+i) - call stdlib_qlarfg( m-k+i, a( m-k+i, n-k+i ), a( 1, n-k+i ), 1,tau( i ) ) + call stdlib_${ri}$larfg( m-k+i, a( m-k+i, n-k+i ), a( 1, n-k+i ), 1,tau( i ) ) ! apply h(i) to a(1:m-k+i,1:n-k+i-1) from the left aii = a( m-k+i, n-k+i ) a( m-k+i, n-k+i ) = one - call stdlib_qlarf( 'LEFT', m-k+i, n-k+i-1, a( 1, n-k+i ), 1, tau( i ),a, lda, work ) + call stdlib_${ri}$larf( 'LEFT', m-k+i, n-k+i-1, a( 1, n-k+i ), 1, tau( i ),a, lda, work ) a( m-k+i, n-k+i ) = aii end do return - end subroutine stdlib_qgeql2 + end subroutine stdlib_${ri}$geql2 - pure subroutine stdlib_qgeqlf( m, n, a, lda, tau, work, lwork, info ) + pure subroutine stdlib_${ri}$geqlf( m, n, a, lda, tau, work, lwork, info ) !! DGEQLF: computes a QL factorization of a real M-by-N matrix A: !! A = Q * L. ! -- lapack computational routine -- @@ -8813,8 +8814,8 @@ module stdlib_linalg_lapack_q integer(ilp), intent(out) :: info integer(ilp), intent(in) :: lda, lwork, m, n ! Array Arguments - real(qp), intent(inout) :: a(lda,*) - real(qp), intent(out) :: tau(*), work(*) + real(${rk}$), intent(inout) :: a(lda,*) + real(${rk}$), intent(out) :: tau(*), work(*) ! ===================================================================== ! Local Scalars logical(lk) :: lquery @@ -8883,15 +8884,15 @@ module stdlib_linalg_lapack_q ib = min( k-i+1, nb ) ! compute the ql factorization of the current block ! a(1:m-k+i+ib-1,n-k+i:n-k+i+ib-1) - call stdlib_qgeql2( m-k+i+ib-1, ib, a( 1, n-k+i ), lda, tau( i ),work, iinfo ) + call stdlib_${ri}$geql2( m-k+i+ib-1, ib, a( 1, n-k+i ), lda, tau( i ),work, iinfo ) if( n-k+i>1 ) then ! form the triangular factor of the block reflector ! h = h(i+ib-1) . . . h(i+1) h(i) - call stdlib_qlarft( 'BACKWARD', 'COLUMNWISE', m-k+i+ib-1, ib,a( 1, n-k+i ), & + call stdlib_${ri}$larft( 'BACKWARD', 'COLUMNWISE', m-k+i+ib-1, ib,a( 1, n-k+i ), & lda, tau( i ), work, ldwork ) ! apply h**t to a(1:m-k+i+ib-1,1:n-k+i-1) from the left - call stdlib_qlarfb( 'LEFT', 'TRANSPOSE', 'BACKWARD','COLUMNWISE', m-k+i+ib-1, & + call stdlib_${ri}$larfb( 'LEFT', 'TRANSPOSE', 'BACKWARD','COLUMNWISE', m-k+i+ib-1, & n-k+i-1, ib,a( 1, n-k+i ), lda, work, ldwork, a, lda,work( ib+1 ), ldwork ) end if @@ -8903,13 +8904,13 @@ module stdlib_linalg_lapack_q nu = n end if ! use unblocked code to factor the last or only block - if( mu>0 .and. nu>0 )call stdlib_qgeql2( mu, nu, a, lda, tau, work, iinfo ) + if( mu>0 .and. nu>0 )call stdlib_${ri}$geql2( mu, nu, a, lda, tau, work, iinfo ) work( 1 ) = iws return - end subroutine stdlib_qgeqlf + end subroutine stdlib_${ri}$geqlf - pure subroutine stdlib_qgeqp3( m, n, a, lda, jpvt, tau, work, lwork, info ) + pure subroutine stdlib_${ri}$geqp3( m, n, a, lda, jpvt, tau, work, lwork, info ) !! DGEQP3: computes a QR factorization with column pivoting of a !! matrix A: A*P = Q*R using Level 3 BLAS. ! -- lapack computational routine -- @@ -8920,8 +8921,8 @@ module stdlib_linalg_lapack_q integer(ilp), intent(in) :: lda, lwork, m, n ! Array Arguments integer(ilp), intent(inout) :: jpvt(*) - real(qp), intent(inout) :: a(lda,*) - real(qp), intent(out) :: tau(*), work(*) + real(${rk}$), intent(inout) :: a(lda,*) + real(${rk}$), intent(out) :: tau(*), work(*) ! ===================================================================== ! Parameters integer(ilp), parameter :: inb = 1 @@ -8972,7 +8973,7 @@ module stdlib_linalg_lapack_q do j = 1, n if( jpvt( j )/=0 ) then if( j/=nfxd ) then - call stdlib_qswap( m, a( 1, j ), 1, a( 1, nfxd ), 1 ) + call stdlib_${ri}$swap( m, a( 1, j ), 1, a( 1, nfxd ), 1 ) jpvt( j ) = jpvt( nfxd ) jpvt( nfxd ) = j else @@ -8990,13 +8991,13 @@ module stdlib_linalg_lapack_q ! remaining columns. if( nfxd>0 ) then na = min( m, nfxd ) - ! cc call stdlib_qgeqr2( m, na, a, lda, tau, work, info ) - call stdlib_qgeqrf( m, na, a, lda, tau, work, lwork, info ) + ! cc call stdlib_${ri}$geqr2( m, na, a, lda, tau, work, info ) + call stdlib_${ri}$geqrf( m, na, a, lda, tau, work, lwork, info ) iws = max( iws, int( work( 1 ),KIND=ilp) ) if( na=nbmin ) .and. ( nb=m ) ) then - call stdlib_qgeqrt( m, n, nb, a, lda, t( 6 ), nb, work, info ) + call stdlib_${ri}$geqrt( m, n, nb, a, lda, t( 6 ), nb, work, info ) else - call stdlib_qlatsqr( m, n, mb, nb, a, lda, t( 6 ), nb, work,lwork, info ) + call stdlib_${ri}$latsqr( m, n, mb, nb, a, lda, t( 6 ), nb, work,lwork, info ) end if work( 1 ) = max( 1, nb*n ) return - end subroutine stdlib_qgeqr + end subroutine stdlib_${ri}$geqr - pure subroutine stdlib_qgeqr2( m, n, a, lda, tau, work, info ) + pure subroutine stdlib_${ri}$geqr2( m, n, a, lda, tau, work, info ) !! DGEQR2: computes a QR factorization of a real m-by-n matrix A: !! A = Q * ( R ), !! ( 0 ) @@ -9189,13 +9190,13 @@ module stdlib_linalg_lapack_q integer(ilp), intent(out) :: info integer(ilp), intent(in) :: lda, m, n ! Array Arguments - real(qp), intent(inout) :: a(lda,*) - real(qp), intent(out) :: tau(*), work(*) + real(${rk}$), intent(inout) :: a(lda,*) + real(${rk}$), intent(out) :: tau(*), work(*) ! ===================================================================== ! Local Scalars integer(ilp) :: i, k - real(qp) :: aii + real(${rk}$) :: aii ! Intrinsic Functions intrinsic :: max,min ! Executable Statements @@ -9215,21 +9216,21 @@ module stdlib_linalg_lapack_q k = min( m, n ) do i = 1, k ! generate elementary reflector h(i) to annihilate a(i+1:m,i) - call stdlib_qlarfg( m-i+1, a( i, i ), a( min( i+1, m ), i ), 1,tau( i ) ) + call stdlib_${ri}$larfg( m-i+1, a( i, i ), a( min( i+1, m ), i ), 1,tau( i ) ) if( i t(i,1) - call stdlib_qlarfg( m-i+1, a( i, i ), a( min( i+1, m ), i ), 1,t( i, 1 ) ) + call stdlib_${ri}$larfg( m-i+1, a( i, i ), a( min( i+1, m ), i ), 1,t( i, 1 ) ) if( ieps .and. two*berr( j )<=lstres .and.count<=itmax ) then ! update solution and try again. - call stdlib_qgetrs( trans, n, 1, af, ldaf, ipiv, work( n+1 ), n,info ) - call stdlib_qaxpy( n, one, work( n+1 ), 1, x( 1, j ), 1 ) + call stdlib_${ri}$getrs( trans, n, 1, af, ldaf, ipiv, work( n+1 ), n,info ) + call stdlib_${ri}$axpy( n, one, work( n+1 ), 1, x( 1, j ), 1 ) lstres = berr( j ) count = count + 1 go to 20 @@ -9847,7 +9848,7 @@ module stdlib_linalg_lapack_q ! the i-th component of abs(r)+nz*eps*(abs(op(a))*abs(x)+abs(b)) ! is incremented by safe1 if the i-th component of ! abs(op(a))*abs(x) + abs(b) is less than safe2. - ! use stdlib_qlacn2 to estimate the infinity-norm of the matrix + ! use stdlib_${ri}$lacn2 to estimate the infinity-norm of the matrix ! inv(op(a)) * diag(w), ! where w = abs(r) + nz*eps*( abs(op(a))*abs(x)+abs(b) ))) do i = 1, n @@ -9859,12 +9860,12 @@ module stdlib_linalg_lapack_q end do kase = 0 100 continue - call stdlib_qlacn2( n, work( 2*n+1 ), work( n+1 ), iwork, ferr( j ),kase, isave ) + call stdlib_${ri}$lacn2( n, work( 2*n+1 ), work( n+1 ), iwork, ferr( j ),kase, isave ) if( kase/=0 ) then if( kase==1 ) then ! multiply by diag(w)*inv(op(a)**t). - call stdlib_qgetrs( transt, n, 1, af, ldaf, ipiv, work( n+1 ),n, info ) + call stdlib_${ri}$getrs( transt, n, 1, af, ldaf, ipiv, work( n+1 ),n, info ) do i = 1, n work( n+i ) = work( i )*work( n+i ) @@ -9874,7 +9875,7 @@ module stdlib_linalg_lapack_q do i = 1, n work( n+i ) = work( i )*work( n+i ) end do - call stdlib_qgetrs( trans, n, 1, af, ldaf, ipiv, work( n+1 ), n,info ) + call stdlib_${ri}$getrs( trans, n, 1, af, ldaf, ipiv, work( n+1 ), n,info ) end if go to 100 end if @@ -9886,10 +9887,10 @@ module stdlib_linalg_lapack_q if( lstres/=zero )ferr( j ) = ferr( j ) / lstres end do loop_140 return - end subroutine stdlib_qgerfs + end subroutine stdlib_${ri}$gerfs - pure subroutine stdlib_qgerq2( m, n, a, lda, tau, work, info ) + pure subroutine stdlib_${ri}$gerq2( m, n, a, lda, tau, work, info ) !! DGERQ2: computes an RQ factorization of a real m by n matrix A: !! A = R * Q. ! -- lapack computational routine -- @@ -9899,13 +9900,13 @@ module stdlib_linalg_lapack_q integer(ilp), intent(out) :: info integer(ilp), intent(in) :: lda, m, n ! Array Arguments - real(qp), intent(inout) :: a(lda,*) - real(qp), intent(out) :: tau(*), work(*) + real(${rk}$), intent(inout) :: a(lda,*) + real(${rk}$), intent(out) :: tau(*), work(*) ! ===================================================================== ! Local Scalars integer(ilp) :: i, k - real(qp) :: aii + real(${rk}$) :: aii ! Intrinsic Functions intrinsic :: max,min ! Executable Statements @@ -9926,19 +9927,19 @@ module stdlib_linalg_lapack_q do i = k, 1, -1 ! generate elementary reflector h(i) to annihilate ! a(m-k+i,1:n-k+i-1) - call stdlib_qlarfg( n-k+i, a( m-k+i, n-k+i ), a( m-k+i, 1 ), lda,tau( i ) ) + call stdlib_${ri}$larfg( n-k+i, a( m-k+i, n-k+i ), a( m-k+i, 1 ), lda,tau( i ) ) ! apply h(i) to a(1:m-k+i-1,1:n-k+i) from the right aii = a( m-k+i, n-k+i ) a( m-k+i, n-k+i ) = one - call stdlib_qlarf( 'RIGHT', m-k+i-1, n-k+i, a( m-k+i, 1 ), lda,tau( i ), a, lda, & + call stdlib_${ri}$larf( 'RIGHT', m-k+i-1, n-k+i, a( m-k+i, 1 ), lda,tau( i ), a, lda, & work ) a( m-k+i, n-k+i ) = aii end do return - end subroutine stdlib_qgerq2 + end subroutine stdlib_${ri}$gerq2 - pure subroutine stdlib_qgerqf( m, n, a, lda, tau, work, lwork, info ) + pure subroutine stdlib_${ri}$gerqf( m, n, a, lda, tau, work, lwork, info ) !! DGERQF: computes an RQ factorization of a real M-by-N matrix A: !! A = R * Q. ! -- lapack computational routine -- @@ -9948,8 +9949,8 @@ module stdlib_linalg_lapack_q integer(ilp), intent(out) :: info integer(ilp), intent(in) :: lda, lwork, m, n ! Array Arguments - real(qp), intent(inout) :: a(lda,*) - real(qp), intent(out) :: tau(*), work(*) + real(${rk}$), intent(inout) :: a(lda,*) + real(${rk}$), intent(out) :: tau(*), work(*) ! ===================================================================== ! Local Scalars logical(lk) :: lquery @@ -10018,15 +10019,15 @@ module stdlib_linalg_lapack_q ib = min( k-i+1, nb ) ! compute the rq factorization of the current block ! a(m-k+i:m-k+i+ib-1,1:n-k+i+ib-1) - call stdlib_qgerq2( ib, n-k+i+ib-1, a( m-k+i, 1 ), lda, tau( i ),work, iinfo ) + call stdlib_${ri}$gerq2( ib, n-k+i+ib-1, a( m-k+i, 1 ), lda, tau( i ),work, iinfo ) if( m-k+i>1 ) then ! form the triangular factor of the block reflector ! h = h(i+ib-1) . . . h(i+1) h(i) - call stdlib_qlarft( 'BACKWARD', 'ROWWISE', n-k+i+ib-1, ib,a( m-k+i, 1 ), lda, & + call stdlib_${ri}$larft( 'BACKWARD', 'ROWWISE', n-k+i+ib-1, ib,a( m-k+i, 1 ), lda, & tau( i ), work, ldwork ) ! apply h to a(1:m-k+i-1,1:n-k+i+ib-1) from the right - call stdlib_qlarfb( 'RIGHT', 'NO TRANSPOSE', 'BACKWARD','ROWWISE', m-k+i-1, n-& + call stdlib_${ri}$larfb( 'RIGHT', 'NO TRANSPOSE', 'BACKWARD','ROWWISE', m-k+i-1, n-& k+i+ib-1, ib,a( m-k+i, 1 ), lda, work, ldwork, a, lda,work( ib+1 ), ldwork ) end if @@ -10038,13 +10039,13 @@ module stdlib_linalg_lapack_q nu = n end if ! use unblocked code to factor the last or only block - if( mu>0 .and. nu>0 )call stdlib_qgerq2( mu, nu, a, lda, tau, work, iinfo ) + if( mu>0 .and. nu>0 )call stdlib_${ri}$gerq2( mu, nu, a, lda, tau, work, iinfo ) work( 1 ) = iws return - end subroutine stdlib_qgerqf + end subroutine stdlib_${ri}$gerqf - pure subroutine stdlib_qgesc2( n, a, lda, rhs, ipiv, jpiv, scale ) + pure subroutine stdlib_${ri}$gesc2( n, a, lda, rhs, ipiv, jpiv, scale ) !! DGESC2: solves a system of linear equations !! A * X = scale* RHS !! with a general N-by-N matrix A using the LU factorization with @@ -10054,26 +10055,26 @@ module stdlib_linalg_lapack_q ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments integer(ilp), intent(in) :: lda, n - real(qp), intent(out) :: scale + real(${rk}$), intent(out) :: scale ! Array Arguments integer(ilp), intent(in) :: ipiv(*), jpiv(*) - real(qp), intent(in) :: a(lda,*) - real(qp), intent(inout) :: rhs(*) + real(${rk}$), intent(in) :: a(lda,*) + real(${rk}$), intent(inout) :: rhs(*) ! ===================================================================== ! Local Scalars integer(ilp) :: i, j - real(qp) :: bignum, eps, smlnum, temp + real(${rk}$) :: bignum, eps, smlnum, temp ! Intrinsic Functions intrinsic :: abs ! Executable Statements ! set constant to control overflow - eps = stdlib_qlamch( 'P' ) - smlnum = stdlib_qlamch( 'S' ) / eps + eps = stdlib_${ri}$lamch( 'P' ) + smlnum = stdlib_${ri}$lamch( 'S' ) / eps bignum = one / smlnum - call stdlib_qlabad( smlnum, bignum ) + call stdlib_${ri}$labad( smlnum, bignum ) ! apply permutations ipiv to rhs - call stdlib_qlaswp( 1, rhs, lda, 1, n-1, ipiv, 1 ) + call stdlib_${ri}$laswp( 1, rhs, lda, 1, n-1, ipiv, 1 ) ! solve for l part do i = 1, n - 1 do j = i + 1, n @@ -10083,10 +10084,10 @@ module stdlib_linalg_lapack_q ! solve for u part scale = one ! check for scaling - i = stdlib_iqamax( n, rhs, 1 ) + i = stdlib_i${ri}$amax( n, rhs, 1 ) if( two*smlnum*abs( rhs( i ) )>abs( a( n, n ) ) ) then temp = ( one / two ) / abs( rhs( i ) ) - call stdlib_qscal( n, temp, rhs( 1 ), 1 ) + call stdlib_${ri}$scal( n, temp, rhs( 1 ), 1 ) scale = scale*temp end if do i = n, 1, -1 @@ -10097,12 +10098,12 @@ module stdlib_linalg_lapack_q end do end do ! apply permutations jpiv to the solution (rhs) - call stdlib_qlaswp( 1, rhs, lda, 1, n-1, jpiv, -1 ) + call stdlib_${ri}$laswp( 1, rhs, lda, 1, n-1, jpiv, -1 ) return - end subroutine stdlib_qgesc2 + end subroutine stdlib_${ri}$gesc2 - subroutine stdlib_qgesdd( jobz, m, n, a, lda, s, u, ldu, vt, ldvt,work, lwork, iwork, info ) + subroutine stdlib_${ri}$gesdd( jobz, m, n, a, lda, s, u, ldu, vt, ldvt,work, lwork, iwork, info ) !! DGESDD: computes the singular value decomposition (SVD) of a real !! M-by-N matrix A, optionally computing the left and right singular !! vectors. If singular vectors are desired, it uses a @@ -10132,8 +10133,8 @@ module stdlib_linalg_lapack_q integer(ilp), intent(in) :: lda, ldu, ldvt, lwork, m, n ! Array Arguments integer(ilp), intent(out) :: iwork(*) - real(qp), intent(inout) :: a(lda,*) - real(qp), intent(out) :: s(*), u(ldu,*), vt(ldvt,*), work(*) + real(${rk}$), intent(inout) :: a(lda,*) + real(${rk}$), intent(out) :: s(*), u(ldu,*), vt(ldvt,*), work(*) ! ===================================================================== ! Local Scalars @@ -10145,10 +10146,10 @@ module stdlib_linalg_lapack_q lwork_qorglq_nn, lwork_qorgqr_mm, lwork_qorgqr_mn, lwork_qormbr_prt_mm, & lwork_qormbr_qln_mm, lwork_qormbr_prt_mn, lwork_qormbr_qln_mn, lwork_qormbr_prt_nn, & lwork_qormbr_qln_nn - real(qp) :: anrm, bignum, eps, smlnum + real(${rk}$) :: anrm, bignum, eps, smlnum ! Local Arrays integer(ilp) :: idum(1) - real(qp) :: dum(1) + real(${rk}$) :: dum(1) ! Intrinsic Functions intrinsic :: int,max,min,sqrt ! Executable Statements @@ -10186,41 +10187,41 @@ module stdlib_linalg_lapack_q minwrk = 1 maxwrk = 1 bdspac = 0 - mnthr = int( minmn*11.0_qp / 6.0_qp,KIND=ilp) + mnthr = int( minmn*11.0_${rk}$ / 6.0_${rk}$,KIND=ilp) if( m>=n .and. minmn>0 ) then - ! compute space needed for stdlib_qbdsdc + ! compute space needed for stdlib_${ri}$bdsdc if( wntqn ) then - ! stdlib_qbdsdc needs only 4*n (or 6*n for uplo=l for lapack <= 3.6_qp) + ! stdlib_${ri}$bdsdc needs only 4*n (or 6*n for uplo=l for lapack <= 3.6_${rk}$) ! keep 7*n for backwards compatibility. bdspac = 7*n else bdspac = 3*n*n + 4*n end if ! compute space preferred for each routine - call stdlib_qgebrd( m, n, dum(1), m, dum(1), dum(1), dum(1),dum(1), dum(1), -1, & + call stdlib_${ri}$gebrd( m, n, dum(1), m, dum(1), dum(1), dum(1),dum(1), dum(1), -1, & ierr ) lwork_qgebrd_mn = int( dum(1),KIND=ilp) - call stdlib_qgebrd( n, n, dum(1), n, dum(1), dum(1), dum(1),dum(1), dum(1), -1, & + call stdlib_${ri}$gebrd( n, n, dum(1), n, dum(1), dum(1), dum(1),dum(1), dum(1), -1, & ierr ) lwork_qgebrd_nn = int( dum(1),KIND=ilp) - call stdlib_qgeqrf( m, n, dum(1), m, dum(1), dum(1), -1, ierr ) + call stdlib_${ri}$geqrf( m, n, dum(1), m, dum(1), dum(1), -1, ierr ) lwork_qgeqrf_mn = int( dum(1),KIND=ilp) - call stdlib_qorgbr( 'Q', n, n, n, dum(1), n, dum(1), dum(1), -1,ierr ) + call stdlib_${ri}$orgbr( 'Q', n, n, n, dum(1), n, dum(1), dum(1), -1,ierr ) lwork_qorgbr_q_nn = int( dum(1),KIND=ilp) - call stdlib_qorgqr( m, m, n, dum(1), m, dum(1), dum(1), -1, ierr ) + call stdlib_${ri}$orgqr( m, m, n, dum(1), m, dum(1), dum(1), -1, ierr ) lwork_qorgqr_mm = int( dum(1),KIND=ilp) - call stdlib_qorgqr( m, n, n, dum(1), m, dum(1), dum(1), -1, ierr ) + call stdlib_${ri}$orgqr( m, n, n, dum(1), m, dum(1), dum(1), -1, ierr ) lwork_qorgqr_mn = int( dum(1),KIND=ilp) - call stdlib_qormbr( 'P', 'R', 'T', n, n, n, dum(1), n,dum(1), dum(1), n, dum(1), & + call stdlib_${ri}$ormbr( 'P', 'R', 'T', n, n, n, dum(1), n,dum(1), dum(1), n, dum(1), & -1, ierr ) lwork_qormbr_prt_nn = int( dum(1),KIND=ilp) - call stdlib_qormbr( 'Q', 'L', 'N', n, n, n, dum(1), n,dum(1), dum(1), n, dum(1), & + call stdlib_${ri}$ormbr( 'Q', 'L', 'N', n, n, n, dum(1), n,dum(1), dum(1), n, dum(1), & -1, ierr ) lwork_qormbr_qln_nn = int( dum(1),KIND=ilp) - call stdlib_qormbr( 'Q', 'L', 'N', m, n, n, dum(1), m,dum(1), dum(1), m, dum(1), & + call stdlib_${ri}$ormbr( 'Q', 'L', 'N', m, n, n, dum(1), m,dum(1), dum(1), m, dum(1), & -1, ierr ) lwork_qormbr_qln_mn = int( dum(1),KIND=ilp) - call stdlib_qormbr( 'Q', 'L', 'N', m, m, n, dum(1), m,dum(1), dum(1), m, dum(1), & + call stdlib_${ri}$ormbr( 'Q', 'L', 'N', m, m, n, dum(1), m,dum(1), dum(1), m, dum(1), & -1, ierr ) lwork_qormbr_qln_mm = int( dum(1),KIND=ilp) if( m>=mnthr ) then @@ -10290,39 +10291,39 @@ module stdlib_linalg_lapack_q end if end if else if( minmn>0 ) then - ! compute space needed for stdlib_qbdsdc + ! compute space needed for stdlib_${ri}$bdsdc if( wntqn ) then - ! stdlib_qbdsdc needs only 4*n (or 6*n for uplo=l for lapack <= 3.6_qp) + ! stdlib_${ri}$bdsdc needs only 4*n (or 6*n for uplo=l for lapack <= 3.6_${rk}$) ! keep 7*n for backwards compatibility. bdspac = 7*m else bdspac = 3*m*m + 4*m end if ! compute space preferred for each routine - call stdlib_qgebrd( m, n, dum(1), m, dum(1), dum(1), dum(1),dum(1), dum(1), -1, & + call stdlib_${ri}$gebrd( m, n, dum(1), m, dum(1), dum(1), dum(1),dum(1), dum(1), -1, & ierr ) lwork_qgebrd_mn = int( dum(1),KIND=ilp) - call stdlib_qgebrd( m, m, a, m, s, dum(1), dum(1),dum(1), dum(1), -1, ierr ) + call stdlib_${ri}$gebrd( m, m, a, m, s, dum(1), dum(1),dum(1), dum(1), -1, ierr ) lwork_qgebrd_mm = int( dum(1),KIND=ilp) - call stdlib_qgelqf( m, n, a, m, dum(1), dum(1), -1, ierr ) + call stdlib_${ri}$gelqf( m, n, a, m, dum(1), dum(1), -1, ierr ) lwork_qgelqf_mn = int( dum(1),KIND=ilp) - call stdlib_qorglq( n, n, m, dum(1), n, dum(1), dum(1), -1, ierr ) + call stdlib_${ri}$orglq( n, n, m, dum(1), n, dum(1), dum(1), -1, ierr ) lwork_qorglq_nn = int( dum(1),KIND=ilp) - call stdlib_qorglq( m, n, m, a, m, dum(1), dum(1), -1, ierr ) + call stdlib_${ri}$orglq( m, n, m, a, m, dum(1), dum(1), -1, ierr ) lwork_qorglq_mn = int( dum(1),KIND=ilp) - call stdlib_qorgbr( 'P', m, m, m, a, n, dum(1), dum(1), -1, ierr ) + call stdlib_${ri}$orgbr( 'P', m, m, m, a, n, dum(1), dum(1), -1, ierr ) lwork_qorgbr_p_mm = int( dum(1),KIND=ilp) - call stdlib_qormbr( 'P', 'R', 'T', m, m, m, dum(1), m,dum(1), dum(1), m, dum(1), & + call stdlib_${ri}$ormbr( 'P', 'R', 'T', m, m, m, dum(1), m,dum(1), dum(1), m, dum(1), & -1, ierr ) lwork_qormbr_prt_mm = int( dum(1),KIND=ilp) - call stdlib_qormbr( 'P', 'R', 'T', m, n, m, dum(1), m,dum(1), dum(1), m, dum(1), & + call stdlib_${ri}$ormbr( 'P', 'R', 'T', m, n, m, dum(1), m,dum(1), dum(1), m, dum(1), & -1, ierr ) lwork_qormbr_prt_mn = int( dum(1),KIND=ilp) - call stdlib_qormbr( 'P', 'R', 'T', n, n, m, dum(1), n,dum(1), dum(1), n, dum(1), & + call stdlib_${ri}$ormbr( 'P', 'R', 'T', n, n, m, dum(1), n,dum(1), dum(1), n, dum(1), & -1, ierr ) lwork_qormbr_prt_nn = int( dum(1),KIND=ilp) - call stdlib_qormbr( 'Q', 'L', 'N', m, m, m, dum(1), m,dum(1), dum(1), m, dum(1), & + call stdlib_${ri}$ormbr( 'Q', 'L', 'N', m, m, m, dum(1), m,dum(1), dum(1), m, dum(1), & -1, ierr ) lwork_qormbr_qln_mm = int( dum(1),KIND=ilp) if( n>=mnthr ) then @@ -10393,7 +10394,7 @@ module stdlib_linalg_lapack_q end if end if maxwrk = max( maxwrk, minwrk ) - work( 1 ) = stdlib_qroundup_lwork( maxwrk ) + work( 1 ) = stdlib_${ri}$roundup_lwork( maxwrk ) if( lworkzero .and. anrmbignum ) then iscl = 1 - call stdlib_qlascl( 'G', 0, 0, anrm, bignum, m, n, a, lda, ierr ) + call stdlib_${ri}$lascl( 'G', 0, 0, anrm, bignum, m, n, a, lda, ierr ) end if if( m>=n ) then ! a has at least as many rows as columns. if a has sufficiently @@ -10439,10 +10440,10 @@ module stdlib_linalg_lapack_q ! compute a=q*r ! workspace: need n [tau] + n [work] ! workspace: prefer n [tau] + n*nb [work] - call stdlib_qgeqrf( m, n, a, lda, work( itau ), work( nwork ),lwork - nwork + & + call stdlib_${ri}$geqrf( m, n, a, lda, work( itau ), work( nwork ),lwork - nwork + & 1, ierr ) ! zero out below r - if (n>1) call stdlib_qlaset( 'L', n-1, n-1, zero, zero, a( 2, 1 ), lda ) + if (n>1) call stdlib_${ri}$laset( 'L', n-1, n-1, zero, zero, a( 2, 1 ), lda ) ie = 1 itauq = ie + n itaup = itauq + n @@ -10450,12 +10451,12 @@ module stdlib_linalg_lapack_q ! bidiagonalize r in a ! workspace: need 3*n [e, tauq, taup] + n [work] ! workspace: prefer 3*n [e, tauq, taup] + 2*n*nb [work] - call stdlib_qgebrd( n, n, a, lda, s, work( ie ), work( itauq ),work( itaup ), & + call stdlib_${ri}$gebrd( n, n, a, lda, s, work( ie ), work( itauq ),work( itaup ), & work( nwork ), lwork-nwork+1,ierr ) nwork = ie + n ! perform bidiagonal svd, computing singular values only ! workspace: need n [e] + bdspac - call stdlib_qbdsdc( 'U', 'N', n, s, work( ie ), dum, 1, dum, 1,dum, idum, & + call stdlib_${ri}$bdsdc( 'U', 'N', n, s, work( ie ), dum, 1, dum, 1,dum, idum, & work( nwork ), iwork, info ) else if( wntqo ) then ! path 2 (m >> n, jobz = 'o') @@ -10473,15 +10474,15 @@ module stdlib_linalg_lapack_q ! compute a=q*r ! workspace: need n*n [r] + n [tau] + n [work] ! workspace: prefer n*n [r] + n [tau] + n*nb [work] - call stdlib_qgeqrf( m, n, a, lda, work( itau ), work( nwork ),lwork - nwork + & + call stdlib_${ri}$geqrf( m, n, a, lda, work( itau ), work( nwork ),lwork - nwork + & 1, ierr ) ! copy r to work(ir), zeroing out below it - call stdlib_qlacpy( 'U', n, n, a, lda, work( ir ), ldwrkr ) - call stdlib_qlaset( 'L', n - 1, n - 1, zero, zero, work(ir+1),ldwrkr ) + call stdlib_${ri}$lacpy( 'U', n, n, a, lda, work( ir ), ldwrkr ) + call stdlib_${ri}$laset( 'L', n - 1, n - 1, zero, zero, work(ir+1),ldwrkr ) ! generate q in a ! workspace: need n*n [r] + n [tau] + n [work] ! workspace: prefer n*n [r] + n [tau] + n*nb [work] - call stdlib_qorgqr( m, n, n, a, lda, work( itau ),work( nwork ), lwork - & + call stdlib_${ri}$orgqr( m, n, n, a, lda, work( itau ),work( nwork ), lwork - & nwork + 1, ierr ) ie = itau itauq = ie + n @@ -10490,7 +10491,7 @@ module stdlib_linalg_lapack_q ! bidiagonalize r in work(ir) ! workspace: need n*n [r] + 3*n [e, tauq, taup] + n [work] ! workspace: prefer n*n [r] + 3*n [e, tauq, taup] + 2*n*nb [work] - call stdlib_qgebrd( n, n, work( ir ), ldwrkr, s, work( ie ),work( itauq ), & + call stdlib_${ri}$gebrd( n, n, work( ir ), ldwrkr, s, work( ie ),work( itauq ), & work( itaup ), work( nwork ),lwork - nwork + 1, ierr ) ! work(iu) is n by n iu = nwork @@ -10499,15 +10500,15 @@ module stdlib_linalg_lapack_q ! of bidiagonal matrix in work(iu) and computing right ! singular vectors of bidiagonal matrix in vt ! workspace: need n*n [r] + 3*n [e, tauq, taup] + n*n [u] + bdspac - call stdlib_qbdsdc( 'U', 'I', n, s, work( ie ), work( iu ), n,vt, ldvt, dum, & + call stdlib_${ri}$bdsdc( 'U', 'I', n, s, work( ie ), work( iu ), n,vt, ldvt, dum, & idum, work( nwork ), iwork,info ) ! overwrite work(iu) by left singular vectors of r ! and vt by right singular vectors of r ! workspace: need n*n [r] + 3*n [e, tauq, taup] + n*n [u] + n [work] ! workspace: prefer n*n [r] + 3*n [e, tauq, taup] + n*n [u] + n*nb [work] - call stdlib_qormbr( 'Q', 'L', 'N', n, n, n, work( ir ), ldwrkr,work( itauq ), & + call stdlib_${ri}$ormbr( 'Q', 'L', 'N', n, n, n, work( ir ), ldwrkr,work( itauq ), & work( iu ), n, work( nwork ),lwork - nwork + 1, ierr ) - call stdlib_qormbr( 'P', 'R', 'T', n, n, n, work( ir ), ldwrkr,work( itaup ), & + call stdlib_${ri}$ormbr( 'P', 'R', 'T', n, n, n, work( ir ), ldwrkr,work( itaup ), & vt, ldvt, work( nwork ),lwork - nwork + 1, ierr ) ! multiply q in a by left singular vectors of r in ! work(iu), storing result in work(ir) and copying to a @@ -10515,9 +10516,9 @@ module stdlib_linalg_lapack_q ! workspace: prefer m*n [r] + 3*n [e, tauq, taup] + n*n [u] do i = 1, m, ldwrkr chunk = min( m - i + 1, ldwrkr ) - call stdlib_qgemm( 'N', 'N', chunk, n, n, one, a( i, 1 ),lda, work( iu ), & + call stdlib_${ri}$gemm( 'N', 'N', chunk, n, n, one, a( i, 1 ),lda, work( iu ), & n, zero, work( ir ),ldwrkr ) - call stdlib_qlacpy( 'F', chunk, n, work( ir ), ldwrkr,a( i, 1 ), lda ) + call stdlib_${ri}$lacpy( 'F', chunk, n, work( ir ), ldwrkr,a( i, 1 ), lda ) end do else if( wntqs ) then @@ -10532,15 +10533,15 @@ module stdlib_linalg_lapack_q ! compute a=q*r ! workspace: need n*n [r] + n [tau] + n [work] ! workspace: prefer n*n [r] + n [tau] + n*nb [work] - call stdlib_qgeqrf( m, n, a, lda, work( itau ), work( nwork ),lwork - nwork + & + call stdlib_${ri}$geqrf( m, n, a, lda, work( itau ), work( nwork ),lwork - nwork + & 1, ierr ) ! copy r to work(ir), zeroing out below it - call stdlib_qlacpy( 'U', n, n, a, lda, work( ir ), ldwrkr ) - call stdlib_qlaset( 'L', n - 1, n - 1, zero, zero, work(ir+1),ldwrkr ) + call stdlib_${ri}$lacpy( 'U', n, n, a, lda, work( ir ), ldwrkr ) + call stdlib_${ri}$laset( 'L', n - 1, n - 1, zero, zero, work(ir+1),ldwrkr ) ! generate q in a ! workspace: need n*n [r] + n [tau] + n [work] ! workspace: prefer n*n [r] + n [tau] + n*nb [work] - call stdlib_qorgqr( m, n, n, a, lda, work( itau ),work( nwork ), lwork - & + call stdlib_${ri}$orgqr( m, n, n, a, lda, work( itau ),work( nwork ), lwork - & nwork + 1, ierr ) ie = itau itauq = ie + n @@ -10549,27 +10550,27 @@ module stdlib_linalg_lapack_q ! bidiagonalize r in work(ir) ! workspace: need n*n [r] + 3*n [e, tauq, taup] + n [work] ! workspace: prefer n*n [r] + 3*n [e, tauq, taup] + 2*n*nb [work] - call stdlib_qgebrd( n, n, work( ir ), ldwrkr, s, work( ie ),work( itauq ), & + call stdlib_${ri}$gebrd( n, n, work( ir ), ldwrkr, s, work( ie ),work( itauq ), & work( itaup ), work( nwork ),lwork - nwork + 1, ierr ) ! perform bidiagonal svd, computing left singular vectors ! of bidiagoal matrix in u and computing right singular ! vectors of bidiagonal matrix in vt ! workspace: need n*n [r] + 3*n [e, tauq, taup] + bdspac - call stdlib_qbdsdc( 'U', 'I', n, s, work( ie ), u, ldu, vt,ldvt, dum, idum, & + call stdlib_${ri}$bdsdc( 'U', 'I', n, s, work( ie ), u, ldu, vt,ldvt, dum, idum, & work( nwork ), iwork,info ) ! overwrite u by left singular vectors of r and vt ! by right singular vectors of r ! workspace: need n*n [r] + 3*n [e, tauq, taup] + n [work] ! workspace: prefer n*n [r] + 3*n [e, tauq, taup] + n*nb [work] - call stdlib_qormbr( 'Q', 'L', 'N', n, n, n, work( ir ), ldwrkr,work( itauq ), & + call stdlib_${ri}$ormbr( 'Q', 'L', 'N', n, n, n, work( ir ), ldwrkr,work( itauq ), & u, ldu, work( nwork ),lwork - nwork + 1, ierr ) - call stdlib_qormbr( 'P', 'R', 'T', n, n, n, work( ir ), ldwrkr,work( itaup ), & + call stdlib_${ri}$ormbr( 'P', 'R', 'T', n, n, n, work( ir ), ldwrkr,work( itaup ), & vt, ldvt, work( nwork ),lwork - nwork + 1, ierr ) ! multiply q in a by left singular vectors of r in ! work(ir), storing result in u ! workspace: need n*n [r] - call stdlib_qlacpy( 'F', n, n, u, ldu, work( ir ), ldwrkr ) - call stdlib_qgemm( 'N', 'N', m, n, n, one, a, lda, work( ir ),ldwrkr, zero, u,& + call stdlib_${ri}$lacpy( 'F', n, n, u, ldu, work( ir ), ldwrkr ) + call stdlib_${ri}$gemm( 'N', 'N', m, n, n, one, a, lda, work( ir ),ldwrkr, zero, u,& ldu ) else if( wntqa ) then ! path 4 (m >> n, jobz='a') @@ -10583,16 +10584,16 @@ module stdlib_linalg_lapack_q ! compute a=q*r, copying result to u ! workspace: need n*n [u] + n [tau] + n [work] ! workspace: prefer n*n [u] + n [tau] + n*nb [work] - call stdlib_qgeqrf( m, n, a, lda, work( itau ), work( nwork ),lwork - nwork + & + call stdlib_${ri}$geqrf( m, n, a, lda, work( itau ), work( nwork ),lwork - nwork + & 1, ierr ) - call stdlib_qlacpy( 'L', m, n, a, lda, u, ldu ) + call stdlib_${ri}$lacpy( 'L', m, n, a, lda, u, ldu ) ! generate q in u ! workspace: need n*n [u] + n [tau] + m [work] ! workspace: prefer n*n [u] + n [tau] + m*nb [work] - call stdlib_qorgqr( m, m, n, u, ldu, work( itau ),work( nwork ), lwork - & + call stdlib_${ri}$orgqr( m, m, n, u, ldu, work( itau ),work( nwork ), lwork - & nwork + 1, ierr ) ! produce r in a, zeroing out other entries - if (n>1) call stdlib_qlaset( 'L', n-1, n-1, zero, zero, a( 2, 1 ), lda ) + if (n>1) call stdlib_${ri}$laset( 'L', n-1, n-1, zero, zero, a( 2, 1 ), lda ) ie = itau itauq = ie + n itaup = itauq + n @@ -10600,29 +10601,29 @@ module stdlib_linalg_lapack_q ! bidiagonalize r in a ! workspace: need n*n [u] + 3*n [e, tauq, taup] + n [work] ! workspace: prefer n*n [u] + 3*n [e, tauq, taup] + 2*n*nb [work] - call stdlib_qgebrd( n, n, a, lda, s, work( ie ), work( itauq ),work( itaup ), & + call stdlib_${ri}$gebrd( n, n, a, lda, s, work( ie ), work( itauq ),work( itaup ), & work( nwork ), lwork-nwork+1,ierr ) ! perform bidiagonal svd, computing left singular vectors ! of bidiagonal matrix in work(iu) and computing right ! singular vectors of bidiagonal matrix in vt ! workspace: need n*n [u] + 3*n [e, tauq, taup] + bdspac - call stdlib_qbdsdc( 'U', 'I', n, s, work( ie ), work( iu ), n,vt, ldvt, dum, & + call stdlib_${ri}$bdsdc( 'U', 'I', n, s, work( ie ), work( iu ), n,vt, ldvt, dum, & idum, work( nwork ), iwork,info ) ! overwrite work(iu) by left singular vectors of r and vt ! by right singular vectors of r ! workspace: need n*n [u] + 3*n [e, tauq, taup] + n [work] ! workspace: prefer n*n [u] + 3*n [e, tauq, taup] + n*nb [work] - call stdlib_qormbr( 'Q', 'L', 'N', n, n, n, a, lda,work( itauq ), work( iu ), & + call stdlib_${ri}$ormbr( 'Q', 'L', 'N', n, n, n, a, lda,work( itauq ), work( iu ), & ldwrku,work( nwork ), lwork - nwork + 1, ierr ) - call stdlib_qormbr( 'P', 'R', 'T', n, n, n, a, lda,work( itaup ), vt, ldvt, & + call stdlib_${ri}$ormbr( 'P', 'R', 'T', n, n, n, a, lda,work( itaup ), vt, ldvt, & work( nwork ),lwork - nwork + 1, ierr ) ! multiply q in u by left singular vectors of r in ! work(iu), storing result in a ! workspace: need n*n [u] - call stdlib_qgemm( 'N', 'N', m, n, n, one, u, ldu, work( iu ),ldwrku, zero, a,& + call stdlib_${ri}$gemm( 'N', 'N', m, n, n, one, u, ldu, work( iu ),ldwrku, zero, a,& lda ) ! copy left singular vectors of a from a to u - call stdlib_qlacpy( 'F', m, n, a, lda, u, ldu ) + call stdlib_${ri}$lacpy( 'F', m, n, a, lda, u, ldu ) end if else ! m < mnthr @@ -10635,13 +10636,13 @@ module stdlib_linalg_lapack_q ! bidiagonalize a ! workspace: need 3*n [e, tauq, taup] + m [work] ! workspace: prefer 3*n [e, tauq, taup] + (m+n)*nb [work] - call stdlib_qgebrd( m, n, a, lda, s, work( ie ), work( itauq ),work( itaup ), & + call stdlib_${ri}$gebrd( m, n, a, lda, s, work( ie ), work( itauq ),work( itaup ), & work( nwork ), lwork-nwork+1,ierr ) if( wntqn ) then ! path 5n (m >= n, jobz='n') ! perform bidiagonal svd, only computing singular values ! workspace: need 3*n [e, tauq, taup] + bdspac - call stdlib_qbdsdc( 'U', 'N', n, s, work( ie ), dum, 1, dum, 1,dum, idum, & + call stdlib_${ri}$bdsdc( 'U', 'N', n, s, work( ie ), dum, 1, dum, 1,dum, idum, & work( nwork ), iwork, info ) else if( wntqo ) then ! path 5o (m >= n, jobz='o') @@ -10650,7 +10651,7 @@ module stdlib_linalg_lapack_q ! work( iu ) is m by n ldwrku = m nwork = iu + ldwrku*n - call stdlib_qlaset( 'F', m, n, zero, zero, work( iu ),ldwrku ) + call stdlib_${ri}$laset( 'F', m, n, zero, zero, work( iu ),ldwrku ) ! ir is unused; silence compile warnings ir = -1 else @@ -10666,28 +10667,28 @@ module stdlib_linalg_lapack_q ! of bidiagonal matrix in work(iu) and computing right ! singular vectors of bidiagonal matrix in vt ! workspace: need 3*n [e, tauq, taup] + n*n [u] + bdspac - call stdlib_qbdsdc( 'U', 'I', n, s, work( ie ), work( iu ),ldwrku, vt, ldvt, & + call stdlib_${ri}$bdsdc( 'U', 'I', n, s, work( ie ), work( iu ),ldwrku, vt, ldvt, & dum, idum, work( nwork ),iwork, info ) ! overwrite vt by right singular vectors of a ! workspace: need 3*n [e, tauq, taup] + n*n [u] + n [work] ! workspace: prefer 3*n [e, tauq, taup] + n*n [u] + n*nb [work] - call stdlib_qormbr( 'P', 'R', 'T', n, n, n, a, lda,work( itaup ), vt, ldvt, & + call stdlib_${ri}$ormbr( 'P', 'R', 'T', n, n, n, a, lda,work( itaup ), vt, ldvt, & work( nwork ),lwork - nwork + 1, ierr ) if( lwork >= m*n + 3*n + bdspac ) then ! path 5o-fast ! overwrite work(iu) by left singular vectors of a ! workspace: need 3*n [e, tauq, taup] + m*n [u] + n [work] ! workspace: prefer 3*n [e, tauq, taup] + m*n [u] + n*nb [work] - call stdlib_qormbr( 'Q', 'L', 'N', m, n, n, a, lda,work( itauq ), work( iu & + call stdlib_${ri}$ormbr( 'Q', 'L', 'N', m, n, n, a, lda,work( itauq ), work( iu & ), ldwrku,work( nwork ), lwork - nwork + 1, ierr ) ! copy left singular vectors of a from work(iu) to a - call stdlib_qlacpy( 'F', m, n, work( iu ), ldwrku, a, lda ) + call stdlib_${ri}$lacpy( 'F', m, n, work( iu ), ldwrku, a, lda ) else ! path 5o-slow ! generate q in a ! workspace: need 3*n [e, tauq, taup] + n*n [u] + n [work] ! workspace: prefer 3*n [e, tauq, taup] + n*n [u] + n*nb [work] - call stdlib_qorgbr( 'Q', m, n, n, a, lda, work( itauq ),work( nwork ), & + call stdlib_${ri}$orgbr( 'Q', m, n, n, a, lda, work( itauq ),work( nwork ), & lwork - nwork + 1, ierr ) ! multiply q in a by left singular vectors of ! bidiagonal matrix in work(iu), storing result in @@ -10696,9 +10697,9 @@ module stdlib_linalg_lapack_q ! workspace: prefer 3*n [e, tauq, taup] + n*n [u] + m*n [r] do i = 1, m, ldwrkr chunk = min( m - i + 1, ldwrkr ) - call stdlib_qgemm( 'N', 'N', chunk, n, n, one, a( i, 1 ),lda, work( iu )& + call stdlib_${ri}$gemm( 'N', 'N', chunk, n, n, one, a( i, 1 ),lda, work( iu )& , ldwrku, zero,work( ir ), ldwrkr ) - call stdlib_qlacpy( 'F', chunk, n, work( ir ), ldwrkr,a( i, 1 ), lda ) + call stdlib_${ri}$lacpy( 'F', chunk, n, work( ir ), ldwrkr,a( i, 1 ), lda ) end do end if @@ -10708,16 +10709,16 @@ module stdlib_linalg_lapack_q ! of bidiagonal matrix in u and computing right singular ! vectors of bidiagonal matrix in vt ! workspace: need 3*n [e, tauq, taup] + bdspac - call stdlib_qlaset( 'F', m, n, zero, zero, u, ldu ) - call stdlib_qbdsdc( 'U', 'I', n, s, work( ie ), u, ldu, vt,ldvt, dum, idum, & + call stdlib_${ri}$laset( 'F', m, n, zero, zero, u, ldu ) + call stdlib_${ri}$bdsdc( 'U', 'I', n, s, work( ie ), u, ldu, vt,ldvt, dum, idum, & work( nwork ), iwork,info ) ! overwrite u by left singular vectors of a and vt ! by right singular vectors of a ! workspace: need 3*n [e, tauq, taup] + n [work] ! workspace: prefer 3*n [e, tauq, taup] + n*nb [work] - call stdlib_qormbr( 'Q', 'L', 'N', m, n, n, a, lda,work( itauq ), u, ldu, & + call stdlib_${ri}$ormbr( 'Q', 'L', 'N', m, n, n, a, lda,work( itauq ), u, ldu, & work( nwork ),lwork - nwork + 1, ierr ) - call stdlib_qormbr( 'P', 'R', 'T', n, n, n, a, lda,work( itaup ), vt, ldvt, & + call stdlib_${ri}$ormbr( 'P', 'R', 'T', n, n, n, a, lda,work( itaup ), vt, ldvt, & work( nwork ),lwork - nwork + 1, ierr ) else if( wntqa ) then ! path 5a (m >= n, jobz='a') @@ -10725,20 +10726,20 @@ module stdlib_linalg_lapack_q ! of bidiagonal matrix in u and computing right singular ! vectors of bidiagonal matrix in vt ! workspace: need 3*n [e, tauq, taup] + bdspac - call stdlib_qlaset( 'F', m, m, zero, zero, u, ldu ) - call stdlib_qbdsdc( 'U', 'I', n, s, work( ie ), u, ldu, vt,ldvt, dum, idum, & + call stdlib_${ri}$laset( 'F', m, m, zero, zero, u, ldu ) + call stdlib_${ri}$bdsdc( 'U', 'I', n, s, work( ie ), u, ldu, vt,ldvt, dum, idum, & work( nwork ), iwork,info ) ! set the right corner of u to identity matrix if( m>n ) then - call stdlib_qlaset( 'F', m - n, m - n, zero, one, u(n+1,n+1),ldu ) + call stdlib_${ri}$laset( 'F', m - n, m - n, zero, one, u(n+1,n+1),ldu ) end if ! overwrite u by left singular vectors of a and vt ! by right singular vectors of a ! workspace: need 3*n [e, tauq, taup] + m [work] ! workspace: prefer 3*n [e, tauq, taup] + m*nb [work] - call stdlib_qormbr( 'Q', 'L', 'N', m, m, n, a, lda,work( itauq ), u, ldu, & + call stdlib_${ri}$ormbr( 'Q', 'L', 'N', m, m, n, a, lda,work( itauq ), u, ldu, & work( nwork ),lwork - nwork + 1, ierr ) - call stdlib_qormbr( 'P', 'R', 'T', n, n, m, a, lda,work( itaup ), vt, ldvt, & + call stdlib_${ri}$ormbr( 'P', 'R', 'T', n, n, m, a, lda,work( itaup ), vt, ldvt, & work( nwork ),lwork - nwork + 1, ierr ) end if end if @@ -10755,10 +10756,10 @@ module stdlib_linalg_lapack_q ! compute a=l*q ! workspace: need m [tau] + m [work] ! workspace: prefer m [tau] + m*nb [work] - call stdlib_qgelqf( m, n, a, lda, work( itau ), work( nwork ),lwork - nwork + & + call stdlib_${ri}$gelqf( m, n, a, lda, work( itau ), work( nwork ),lwork - nwork + & 1, ierr ) ! zero out above l - if (m>1) call stdlib_qlaset( 'U', m-1, m-1, zero, zero, a( 1, 2 ), lda ) + if (m>1) call stdlib_${ri}$laset( 'U', m-1, m-1, zero, zero, a( 1, 2 ), lda ) ie = 1 itauq = ie + m itaup = itauq + m @@ -10766,12 +10767,12 @@ module stdlib_linalg_lapack_q ! bidiagonalize l in a ! workspace: need 3*m [e, tauq, taup] + m [work] ! workspace: prefer 3*m [e, tauq, taup] + 2*m*nb [work] - call stdlib_qgebrd( m, m, a, lda, s, work( ie ), work( itauq ),work( itaup ), & + call stdlib_${ri}$gebrd( m, m, a, lda, s, work( ie ), work( itauq ),work( itaup ), & work( nwork ), lwork-nwork+1,ierr ) nwork = ie + m ! perform bidiagonal svd, computing singular values only ! workspace: need m [e] + bdspac - call stdlib_qbdsdc( 'U', 'N', m, s, work( ie ), dum, 1, dum, 1,dum, idum, & + call stdlib_${ri}$bdsdc( 'U', 'N', m, s, work( ie ), dum, 1, dum, 1,dum, idum, & work( nwork ), iwork, info ) else if( wntqo ) then ! path 2t (n >> m, jobz='o') @@ -10793,16 +10794,16 @@ module stdlib_linalg_lapack_q ! compute a=l*q ! workspace: need m*m [vt] + m*m [l] + m [tau] + m [work] ! workspace: prefer m*m [vt] + m*m [l] + m [tau] + m*nb [work] - call stdlib_qgelqf( m, n, a, lda, work( itau ), work( nwork ),lwork - nwork + & + call stdlib_${ri}$gelqf( m, n, a, lda, work( itau ), work( nwork ),lwork - nwork + & 1, ierr ) ! copy l to work(il), zeroing about above it - call stdlib_qlacpy( 'L', m, m, a, lda, work( il ), ldwrkl ) - call stdlib_qlaset( 'U', m - 1, m - 1, zero, zero,work( il + ldwrkl ), ldwrkl & + call stdlib_${ri}$lacpy( 'L', m, m, a, lda, work( il ), ldwrkl ) + call stdlib_${ri}$laset( 'U', m - 1, m - 1, zero, zero,work( il + ldwrkl ), ldwrkl & ) ! generate q in a ! workspace: need m*m [vt] + m*m [l] + m [tau] + m [work] ! workspace: prefer m*m [vt] + m*m [l] + m [tau] + m*nb [work] - call stdlib_qorglq( m, n, m, a, lda, work( itau ),work( nwork ), lwork - & + call stdlib_${ri}$orglq( m, n, m, a, lda, work( itau ),work( nwork ), lwork - & nwork + 1, ierr ) ie = itau itauq = ie + m @@ -10811,21 +10812,21 @@ module stdlib_linalg_lapack_q ! bidiagonalize l in work(il) ! workspace: need m*m [vt] + m*m [l] + 3*m [e, tauq, taup] + m [work] ! workspace: prefer m*m [vt] + m*m [l] + 3*m [e, tauq, taup] + 2*m*nb [work] - call stdlib_qgebrd( m, m, work( il ), ldwrkl, s, work( ie ),work( itauq ), & + call stdlib_${ri}$gebrd( m, m, work( il ), ldwrkl, s, work( ie ),work( itauq ), & work( itaup ), work( nwork ),lwork - nwork + 1, ierr ) ! perform bidiagonal svd, computing left singular vectors ! of bidiagonal matrix in u, and computing right singular ! vectors of bidiagonal matrix in work(ivt) ! workspace: need m*m [vt] + m*m [l] + 3*m [e, tauq, taup] + bdspac - call stdlib_qbdsdc( 'U', 'I', m, s, work( ie ), u, ldu,work( ivt ), m, dum, & + call stdlib_${ri}$bdsdc( 'U', 'I', m, s, work( ie ), u, ldu,work( ivt ), m, dum, & idum, work( nwork ),iwork, info ) ! overwrite u by left singular vectors of l and work(ivt) ! by right singular vectors of l ! workspace: need m*m [vt] + m*m [l] + 3*m [e, tauq, taup] + m [work] ! workspace: prefer m*m [vt] + m*m [l] + 3*m [e, tauq, taup] + m*nb [work] - call stdlib_qormbr( 'Q', 'L', 'N', m, m, m, work( il ), ldwrkl,work( itauq ), & + call stdlib_${ri}$ormbr( 'Q', 'L', 'N', m, m, m, work( il ), ldwrkl,work( itauq ), & u, ldu, work( nwork ),lwork - nwork + 1, ierr ) - call stdlib_qormbr( 'P', 'R', 'T', m, m, m, work( il ), ldwrkl,work( itaup ), & + call stdlib_${ri}$ormbr( 'P', 'R', 'T', m, m, m, work( il ), ldwrkl,work( itaup ), & work( ivt ), m,work( nwork ), lwork - nwork + 1, ierr ) ! multiply right singular vectors of l in work(ivt) by q ! in a, storing result in work(il) and copying to a @@ -10834,9 +10835,9 @@ module stdlib_linalg_lapack_q ! at this point, l is resized as m by chunk. do i = 1, n, chunk blk = min( n - i + 1, chunk ) - call stdlib_qgemm( 'N', 'N', m, blk, m, one, work( ivt ), m,a( 1, i ), lda,& + call stdlib_${ri}$gemm( 'N', 'N', m, blk, m, one, work( ivt ), m,a( 1, i ), lda,& zero, work( il ), ldwrkl ) - call stdlib_qlacpy( 'F', m, blk, work( il ), ldwrkl,a( 1, i ), lda ) + call stdlib_${ri}$lacpy( 'F', m, blk, work( il ), ldwrkl,a( 1, i ), lda ) end do else if( wntqs ) then @@ -10851,16 +10852,16 @@ module stdlib_linalg_lapack_q ! compute a=l*q ! workspace: need m*m [l] + m [tau] + m [work] ! workspace: prefer m*m [l] + m [tau] + m*nb [work] - call stdlib_qgelqf( m, n, a, lda, work( itau ), work( nwork ),lwork - nwork + & + call stdlib_${ri}$gelqf( m, n, a, lda, work( itau ), work( nwork ),lwork - nwork + & 1, ierr ) ! copy l to work(il), zeroing out above it - call stdlib_qlacpy( 'L', m, m, a, lda, work( il ), ldwrkl ) - call stdlib_qlaset( 'U', m - 1, m - 1, zero, zero,work( il + ldwrkl ), ldwrkl & + call stdlib_${ri}$lacpy( 'L', m, m, a, lda, work( il ), ldwrkl ) + call stdlib_${ri}$laset( 'U', m - 1, m - 1, zero, zero,work( il + ldwrkl ), ldwrkl & ) ! generate q in a ! workspace: need m*m [l] + m [tau] + m [work] ! workspace: prefer m*m [l] + m [tau] + m*nb [work] - call stdlib_qorglq( m, n, m, a, lda, work( itau ),work( nwork ), lwork - & + call stdlib_${ri}$orglq( m, n, m, a, lda, work( itau ),work( nwork ), lwork - & nwork + 1, ierr ) ie = itau itauq = ie + m @@ -10869,27 +10870,27 @@ module stdlib_linalg_lapack_q ! bidiagonalize l in work(iu). ! workspace: need m*m [l] + 3*m [e, tauq, taup] + m [work] ! workspace: prefer m*m [l] + 3*m [e, tauq, taup] + 2*m*nb [work] - call stdlib_qgebrd( m, m, work( il ), ldwrkl, s, work( ie ),work( itauq ), & + call stdlib_${ri}$gebrd( m, m, work( il ), ldwrkl, s, work( ie ),work( itauq ), & work( itaup ), work( nwork ),lwork - nwork + 1, ierr ) ! perform bidiagonal svd, computing left singular vectors ! of bidiagonal matrix in u and computing right singular ! vectors of bidiagonal matrix in vt ! workspace: need m*m [l] + 3*m [e, tauq, taup] + bdspac - call stdlib_qbdsdc( 'U', 'I', m, s, work( ie ), u, ldu, vt,ldvt, dum, idum, & + call stdlib_${ri}$bdsdc( 'U', 'I', m, s, work( ie ), u, ldu, vt,ldvt, dum, idum, & work( nwork ), iwork,info ) ! overwrite u by left singular vectors of l and vt ! by right singular vectors of l ! workspace: need m*m [l] + 3*m [e, tauq, taup] + m [work] ! workspace: prefer m*m [l] + 3*m [e, tauq, taup] + m*nb [work] - call stdlib_qormbr( 'Q', 'L', 'N', m, m, m, work( il ), ldwrkl,work( itauq ), & + call stdlib_${ri}$ormbr( 'Q', 'L', 'N', m, m, m, work( il ), ldwrkl,work( itauq ), & u, ldu, work( nwork ),lwork - nwork + 1, ierr ) - call stdlib_qormbr( 'P', 'R', 'T', m, m, m, work( il ), ldwrkl,work( itaup ), & + call stdlib_${ri}$ormbr( 'P', 'R', 'T', m, m, m, work( il ), ldwrkl,work( itaup ), & vt, ldvt, work( nwork ),lwork - nwork + 1, ierr ) ! multiply right singular vectors of l in work(il) by ! q in a, storing result in vt ! workspace: need m*m [l] - call stdlib_qlacpy( 'F', m, m, vt, ldvt, work( il ), ldwrkl ) - call stdlib_qgemm( 'N', 'N', m, n, m, one, work( il ), ldwrkl,a, lda, zero, & + call stdlib_${ri}$lacpy( 'F', m, m, vt, ldvt, work( il ), ldwrkl ) + call stdlib_${ri}$gemm( 'N', 'N', m, n, m, one, work( il ), ldwrkl,a, lda, zero, & vt, ldvt ) else if( wntqa ) then ! path 4t (n >> m, jobz='a') @@ -10903,16 +10904,16 @@ module stdlib_linalg_lapack_q ! compute a=l*q, copying result to vt ! workspace: need m*m [vt] + m [tau] + m [work] ! workspace: prefer m*m [vt] + m [tau] + m*nb [work] - call stdlib_qgelqf( m, n, a, lda, work( itau ), work( nwork ),lwork - nwork + & + call stdlib_${ri}$gelqf( m, n, a, lda, work( itau ), work( nwork ),lwork - nwork + & 1, ierr ) - call stdlib_qlacpy( 'U', m, n, a, lda, vt, ldvt ) + call stdlib_${ri}$lacpy( 'U', m, n, a, lda, vt, ldvt ) ! generate q in vt ! workspace: need m*m [vt] + m [tau] + n [work] ! workspace: prefer m*m [vt] + m [tau] + n*nb [work] - call stdlib_qorglq( n, n, m, vt, ldvt, work( itau ),work( nwork ), lwork - & + call stdlib_${ri}$orglq( n, n, m, vt, ldvt, work( itau ),work( nwork ), lwork - & nwork + 1, ierr ) ! produce l in a, zeroing out other entries - if (m>1) call stdlib_qlaset( 'U', m-1, m-1, zero, zero, a( 1, 2 ), lda ) + if (m>1) call stdlib_${ri}$laset( 'U', m-1, m-1, zero, zero, a( 1, 2 ), lda ) ie = itau itauq = ie + m itaup = itauq + m @@ -10920,29 +10921,29 @@ module stdlib_linalg_lapack_q ! bidiagonalize l in a ! workspace: need m*m [vt] + 3*m [e, tauq, taup] + m [work] ! workspace: prefer m*m [vt] + 3*m [e, tauq, taup] + 2*m*nb [work] - call stdlib_qgebrd( m, m, a, lda, s, work( ie ), work( itauq ),work( itaup ), & + call stdlib_${ri}$gebrd( m, m, a, lda, s, work( ie ), work( itauq ),work( itaup ), & work( nwork ), lwork-nwork+1,ierr ) ! perform bidiagonal svd, computing left singular vectors ! of bidiagonal matrix in u and computing right singular ! vectors of bidiagonal matrix in work(ivt) ! workspace: need m*m [vt] + 3*m [e, tauq, taup] + bdspac - call stdlib_qbdsdc( 'U', 'I', m, s, work( ie ), u, ldu,work( ivt ), ldwkvt, & + call stdlib_${ri}$bdsdc( 'U', 'I', m, s, work( ie ), u, ldu,work( ivt ), ldwkvt, & dum, idum,work( nwork ), iwork, info ) ! overwrite u by left singular vectors of l and work(ivt) ! by right singular vectors of l ! workspace: need m*m [vt] + 3*m [e, tauq, taup]+ m [work] ! workspace: prefer m*m [vt] + 3*m [e, tauq, taup]+ m*nb [work] - call stdlib_qormbr( 'Q', 'L', 'N', m, m, m, a, lda,work( itauq ), u, ldu, & + call stdlib_${ri}$ormbr( 'Q', 'L', 'N', m, m, m, a, lda,work( itauq ), u, ldu, & work( nwork ),lwork - nwork + 1, ierr ) - call stdlib_qormbr( 'P', 'R', 'T', m, m, m, a, lda,work( itaup ), work( ivt ),& + call stdlib_${ri}$ormbr( 'P', 'R', 'T', m, m, m, a, lda,work( itaup ), work( ivt ),& ldwkvt,work( nwork ), lwork - nwork + 1, ierr ) ! multiply right singular vectors of l in work(ivt) by ! q in vt, storing result in a ! workspace: need m*m [vt] - call stdlib_qgemm( 'N', 'N', m, n, m, one, work( ivt ), ldwkvt,vt, ldvt, zero,& + call stdlib_${ri}$gemm( 'N', 'N', m, n, m, one, work( ivt ), ldwkvt,vt, ldvt, zero,& a, lda ) ! copy right singular vectors of a from a to vt - call stdlib_qlacpy( 'F', m, n, a, lda, vt, ldvt ) + call stdlib_${ri}$lacpy( 'F', m, n, a, lda, vt, ldvt ) end if else ! n < mnthr @@ -10955,13 +10956,13 @@ module stdlib_linalg_lapack_q ! bidiagonalize a ! workspace: need 3*m [e, tauq, taup] + n [work] ! workspace: prefer 3*m [e, tauq, taup] + (m+n)*nb [work] - call stdlib_qgebrd( m, n, a, lda, s, work( ie ), work( itauq ),work( itaup ), & + call stdlib_${ri}$gebrd( m, n, a, lda, s, work( ie ), work( itauq ),work( itaup ), & work( nwork ), lwork-nwork+1,ierr ) if( wntqn ) then ! path 5tn (n > m, jobz='n') ! perform bidiagonal svd, only computing singular values ! workspace: need 3*m [e, tauq, taup] + bdspac - call stdlib_qbdsdc( 'L', 'N', m, s, work( ie ), dum, 1, dum, 1,dum, idum, & + call stdlib_${ri}$bdsdc( 'L', 'N', m, s, work( ie ), dum, 1, dum, 1,dum, idum, & work( nwork ), iwork, info ) else if( wntqo ) then ! path 5to (n > m, jobz='o') @@ -10969,7 +10970,7 @@ module stdlib_linalg_lapack_q ivt = nwork if( lwork >= m*n + 3*m + bdspac ) then ! work( ivt ) is m by n - call stdlib_qlaset( 'F', m, n, zero, zero, work( ivt ),ldwkvt ) + call stdlib_${ri}$laset( 'F', m, n, zero, zero, work( ivt ),ldwkvt ) nwork = ivt + ldwkvt*n ! il is unused; silence compile warnings il = -1 @@ -10984,28 +10985,28 @@ module stdlib_linalg_lapack_q ! of bidiagonal matrix in u and computing right singular ! vectors of bidiagonal matrix in work(ivt) ! workspace: need 3*m [e, tauq, taup] + m*m [vt] + bdspac - call stdlib_qbdsdc( 'L', 'I', m, s, work( ie ), u, ldu,work( ivt ), ldwkvt, & + call stdlib_${ri}$bdsdc( 'L', 'I', m, s, work( ie ), u, ldu,work( ivt ), ldwkvt, & dum, idum,work( nwork ), iwork, info ) ! overwrite u by left singular vectors of a ! workspace: need 3*m [e, tauq, taup] + m*m [vt] + m [work] ! workspace: prefer 3*m [e, tauq, taup] + m*m [vt] + m*nb [work] - call stdlib_qormbr( 'Q', 'L', 'N', m, m, n, a, lda,work( itauq ), u, ldu, & + call stdlib_${ri}$ormbr( 'Q', 'L', 'N', m, m, n, a, lda,work( itauq ), u, ldu, & work( nwork ),lwork - nwork + 1, ierr ) if( lwork >= m*n + 3*m + bdspac ) then ! path 5to-fast ! overwrite work(ivt) by left singular vectors of a ! workspace: need 3*m [e, tauq, taup] + m*n [vt] + m [work] ! workspace: prefer 3*m [e, tauq, taup] + m*n [vt] + m*nb [work] - call stdlib_qormbr( 'P', 'R', 'T', m, n, m, a, lda,work( itaup ), work( & + call stdlib_${ri}$ormbr( 'P', 'R', 'T', m, n, m, a, lda,work( itaup ), work( & ivt ), ldwkvt,work( nwork ), lwork - nwork + 1, ierr ) ! copy right singular vectors of a from work(ivt) to a - call stdlib_qlacpy( 'F', m, n, work( ivt ), ldwkvt, a, lda ) + call stdlib_${ri}$lacpy( 'F', m, n, work( ivt ), ldwkvt, a, lda ) else ! path 5to-slow ! generate p**t in a ! workspace: need 3*m [e, tauq, taup] + m*m [vt] + m [work] ! workspace: prefer 3*m [e, tauq, taup] + m*m [vt] + m*nb [work] - call stdlib_qorgbr( 'P', m, n, m, a, lda, work( itaup ),work( nwork ), & + call stdlib_${ri}$orgbr( 'P', m, n, m, a, lda, work( itaup ),work( nwork ), & lwork - nwork + 1, ierr ) ! multiply q in a by right singular vectors of ! bidiagonal matrix in work(ivt), storing result in @@ -11014,9 +11015,9 @@ module stdlib_linalg_lapack_q ! workspace: prefer 3*m [e, tauq, taup] + m*m [vt] + m*n [l] do i = 1, n, chunk blk = min( n - i + 1, chunk ) - call stdlib_qgemm( 'N', 'N', m, blk, m, one, work( ivt ),ldwkvt, a( 1, & + call stdlib_${ri}$gemm( 'N', 'N', m, blk, m, one, work( ivt ),ldwkvt, a( 1, & i ), lda, zero,work( il ), m ) - call stdlib_qlacpy( 'F', m, blk, work( il ), m, a( 1, i ),lda ) + call stdlib_${ri}$lacpy( 'F', m, blk, work( il ), m, a( 1, i ),lda ) end do end if else if( wntqs ) then @@ -11025,16 +11026,16 @@ module stdlib_linalg_lapack_q ! of bidiagonal matrix in u and computing right singular ! vectors of bidiagonal matrix in vt ! workspace: need 3*m [e, tauq, taup] + bdspac - call stdlib_qlaset( 'F', m, n, zero, zero, vt, ldvt ) - call stdlib_qbdsdc( 'L', 'I', m, s, work( ie ), u, ldu, vt,ldvt, dum, idum, & + call stdlib_${ri}$laset( 'F', m, n, zero, zero, vt, ldvt ) + call stdlib_${ri}$bdsdc( 'L', 'I', m, s, work( ie ), u, ldu, vt,ldvt, dum, idum, & work( nwork ), iwork,info ) ! overwrite u by left singular vectors of a and vt ! by right singular vectors of a ! workspace: need 3*m [e, tauq, taup] + m [work] ! workspace: prefer 3*m [e, tauq, taup] + m*nb [work] - call stdlib_qormbr( 'Q', 'L', 'N', m, m, n, a, lda,work( itauq ), u, ldu, & + call stdlib_${ri}$ormbr( 'Q', 'L', 'N', m, m, n, a, lda,work( itauq ), u, ldu, & work( nwork ),lwork - nwork + 1, ierr ) - call stdlib_qormbr( 'P', 'R', 'T', m, n, m, a, lda,work( itaup ), vt, ldvt, & + call stdlib_${ri}$ormbr( 'P', 'R', 'T', m, n, m, a, lda,work( itaup ), vt, ldvt, & work( nwork ),lwork - nwork + 1, ierr ) else if( wntqa ) then ! path 5ta (n > m, jobz='a') @@ -11042,38 +11043,38 @@ module stdlib_linalg_lapack_q ! of bidiagonal matrix in u and computing right singular ! vectors of bidiagonal matrix in vt ! workspace: need 3*m [e, tauq, taup] + bdspac - call stdlib_qlaset( 'F', n, n, zero, zero, vt, ldvt ) - call stdlib_qbdsdc( 'L', 'I', m, s, work( ie ), u, ldu, vt,ldvt, dum, idum, & + call stdlib_${ri}$laset( 'F', n, n, zero, zero, vt, ldvt ) + call stdlib_${ri}$bdsdc( 'L', 'I', m, s, work( ie ), u, ldu, vt,ldvt, dum, idum, & work( nwork ), iwork,info ) ! set the right corner of vt to identity matrix if( n>m ) then - call stdlib_qlaset( 'F', n-m, n-m, zero, one, vt(m+1,m+1),ldvt ) + call stdlib_${ri}$laset( 'F', n-m, n-m, zero, one, vt(m+1,m+1),ldvt ) end if ! overwrite u by left singular vectors of a and vt ! by right singular vectors of a ! workspace: need 3*m [e, tauq, taup] + n [work] ! workspace: prefer 3*m [e, tauq, taup] + n*nb [work] - call stdlib_qormbr( 'Q', 'L', 'N', m, m, n, a, lda,work( itauq ), u, ldu, & + call stdlib_${ri}$ormbr( 'Q', 'L', 'N', m, m, n, a, lda,work( itauq ), u, ldu, & work( nwork ),lwork - nwork + 1, ierr ) - call stdlib_qormbr( 'P', 'R', 'T', n, n, m, a, lda,work( itaup ), vt, ldvt, & + call stdlib_${ri}$ormbr( 'P', 'R', 'T', n, n, m, a, lda,work( itaup ), vt, ldvt, & work( nwork ),lwork - nwork + 1, ierr ) end if end if end if ! undo scaling if necessary if( iscl==1 ) then - if( anrm>bignum )call stdlib_qlascl( 'G', 0, 0, bignum, anrm, minmn, 1, s, minmn,& + if( anrm>bignum )call stdlib_${ri}$lascl( 'G', 0, 0, bignum, anrm, minmn, 1, s, minmn,& ierr ) - if( anrm=n .and. minmn>0 ) then - ! compute space needed for stdlib_qbdsqr + ! compute space needed for stdlib_${ri}$bdsqr mnthr = stdlib_ilaenv( 6, 'DGESVD', jobu // jobvt, m, n, 0, 0 ) bdspac = 5*n - ! compute space needed for stdlib_qgeqrf - call stdlib_qgeqrf( m, n, a, lda, dum(1), dum(1), -1, ierr ) + ! compute space needed for stdlib_${ri}$geqrf + call stdlib_${ri}$geqrf( m, n, a, lda, dum(1), dum(1), -1, ierr ) lwork_qgeqrf = int( dum(1),KIND=ilp) - ! compute space needed for stdlib_qorgqr - call stdlib_qorgqr( m, n, n, a, lda, dum(1), dum(1), -1, ierr ) + ! compute space needed for stdlib_${ri}$orgqr + call stdlib_${ri}$orgqr( m, n, n, a, lda, dum(1), dum(1), -1, ierr ) lwork_qorgqr_n = int( dum(1),KIND=ilp) - call stdlib_qorgqr( m, m, n, a, lda, dum(1), dum(1), -1, ierr ) + call stdlib_${ri}$orgqr( m, m, n, a, lda, dum(1), dum(1), -1, ierr ) lwork_qorgqr_m = int( dum(1),KIND=ilp) - ! compute space needed for stdlib_qgebrd - call stdlib_qgebrd( n, n, a, lda, s, dum(1), dum(1),dum(1), dum(1), -1, ierr ) + ! compute space needed for stdlib_${ri}$gebrd + call stdlib_${ri}$gebrd( n, n, a, lda, s, dum(1), dum(1),dum(1), dum(1), -1, ierr ) lwork_qgebrd = int( dum(1),KIND=ilp) - ! compute space needed for stdlib_qorgbr p - call stdlib_qorgbr( 'P', n, n, n, a, lda, dum(1),dum(1), -1, ierr ) + ! compute space needed for stdlib_${ri}$orgbr p + call stdlib_${ri}$orgbr( 'P', n, n, n, a, lda, dum(1),dum(1), -1, ierr ) lwork_qorgbr_p = int( dum(1),KIND=ilp) - ! compute space needed for stdlib_qorgbr q - call stdlib_qorgbr( 'Q', n, n, n, a, lda, dum(1),dum(1), -1, ierr ) + ! compute space needed for stdlib_${ri}$orgbr q + call stdlib_${ri}$orgbr( 'Q', n, n, n, a, lda, dum(1),dum(1), -1, ierr ) lwork_qorgbr_q = int( dum(1),KIND=ilp) if( m>=mnthr ) then if( wntun ) then @@ -11313,17 +11314,17 @@ module stdlib_linalg_lapack_q end if else ! path 10 (m at least n, but not much larger) - call stdlib_qgebrd( m, n, a, lda, s, dum(1), dum(1),dum(1), dum(1), -1, ierr ) + call stdlib_${ri}$gebrd( m, n, a, lda, s, dum(1), dum(1),dum(1), dum(1), -1, ierr ) lwork_qgebrd = int( dum(1),KIND=ilp) maxwrk = 3*n + lwork_qgebrd if( wntus .or. wntuo ) then - call stdlib_qorgbr( 'Q', m, n, n, a, lda, dum(1),dum(1), -1, ierr ) + call stdlib_${ri}$orgbr( 'Q', m, n, n, a, lda, dum(1),dum(1), -1, ierr ) lwork_qorgbr_q = int( dum(1),KIND=ilp) maxwrk = max( maxwrk, 3*n + lwork_qorgbr_q ) end if if( wntua ) then - call stdlib_qorgbr( 'Q', m, m, n, a, lda, dum(1),dum(1), -1, ierr ) + call stdlib_${ri}$orgbr( 'Q', m, m, n, a, lda, dum(1),dum(1), -1, ierr ) lwork_qorgbr_q = int( dum(1),KIND=ilp) maxwrk = max( maxwrk, 3*n + lwork_qorgbr_q ) end if @@ -11334,26 +11335,26 @@ module stdlib_linalg_lapack_q minwrk = max( 3*n + m, bdspac ) end if else if( minmn>0 ) then - ! compute space needed for stdlib_qbdsqr + ! compute space needed for stdlib_${ri}$bdsqr mnthr = stdlib_ilaenv( 6, 'DGESVD', jobu // jobvt, m, n, 0, 0 ) bdspac = 5*m - ! compute space needed for stdlib_qgelqf - call stdlib_qgelqf( m, n, a, lda, dum(1), dum(1), -1, ierr ) + ! compute space needed for stdlib_${ri}$gelqf + call stdlib_${ri}$gelqf( m, n, a, lda, dum(1), dum(1), -1, ierr ) lwork_qgelqf = int( dum(1),KIND=ilp) - ! compute space needed for stdlib_qorglq - call stdlib_qorglq( n, n, m, dum(1), n, dum(1), dum(1), -1, ierr ) + ! compute space needed for stdlib_${ri}$orglq + call stdlib_${ri}$orglq( n, n, m, dum(1), n, dum(1), dum(1), -1, ierr ) lwork_qorglq_n = int( dum(1),KIND=ilp) - call stdlib_qorglq( m, n, m, a, lda, dum(1), dum(1), -1, ierr ) + call stdlib_${ri}$orglq( m, n, m, a, lda, dum(1), dum(1), -1, ierr ) lwork_qorglq_m = int( dum(1),KIND=ilp) - ! compute space needed for stdlib_qgebrd - call stdlib_qgebrd( m, m, a, lda, s, dum(1), dum(1),dum(1), dum(1), -1, ierr ) + ! compute space needed for stdlib_${ri}$gebrd + call stdlib_${ri}$gebrd( m, m, a, lda, s, dum(1), dum(1),dum(1), dum(1), -1, ierr ) lwork_qgebrd = int( dum(1),KIND=ilp) - ! compute space needed for stdlib_qorgbr p - call stdlib_qorgbr( 'P', m, m, m, a, n, dum(1),dum(1), -1, ierr ) + ! compute space needed for stdlib_${ri}$orgbr p + call stdlib_${ri}$orgbr( 'P', m, m, m, a, n, dum(1),dum(1), -1, ierr ) lwork_qorgbr_p = int( dum(1),KIND=ilp) - ! compute space needed for stdlib_qorgbr q - call stdlib_qorgbr( 'Q', m, m, m, a, n, dum(1),dum(1), -1, ierr ) + ! compute space needed for stdlib_${ri}$orgbr q + call stdlib_${ri}$orgbr( 'Q', m, m, m, a, n, dum(1),dum(1), -1, ierr ) lwork_qorgbr_q = int( dum(1),KIND=ilp) if( n>=mnthr ) then if( wntvn ) then @@ -11446,18 +11447,18 @@ module stdlib_linalg_lapack_q end if else ! path 10t(n greater than m, but not much larger) - call stdlib_qgebrd( m, n, a, lda, s, dum(1), dum(1),dum(1), dum(1), -1, ierr ) + call stdlib_${ri}$gebrd( m, n, a, lda, s, dum(1), dum(1),dum(1), dum(1), -1, ierr ) lwork_qgebrd = int( dum(1),KIND=ilp) maxwrk = 3*m + lwork_qgebrd if( wntvs .or. wntvo ) then - ! compute space needed for stdlib_qorgbr p - call stdlib_qorgbr( 'P', m, n, m, a, n, dum(1),dum(1), -1, ierr ) + ! compute space needed for stdlib_${ri}$orgbr p + call stdlib_${ri}$orgbr( 'P', m, n, m, a, n, dum(1),dum(1), -1, ierr ) lwork_qorgbr_p = int( dum(1),KIND=ilp) maxwrk = max( maxwrk, 3*m + lwork_qorgbr_p ) end if if( wntva ) then - call stdlib_qorgbr( 'P', n, n, m, a, n, dum(1),dum(1), -1, ierr ) + call stdlib_${ri}$orgbr( 'P', n, n, m, a, n, dum(1),dum(1), -1, ierr ) lwork_qorgbr_p = int( dum(1),KIND=ilp) maxwrk = max( maxwrk, 3*m + lwork_qorgbr_p ) end if @@ -11485,18 +11486,18 @@ module stdlib_linalg_lapack_q return end if ! get machine constants - eps = stdlib_qlamch( 'P' ) - smlnum = sqrt( stdlib_qlamch( 'S' ) ) / eps + eps = stdlib_${ri}$lamch( 'P' ) + smlnum = sqrt( stdlib_${ri}$lamch( 'S' ) ) / eps bignum = one / smlnum ! scale a if max element outside range [smlnum,bignum] - anrm = stdlib_qlange( 'M', m, n, a, lda, dum ) + anrm = stdlib_${ri}$lange( 'M', m, n, a, lda, dum ) iscl = 0 if( anrm>zero .and. anrmbignum ) then iscl = 1 - call stdlib_qlascl( 'G', 0, 0, anrm, bignum, m, n, a, lda, ierr ) + call stdlib_${ri}$lascl( 'G', 0, 0, anrm, bignum, m, n, a, lda, ierr ) end if if( m>=n ) then ! a has at least as many rows as columns. if a has sufficiently @@ -11510,11 +11511,11 @@ module stdlib_linalg_lapack_q iwork = itau + n ! compute a=q*r ! (workspace: need 2*n, prefer n + n*nb) - call stdlib_qgeqrf( m, n, a, lda, work( itau ), work( iwork ),lwork-iwork+1, & + call stdlib_${ri}$geqrf( m, n, a, lda, work( itau ), work( iwork ),lwork-iwork+1, & ierr ) ! zero out below r if( n > 1 ) then - call stdlib_qlaset( 'L', n-1, n-1, zero, zero, a( 2, 1 ),lda ) + call stdlib_${ri}$laset( 'L', n-1, n-1, zero, zero, a( 2, 1 ),lda ) end if ie = 1 itauq = ie + n @@ -11522,13 +11523,13 @@ module stdlib_linalg_lapack_q iwork = itaup + n ! bidiagonalize r in a ! (workspace: need 4*n, prefer 3*n + 2*n*nb) - call stdlib_qgebrd( n, n, a, lda, s, work( ie ), work( itauq ),work( itaup ), & + call stdlib_${ri}$gebrd( n, n, a, lda, s, work( ie ), work( itauq ),work( itaup ), & work( iwork ), lwork-iwork+1,ierr ) ncvt = 0 if( wntvo .or. wntvas ) then ! if right singular vectors desired, generate p'. ! (workspace: need 4*n-1, prefer 3*n + (n-1)*nb) - call stdlib_qorgbr( 'P', n, n, n, a, lda, work( itaup ),work( iwork ), & + call stdlib_${ri}$orgbr( 'P', n, n, n, a, lda, work( itaup ),work( iwork ), & lwork-iwork+1, ierr ) ncvt = n end if @@ -11536,10 +11537,10 @@ module stdlib_linalg_lapack_q ! perform bidiagonal qr iteration, computing right ! singular vectors of a in a if desired ! (workspace: need bdspac) - call stdlib_qbdsqr( 'U', n, ncvt, 0, 0, s, work( ie ), a, lda,dum, 1, dum, 1, & + call stdlib_${ri}$bdsqr( 'U', n, ncvt, 0, 0, s, work( ie ), a, lda,dum, 1, dum, 1, & work( iwork ), info ) ! if right singular vectors desired in vt, copy them there - if( wntvas )call stdlib_qlacpy( 'F', n, n, a, lda, vt, ldvt ) + if( wntvas )call stdlib_${ri}$lacpy( 'F', n, n, a, lda, vt, ldvt ) else if( wntuo .and. wntvn ) then ! path 2 (m much larger than n, jobu='o', jobvt='n') ! n left singular vectors to be overwritten on a and @@ -11564,15 +11565,15 @@ module stdlib_linalg_lapack_q iwork = itau + n ! compute a=q*r ! (workspace: need n*n + 2*n, prefer n*n + n + n*nb) - call stdlib_qgeqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-iwork+& + call stdlib_${ri}$geqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-iwork+& 1, ierr ) ! copy r to work(ir) and zero out below it - call stdlib_qlacpy( 'U', n, n, a, lda, work( ir ), ldwrkr ) - call stdlib_qlaset( 'L', n-1, n-1, zero, zero, work( ir+1 ),ldwrkr ) + call stdlib_${ri}$lacpy( 'U', n, n, a, lda, work( ir ), ldwrkr ) + call stdlib_${ri}$laset( 'L', n-1, n-1, zero, zero, work( ir+1 ),ldwrkr ) ! generate q in a ! (workspace: need n*n + 2*n, prefer n*n + n + n*nb) - call stdlib_qorgqr( m, n, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib_${ri}$orgqr( m, n, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ie = itau itauq = ie + n @@ -11580,17 +11581,17 @@ module stdlib_linalg_lapack_q iwork = itaup + n ! bidiagonalize r in work(ir) ! (workspace: need n*n + 4*n, prefer n*n + 3*n + 2*n*nb) - call stdlib_qgebrd( n, n, work( ir ), ldwrkr, s, work( ie ),work( itauq ), & + call stdlib_${ri}$gebrd( n, n, work( ir ), ldwrkr, s, work( ie ),work( itauq ), & work( itaup ),work( iwork ), lwork-iwork+1, ierr ) ! generate left vectors bidiagonalizing r ! (workspace: need n*n + 4*n, prefer n*n + 3*n + n*nb) - call stdlib_qorgbr( 'Q', n, n, n, work( ir ), ldwrkr,work( itauq ), work( & + call stdlib_${ri}$orgbr( 'Q', n, n, n, work( ir ), ldwrkr,work( itauq ), work( & iwork ),lwork-iwork+1, ierr ) iwork = ie + n ! perform bidiagonal qr iteration, computing left ! singular vectors of r in work(ir) ! (workspace: need n*n + bdspac) - call stdlib_qbdsqr( 'U', n, 0, n, 0, s, work( ie ), dum, 1,work( ir ), & + call stdlib_${ri}$bdsqr( 'U', n, 0, n, 0, s, work( ie ), dum, 1,work( ir ), & ldwrkr, dum, 1,work( iwork ), info ) iu = ie + n ! multiply q in a by left singular vectors of r in @@ -11598,9 +11599,9 @@ module stdlib_linalg_lapack_q ! (workspace: need n*n + 2*n, prefer n*n + m*n + n) do i = 1, m, ldwrku chunk = min( m-i+1, ldwrku ) - call stdlib_qgemm( 'N', 'N', chunk, n, n, one, a( i, 1 ),lda, work( ir )& + call stdlib_${ri}$gemm( 'N', 'N', chunk, n, n, one, a( i, 1 ),lda, work( ir )& , ldwrkr, zero,work( iu ), ldwrku ) - call stdlib_qlacpy( 'F', chunk, n, work( iu ), ldwrku,a( i, 1 ), lda ) + call stdlib_${ri}$lacpy( 'F', chunk, n, work( iu ), ldwrku,a( i, 1 ), lda ) end do else @@ -11611,17 +11612,17 @@ module stdlib_linalg_lapack_q iwork = itaup + n ! bidiagonalize a ! (workspace: need 3*n + m, prefer 3*n + (m + n)*nb) - call stdlib_qgebrd( m, n, a, lda, s, work( ie ),work( itauq ), work( itaup & + call stdlib_${ri}$gebrd( m, n, a, lda, s, work( ie ),work( itauq ), work( itaup & ),work( iwork ), lwork-iwork+1, ierr ) ! generate left vectors bidiagonalizing a ! (workspace: need 4*n, prefer 3*n + n*nb) - call stdlib_qorgbr( 'Q', m, n, n, a, lda, work( itauq ),work( iwork ), & + call stdlib_${ri}$orgbr( 'Q', m, n, n, a, lda, work( itauq ),work( iwork ), & lwork-iwork+1, ierr ) iwork = ie + n ! perform bidiagonal qr iteration, computing left ! singular vectors of a in a ! (workspace: need bdspac) - call stdlib_qbdsqr( 'U', n, 0, m, 0, s, work( ie ), dum, 1,a, lda, dum, 1, & + call stdlib_${ri}$bdsqr( 'U', n, 0, m, 0, s, work( ie ), dum, 1,a, lda, dum, 1, & work( iwork ), info ) end if else if( wntuo .and. wntvas ) then @@ -11648,15 +11649,15 @@ module stdlib_linalg_lapack_q iwork = itau + n ! compute a=q*r ! (workspace: need n*n + 2*n, prefer n*n + n + n*nb) - call stdlib_qgeqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-iwork+& + call stdlib_${ri}$geqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-iwork+& 1, ierr ) ! copy r to vt, zeroing out below it - call stdlib_qlacpy( 'U', n, n, a, lda, vt, ldvt ) - if( n>1 )call stdlib_qlaset( 'L', n-1, n-1, zero, zero,vt( 2, 1 ), ldvt ) + call stdlib_${ri}$lacpy( 'U', n, n, a, lda, vt, ldvt ) + if( n>1 )call stdlib_${ri}$laset( 'L', n-1, n-1, zero, zero,vt( 2, 1 ), ldvt ) ! generate q in a ! (workspace: need n*n + 2*n, prefer n*n + n + n*nb) - call stdlib_qorgqr( m, n, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib_${ri}$orgqr( m, n, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ie = itau itauq = ie + n @@ -11664,23 +11665,23 @@ module stdlib_linalg_lapack_q iwork = itaup + n ! bidiagonalize r in vt, copying result to work(ir) ! (workspace: need n*n + 4*n, prefer n*n + 3*n + 2*n*nb) - call stdlib_qgebrd( n, n, vt, ldvt, s, work( ie ),work( itauq ), work( & + call stdlib_${ri}$gebrd( n, n, vt, ldvt, s, work( ie ),work( itauq ), work( & itaup ),work( iwork ), lwork-iwork+1, ierr ) - call stdlib_qlacpy( 'L', n, n, vt, ldvt, work( ir ), ldwrkr ) + call stdlib_${ri}$lacpy( 'L', n, n, vt, ldvt, work( ir ), ldwrkr ) ! generate left vectors bidiagonalizing r in work(ir) ! (workspace: need n*n + 4*n, prefer n*n + 3*n + n*nb) - call stdlib_qorgbr( 'Q', n, n, n, work( ir ), ldwrkr,work( itauq ), work( & + call stdlib_${ri}$orgbr( 'Q', n, n, n, work( ir ), ldwrkr,work( itauq ), work( & iwork ),lwork-iwork+1, ierr ) ! generate right vectors bidiagonalizing r in vt ! (workspace: need n*n + 4*n-1, prefer n*n + 3*n + (n-1)*nb) - call stdlib_qorgbr( 'P', n, n, n, vt, ldvt, work( itaup ),work( iwork ), & + call stdlib_${ri}$orgbr( 'P', n, n, n, vt, ldvt, work( itaup ),work( iwork ), & lwork-iwork+1, ierr ) iwork = ie + n ! perform bidiagonal qr iteration, computing left ! singular vectors of r in work(ir) and computing right ! singular vectors of r in vt ! (workspace: need n*n + bdspac) - call stdlib_qbdsqr( 'U', n, n, n, 0, s, work( ie ), vt, ldvt,work( ir ), & + call stdlib_${ri}$bdsqr( 'U', n, n, n, 0, s, work( ie ), vt, ldvt,work( ir ), & ldwrkr, dum, 1,work( iwork ), info ) iu = ie + n ! multiply q in a by left singular vectors of r in @@ -11688,9 +11689,9 @@ module stdlib_linalg_lapack_q ! (workspace: need n*n + 2*n, prefer n*n + m*n + n) do i = 1, m, ldwrku chunk = min( m-i+1, ldwrku ) - call stdlib_qgemm( 'N', 'N', chunk, n, n, one, a( i, 1 ),lda, work( ir )& + call stdlib_${ri}$gemm( 'N', 'N', chunk, n, n, one, a( i, 1 ),lda, work( ir )& , ldwrkr, zero,work( iu ), ldwrku ) - call stdlib_qlacpy( 'F', chunk, n, work( iu ), ldwrku,a( i, 1 ), lda ) + call stdlib_${ri}$lacpy( 'F', chunk, n, work( iu ), ldwrku,a( i, 1 ), lda ) end do else @@ -11699,15 +11700,15 @@ module stdlib_linalg_lapack_q iwork = itau + n ! compute a=q*r ! (workspace: need 2*n, prefer n + n*nb) - call stdlib_qgeqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-iwork+& + call stdlib_${ri}$geqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-iwork+& 1, ierr ) ! copy r to vt, zeroing out below it - call stdlib_qlacpy( 'U', n, n, a, lda, vt, ldvt ) - if( n>1 )call stdlib_qlaset( 'L', n-1, n-1, zero, zero,vt( 2, 1 ), ldvt ) + call stdlib_${ri}$lacpy( 'U', n, n, a, lda, vt, ldvt ) + if( n>1 )call stdlib_${ri}$laset( 'L', n-1, n-1, zero, zero,vt( 2, 1 ), ldvt ) ! generate q in a ! (workspace: need 2*n, prefer n + n*nb) - call stdlib_qorgqr( m, n, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib_${ri}$orgqr( m, n, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ie = itau itauq = ie + n @@ -11715,22 +11716,22 @@ module stdlib_linalg_lapack_q iwork = itaup + n ! bidiagonalize r in vt ! (workspace: need 4*n, prefer 3*n + 2*n*nb) - call stdlib_qgebrd( n, n, vt, ldvt, s, work( ie ),work( itauq ), work( & + call stdlib_${ri}$gebrd( n, n, vt, ldvt, s, work( ie ),work( itauq ), work( & itaup ),work( iwork ), lwork-iwork+1, ierr ) ! multiply q in a by left vectors bidiagonalizing r ! (workspace: need 3*n + m, prefer 3*n + m*nb) - call stdlib_qormbr( 'Q', 'R', 'N', m, n, n, vt, ldvt,work( itauq ), a, lda,& + call stdlib_${ri}$ormbr( 'Q', 'R', 'N', m, n, n, vt, ldvt,work( itauq ), a, lda,& work( iwork ),lwork-iwork+1, ierr ) ! generate right vectors bidiagonalizing r in vt ! (workspace: need 4*n-1, prefer 3*n + (n-1)*nb) - call stdlib_qorgbr( 'P', n, n, n, vt, ldvt, work( itaup ),work( iwork ), & + call stdlib_${ri}$orgbr( 'P', n, n, n, vt, ldvt, work( itaup ),work( iwork ), & lwork-iwork+1, ierr ) iwork = ie + n ! perform bidiagonal qr iteration, computing left ! singular vectors of a in a and computing right ! singular vectors of a in vt ! (workspace: need bdspac) - call stdlib_qbdsqr( 'U', n, n, m, 0, s, work( ie ), vt, ldvt,a, lda, dum, & + call stdlib_${ri}$bdsqr( 'U', n, n, m, 0, s, work( ie ), vt, ldvt,a, lda, dum, & 1, work( iwork ), info ) end if else if( wntus ) then @@ -11752,15 +11753,15 @@ module stdlib_linalg_lapack_q iwork = itau + n ! compute a=q*r ! (workspace: need n*n + 2*n, prefer n*n + n + n*nb) - call stdlib_qgeqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib_${ri}$geqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ! copy r to work(ir), zeroing out below it - call stdlib_qlacpy( 'U', n, n, a, lda, work( ir ),ldwrkr ) - call stdlib_qlaset( 'L', n-1, n-1, zero, zero,work( ir+1 ), ldwrkr ) + call stdlib_${ri}$lacpy( 'U', n, n, a, lda, work( ir ),ldwrkr ) + call stdlib_${ri}$laset( 'L', n-1, n-1, zero, zero,work( ir+1 ), ldwrkr ) ! generate q in a ! (workspace: need n*n + 2*n, prefer n*n + n + n*nb) - call stdlib_qorgqr( m, n, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib_${ri}$orgqr( m, n, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ie = itau itauq = ie + n @@ -11768,22 +11769,22 @@ module stdlib_linalg_lapack_q iwork = itaup + n ! bidiagonalize r in work(ir) ! (workspace: need n*n + 4*n, prefer n*n + 3*n + 2*n*nb) - call stdlib_qgebrd( n, n, work( ir ), ldwrkr, s,work( ie ), work( itauq & + call stdlib_${ri}$gebrd( n, n, work( ir ), ldwrkr, s,work( ie ), work( itauq & ),work( itaup ), work( iwork ),lwork-iwork+1, ierr ) ! generate left vectors bidiagonalizing r in work(ir) ! (workspace: need n*n + 4*n, prefer n*n + 3*n + n*nb) - call stdlib_qorgbr( 'Q', n, n, n, work( ir ), ldwrkr,work( itauq ), & + call stdlib_${ri}$orgbr( 'Q', n, n, n, work( ir ), ldwrkr,work( itauq ), & work( iwork ),lwork-iwork+1, ierr ) iwork = ie + n ! perform bidiagonal qr iteration, computing left ! singular vectors of r in work(ir) ! (workspace: need n*n + bdspac) - call stdlib_qbdsqr( 'U', n, 0, n, 0, s, work( ie ), dum,1, work( ir ), & + call stdlib_${ri}$bdsqr( 'U', n, 0, n, 0, s, work( ie ), dum,1, work( ir ), & ldwrkr, dum, 1,work( iwork ), info ) ! multiply q in a by left singular vectors of r in ! work(ir), storing result in u ! (workspace: need n*n) - call stdlib_qgemm( 'N', 'N', m, n, n, one, a, lda,work( ir ), ldwrkr, & + call stdlib_${ri}$gemm( 'N', 'N', m, n, n, one, a, lda,work( ir ), ldwrkr, & zero, u, ldu ) else ! insufficient workspace for a fast algorithm @@ -11791,12 +11792,12 @@ module stdlib_linalg_lapack_q iwork = itau + n ! compute a=q*r, copying result to u ! (workspace: need 2*n, prefer n + n*nb) - call stdlib_qgeqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib_${ri}$geqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - call stdlib_qlacpy( 'L', m, n, a, lda, u, ldu ) + call stdlib_${ri}$lacpy( 'L', m, n, a, lda, u, ldu ) ! generate q in u ! (workspace: need 2*n, prefer n + n*nb) - call stdlib_qorgqr( m, n, n, u, ldu, work( itau ),work( iwork ), lwork-& + call stdlib_${ri}$orgqr( m, n, n, u, ldu, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ie = itau itauq = ie + n @@ -11804,22 +11805,22 @@ module stdlib_linalg_lapack_q iwork = itaup + n ! zero out below r in a if( n > 1 ) then - call stdlib_qlaset( 'L', n-1, n-1, zero, zero,a( 2, 1 ), lda ) + call stdlib_${ri}$laset( 'L', n-1, n-1, zero, zero,a( 2, 1 ), lda ) end if ! bidiagonalize r in a ! (workspace: need 4*n, prefer 3*n + 2*n*nb) - call stdlib_qgebrd( n, n, a, lda, s, work( ie ),work( itauq ), work( & + call stdlib_${ri}$gebrd( n, n, a, lda, s, work( ie ),work( itauq ), work( & itaup ),work( iwork ), lwork-iwork+1, ierr ) ! multiply q in u by left vectors bidiagonalizing r ! (workspace: need 3*n + m, prefer 3*n + m*nb) - call stdlib_qormbr( 'Q', 'R', 'N', m, n, n, a, lda,work( itauq ), u, & + call stdlib_${ri}$ormbr( 'Q', 'R', 'N', m, n, n, a, lda,work( itauq ), u, & ldu, work( iwork ),lwork-iwork+1, ierr ) iwork = ie + n ! perform bidiagonal qr iteration, computing left ! singular vectors of a in u ! (workspace: need bdspac) - call stdlib_qbdsqr( 'U', n, 0, m, 0, s, work( ie ), dum,1, u, ldu, dum, & + call stdlib_${ri}$bdsqr( 'U', n, 0, m, 0, s, work( ie ), dum,1, u, ldu, dum, & 1, work( iwork ),info ) end if else if( wntvo ) then @@ -11849,15 +11850,15 @@ module stdlib_linalg_lapack_q iwork = itau + n ! compute a=q*r ! (workspace: need 2*n*n + 2*n, prefer 2*n*n + n + n*nb) - call stdlib_qgeqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib_${ri}$geqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ! copy r to work(iu), zeroing out below it - call stdlib_qlacpy( 'U', n, n, a, lda, work( iu ),ldwrku ) - call stdlib_qlaset( 'L', n-1, n-1, zero, zero,work( iu+1 ), ldwrku ) + call stdlib_${ri}$lacpy( 'U', n, n, a, lda, work( iu ),ldwrku ) + call stdlib_${ri}$laset( 'L', n-1, n-1, zero, zero,work( iu+1 ), ldwrku ) ! generate q in a ! (workspace: need 2*n*n + 2*n, prefer 2*n*n + n + n*nb) - call stdlib_qorgqr( m, n, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib_${ri}$orgqr( m, n, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ie = itau itauq = ie + n @@ -11867,46 +11868,46 @@ module stdlib_linalg_lapack_q ! work(ir) ! (workspace: need 2*n*n + 4*n, ! prefer 2*n*n+3*n+2*n*nb) - call stdlib_qgebrd( n, n, work( iu ), ldwrku, s,work( ie ), work( itauq & + call stdlib_${ri}$gebrd( n, n, work( iu ), ldwrku, s,work( ie ), work( itauq & ),work( itaup ), work( iwork ),lwork-iwork+1, ierr ) - call stdlib_qlacpy( 'U', n, n, work( iu ), ldwrku,work( ir ), ldwrkr ) + call stdlib_${ri}$lacpy( 'U', n, n, work( iu ), ldwrku,work( ir ), ldwrkr ) ! generate left bidiagonalizing vectors in work(iu) ! (workspace: need 2*n*n + 4*n, prefer 2*n*n + 3*n + n*nb) - call stdlib_qorgbr( 'Q', n, n, n, work( iu ), ldwrku,work( itauq ), & + call stdlib_${ri}$orgbr( 'Q', n, n, n, work( iu ), ldwrku,work( itauq ), & work( iwork ),lwork-iwork+1, ierr ) ! generate right bidiagonalizing vectors in work(ir) ! (workspace: need 2*n*n + 4*n-1, ! prefer 2*n*n+3*n+(n-1)*nb) - call stdlib_qorgbr( 'P', n, n, n, work( ir ), ldwrkr,work( itaup ), & + call stdlib_${ri}$orgbr( 'P', n, n, n, work( ir ), ldwrkr,work( itaup ), & work( iwork ),lwork-iwork+1, ierr ) iwork = ie + n ! perform bidiagonal qr iteration, computing left ! singular vectors of r in work(iu) and computing ! right singular vectors of r in work(ir) ! (workspace: need 2*n*n + bdspac) - call stdlib_qbdsqr( 'U', n, n, n, 0, s, work( ie ),work( ir ), ldwrkr, & + call stdlib_${ri}$bdsqr( 'U', n, n, n, 0, s, work( ie ),work( ir ), ldwrkr, & work( iu ),ldwrku, dum, 1, work( iwork ), info ) ! multiply q in a by left singular vectors of r in ! work(iu), storing result in u ! (workspace: need n*n) - call stdlib_qgemm( 'N', 'N', m, n, n, one, a, lda,work( iu ), ldwrku, & + call stdlib_${ri}$gemm( 'N', 'N', m, n, n, one, a, lda,work( iu ), ldwrku, & zero, u, ldu ) ! copy right singular vectors of r to a ! (workspace: need n*n) - call stdlib_qlacpy( 'F', n, n, work( ir ), ldwrkr, a,lda ) + call stdlib_${ri}$lacpy( 'F', n, n, work( ir ), ldwrkr, a,lda ) else ! insufficient workspace for a fast algorithm itau = 1 iwork = itau + n ! compute a=q*r, copying result to u ! (workspace: need 2*n, prefer n + n*nb) - call stdlib_qgeqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib_${ri}$geqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - call stdlib_qlacpy( 'L', m, n, a, lda, u, ldu ) + call stdlib_${ri}$lacpy( 'L', m, n, a, lda, u, ldu ) ! generate q in u ! (workspace: need 2*n, prefer n + n*nb) - call stdlib_qorgqr( m, n, n, u, ldu, work( itau ),work( iwork ), lwork-& + call stdlib_${ri}$orgqr( m, n, n, u, ldu, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ie = itau itauq = ie + n @@ -11914,27 +11915,27 @@ module stdlib_linalg_lapack_q iwork = itaup + n ! zero out below r in a if( n > 1 ) then - call stdlib_qlaset( 'L', n-1, n-1, zero, zero,a( 2, 1 ), lda ) + call stdlib_${ri}$laset( 'L', n-1, n-1, zero, zero,a( 2, 1 ), lda ) end if ! bidiagonalize r in a ! (workspace: need 4*n, prefer 3*n + 2*n*nb) - call stdlib_qgebrd( n, n, a, lda, s, work( ie ),work( itauq ), work( & + call stdlib_${ri}$gebrd( n, n, a, lda, s, work( ie ),work( itauq ), work( & itaup ),work( iwork ), lwork-iwork+1, ierr ) ! multiply q in u by left vectors bidiagonalizing r ! (workspace: need 3*n + m, prefer 3*n + m*nb) - call stdlib_qormbr( 'Q', 'R', 'N', m, n, n, a, lda,work( itauq ), u, & + call stdlib_${ri}$ormbr( 'Q', 'R', 'N', m, n, n, a, lda,work( itauq ), u, & ldu, work( iwork ),lwork-iwork+1, ierr ) ! generate right vectors bidiagonalizing r in a ! (workspace: need 4*n-1, prefer 3*n + (n-1)*nb) - call stdlib_qorgbr( 'P', n, n, n, a, lda, work( itaup ),work( iwork ), & + call stdlib_${ri}$orgbr( 'P', n, n, n, a, lda, work( itaup ),work( iwork ), & lwork-iwork+1, ierr ) iwork = ie + n ! perform bidiagonal qr iteration, computing left ! singular vectors of a in u and computing right ! singular vectors of a in a ! (workspace: need bdspac) - call stdlib_qbdsqr( 'U', n, n, m, 0, s, work( ie ), a,lda, u, ldu, dum, & + call stdlib_${ri}$bdsqr( 'U', n, n, m, 0, s, work( ie ), a,lda, u, ldu, dum, & 1, work( iwork ),info ) end if else if( wntvas ) then @@ -11956,15 +11957,15 @@ module stdlib_linalg_lapack_q iwork = itau + n ! compute a=q*r ! (workspace: need n*n + 2*n, prefer n*n + n + n*nb) - call stdlib_qgeqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib_${ri}$geqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ! copy r to work(iu), zeroing out below it - call stdlib_qlacpy( 'U', n, n, a, lda, work( iu ),ldwrku ) - call stdlib_qlaset( 'L', n-1, n-1, zero, zero,work( iu+1 ), ldwrku ) + call stdlib_${ri}$lacpy( 'U', n, n, a, lda, work( iu ),ldwrku ) + call stdlib_${ri}$laset( 'L', n-1, n-1, zero, zero,work( iu+1 ), ldwrku ) ! generate q in a ! (workspace: need n*n + 2*n, prefer n*n + n + n*nb) - call stdlib_qorgqr( m, n, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib_${ri}$orgqr( m, n, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ie = itau itauq = ie + n @@ -11972,29 +11973,29 @@ module stdlib_linalg_lapack_q iwork = itaup + n ! bidiagonalize r in work(iu), copying result to vt ! (workspace: need n*n + 4*n, prefer n*n + 3*n + 2*n*nb) - call stdlib_qgebrd( n, n, work( iu ), ldwrku, s,work( ie ), work( itauq & + call stdlib_${ri}$gebrd( n, n, work( iu ), ldwrku, s,work( ie ), work( itauq & ),work( itaup ), work( iwork ),lwork-iwork+1, ierr ) - call stdlib_qlacpy( 'U', n, n, work( iu ), ldwrku, vt,ldvt ) + call stdlib_${ri}$lacpy( 'U', n, n, work( iu ), ldwrku, vt,ldvt ) ! generate left bidiagonalizing vectors in work(iu) ! (workspace: need n*n + 4*n, prefer n*n + 3*n + n*nb) - call stdlib_qorgbr( 'Q', n, n, n, work( iu ), ldwrku,work( itauq ), & + call stdlib_${ri}$orgbr( 'Q', n, n, n, work( iu ), ldwrku,work( itauq ), & work( iwork ),lwork-iwork+1, ierr ) ! generate right bidiagonalizing vectors in vt ! (workspace: need n*n + 4*n-1, ! prefer n*n+3*n+(n-1)*nb) - call stdlib_qorgbr( 'P', n, n, n, vt, ldvt, work( itaup ),work( iwork ),& + call stdlib_${ri}$orgbr( 'P', n, n, n, vt, ldvt, work( itaup ),work( iwork ),& lwork-iwork+1, ierr ) iwork = ie + n ! perform bidiagonal qr iteration, computing left ! singular vectors of r in work(iu) and computing ! right singular vectors of r in vt ! (workspace: need n*n + bdspac) - call stdlib_qbdsqr( 'U', n, n, n, 0, s, work( ie ), vt,ldvt, work( iu ),& + call stdlib_${ri}$bdsqr( 'U', n, n, n, 0, s, work( ie ), vt,ldvt, work( iu ),& ldwrku, dum, 1,work( iwork ), info ) ! multiply q in a by left singular vectors of r in ! work(iu), storing result in u ! (workspace: need n*n) - call stdlib_qgemm( 'N', 'N', m, n, n, one, a, lda,work( iu ), ldwrku, & + call stdlib_${ri}$gemm( 'N', 'N', m, n, n, one, a, lda,work( iu ), ldwrku, & zero, u, ldu ) else ! insufficient workspace for a fast algorithm @@ -12002,16 +12003,16 @@ module stdlib_linalg_lapack_q iwork = itau + n ! compute a=q*r, copying result to u ! (workspace: need 2*n, prefer n + n*nb) - call stdlib_qgeqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib_${ri}$geqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - call stdlib_qlacpy( 'L', m, n, a, lda, u, ldu ) + call stdlib_${ri}$lacpy( 'L', m, n, a, lda, u, ldu ) ! generate q in u ! (workspace: need 2*n, prefer n + n*nb) - call stdlib_qorgqr( m, n, n, u, ldu, work( itau ),work( iwork ), lwork-& + call stdlib_${ri}$orgqr( m, n, n, u, ldu, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ! copy r to vt, zeroing out below it - call stdlib_qlacpy( 'U', n, n, a, lda, vt, ldvt ) - if( n>1 )call stdlib_qlaset( 'L', n-1, n-1, zero, zero,vt( 2, 1 ), ldvt & + call stdlib_${ri}$lacpy( 'U', n, n, a, lda, vt, ldvt ) + if( n>1 )call stdlib_${ri}$laset( 'L', n-1, n-1, zero, zero,vt( 2, 1 ), ldvt & ) ie = itau itauq = ie + n @@ -12019,23 +12020,23 @@ module stdlib_linalg_lapack_q iwork = itaup + n ! bidiagonalize r in vt ! (workspace: need 4*n, prefer 3*n + 2*n*nb) - call stdlib_qgebrd( n, n, vt, ldvt, s, work( ie ),work( itauq ), work( & + call stdlib_${ri}$gebrd( n, n, vt, ldvt, s, work( ie ),work( itauq ), work( & itaup ),work( iwork ), lwork-iwork+1, ierr ) ! multiply q in u by left bidiagonalizing vectors ! in vt ! (workspace: need 3*n + m, prefer 3*n + m*nb) - call stdlib_qormbr( 'Q', 'R', 'N', m, n, n, vt, ldvt,work( itauq ), u, & + call stdlib_${ri}$ormbr( 'Q', 'R', 'N', m, n, n, vt, ldvt,work( itauq ), u, & ldu, work( iwork ),lwork-iwork+1, ierr ) ! generate right bidiagonalizing vectors in vt ! (workspace: need 4*n-1, prefer 3*n + (n-1)*nb) - call stdlib_qorgbr( 'P', n, n, n, vt, ldvt, work( itaup ),work( iwork ),& + call stdlib_${ri}$orgbr( 'P', n, n, n, vt, ldvt, work( itaup ),work( iwork ),& lwork-iwork+1, ierr ) iwork = ie + n ! perform bidiagonal qr iteration, computing left ! singular vectors of a in u and computing right ! singular vectors of a in vt ! (workspace: need bdspac) - call stdlib_qbdsqr( 'U', n, n, m, 0, s, work( ie ), vt,ldvt, u, ldu, & + call stdlib_${ri}$bdsqr( 'U', n, n, m, 0, s, work( ie ), vt,ldvt, u, ldu, & dum, 1, work( iwork ),info ) end if end if @@ -12058,16 +12059,16 @@ module stdlib_linalg_lapack_q iwork = itau + n ! compute a=q*r, copying result to u ! (workspace: need n*n + 2*n, prefer n*n + n + n*nb) - call stdlib_qgeqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib_${ri}$geqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - call stdlib_qlacpy( 'L', m, n, a, lda, u, ldu ) + call stdlib_${ri}$lacpy( 'L', m, n, a, lda, u, ldu ) ! copy r to work(ir), zeroing out below it - call stdlib_qlacpy( 'U', n, n, a, lda, work( ir ),ldwrkr ) - call stdlib_qlaset( 'L', n-1, n-1, zero, zero,work( ir+1 ), ldwrkr ) + call stdlib_${ri}$lacpy( 'U', n, n, a, lda, work( ir ),ldwrkr ) + call stdlib_${ri}$laset( 'L', n-1, n-1, zero, zero,work( ir+1 ), ldwrkr ) ! generate q in u ! (workspace: need n*n + n + m, prefer n*n + n + m*nb) - call stdlib_qorgqr( m, m, n, u, ldu, work( itau ),work( iwork ), lwork-& + call stdlib_${ri}$orgqr( m, m, n, u, ldu, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ie = itau itauq = ie + n @@ -12075,37 +12076,37 @@ module stdlib_linalg_lapack_q iwork = itaup + n ! bidiagonalize r in work(ir) ! (workspace: need n*n + 4*n, prefer n*n + 3*n + 2*n*nb) - call stdlib_qgebrd( n, n, work( ir ), ldwrkr, s,work( ie ), work( itauq & + call stdlib_${ri}$gebrd( n, n, work( ir ), ldwrkr, s,work( ie ), work( itauq & ),work( itaup ), work( iwork ),lwork-iwork+1, ierr ) ! generate left bidiagonalizing vectors in work(ir) ! (workspace: need n*n + 4*n, prefer n*n + 3*n + n*nb) - call stdlib_qorgbr( 'Q', n, n, n, work( ir ), ldwrkr,work( itauq ), & + call stdlib_${ri}$orgbr( 'Q', n, n, n, work( ir ), ldwrkr,work( itauq ), & work( iwork ),lwork-iwork+1, ierr ) iwork = ie + n ! perform bidiagonal qr iteration, computing left ! singular vectors of r in work(ir) ! (workspace: need n*n + bdspac) - call stdlib_qbdsqr( 'U', n, 0, n, 0, s, work( ie ), dum,1, work( ir ), & + call stdlib_${ri}$bdsqr( 'U', n, 0, n, 0, s, work( ie ), dum,1, work( ir ), & ldwrkr, dum, 1,work( iwork ), info ) ! multiply q in u by left singular vectors of r in ! work(ir), storing result in a ! (workspace: need n*n) - call stdlib_qgemm( 'N', 'N', m, n, n, one, u, ldu,work( ir ), ldwrkr, & + call stdlib_${ri}$gemm( 'N', 'N', m, n, n, one, u, ldu,work( ir ), ldwrkr, & zero, a, lda ) ! copy left singular vectors of a from a to u - call stdlib_qlacpy( 'F', m, n, a, lda, u, ldu ) + call stdlib_${ri}$lacpy( 'F', m, n, a, lda, u, ldu ) else ! insufficient workspace for a fast algorithm itau = 1 iwork = itau + n ! compute a=q*r, copying result to u ! (workspace: need 2*n, prefer n + n*nb) - call stdlib_qgeqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib_${ri}$geqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - call stdlib_qlacpy( 'L', m, n, a, lda, u, ldu ) + call stdlib_${ri}$lacpy( 'L', m, n, a, lda, u, ldu ) ! generate q in u ! (workspace: need n + m, prefer n + m*nb) - call stdlib_qorgqr( m, m, n, u, ldu, work( itau ),work( iwork ), lwork-& + call stdlib_${ri}$orgqr( m, m, n, u, ldu, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ie = itau itauq = ie + n @@ -12113,23 +12114,23 @@ module stdlib_linalg_lapack_q iwork = itaup + n ! zero out below r in a if( n > 1 ) then - call stdlib_qlaset( 'L', n-1, n-1, zero, zero,a( 2, 1 ), lda ) + call stdlib_${ri}$laset( 'L', n-1, n-1, zero, zero,a( 2, 1 ), lda ) end if ! bidiagonalize r in a ! (workspace: need 4*n, prefer 3*n + 2*n*nb) - call stdlib_qgebrd( n, n, a, lda, s, work( ie ),work( itauq ), work( & + call stdlib_${ri}$gebrd( n, n, a, lda, s, work( ie ),work( itauq ), work( & itaup ),work( iwork ), lwork-iwork+1, ierr ) ! multiply q in u by left bidiagonalizing vectors ! in a ! (workspace: need 3*n + m, prefer 3*n + m*nb) - call stdlib_qormbr( 'Q', 'R', 'N', m, n, n, a, lda,work( itauq ), u, & + call stdlib_${ri}$ormbr( 'Q', 'R', 'N', m, n, n, a, lda,work( itauq ), u, & ldu, work( iwork ),lwork-iwork+1, ierr ) iwork = ie + n ! perform bidiagonal qr iteration, computing left ! singular vectors of a in u ! (workspace: need bdspac) - call stdlib_qbdsqr( 'U', n, 0, m, 0, s, work( ie ), dum,1, u, ldu, dum, & + call stdlib_${ri}$bdsqr( 'U', n, 0, m, 0, s, work( ie ), dum,1, u, ldu, dum, & 1, work( iwork ),info ) end if else if( wntvo ) then @@ -12159,16 +12160,16 @@ module stdlib_linalg_lapack_q iwork = itau + n ! compute a=q*r, copying result to u ! (workspace: need 2*n*n + 2*n, prefer 2*n*n + n + n*nb) - call stdlib_qgeqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib_${ri}$geqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - call stdlib_qlacpy( 'L', m, n, a, lda, u, ldu ) + call stdlib_${ri}$lacpy( 'L', m, n, a, lda, u, ldu ) ! generate q in u ! (workspace: need 2*n*n + n + m, prefer 2*n*n + n + m*nb) - call stdlib_qorgqr( m, m, n, u, ldu, work( itau ),work( iwork ), lwork-& + call stdlib_${ri}$orgqr( m, m, n, u, ldu, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ! copy r to work(iu), zeroing out below it - call stdlib_qlacpy( 'U', n, n, a, lda, work( iu ),ldwrku ) - call stdlib_qlaset( 'L', n-1, n-1, zero, zero,work( iu+1 ), ldwrku ) + call stdlib_${ri}$lacpy( 'U', n, n, a, lda, work( iu ),ldwrku ) + call stdlib_${ri}$laset( 'L', n-1, n-1, zero, zero,work( iu+1 ), ldwrku ) ie = itau itauq = ie + n @@ -12178,47 +12179,47 @@ module stdlib_linalg_lapack_q ! work(ir) ! (workspace: need 2*n*n + 4*n, ! prefer 2*n*n+3*n+2*n*nb) - call stdlib_qgebrd( n, n, work( iu ), ldwrku, s,work( ie ), work( itauq & + call stdlib_${ri}$gebrd( n, n, work( iu ), ldwrku, s,work( ie ), work( itauq & ),work( itaup ), work( iwork ),lwork-iwork+1, ierr ) - call stdlib_qlacpy( 'U', n, n, work( iu ), ldwrku,work( ir ), ldwrkr ) + call stdlib_${ri}$lacpy( 'U', n, n, work( iu ), ldwrku,work( ir ), ldwrkr ) ! generate left bidiagonalizing vectors in work(iu) ! (workspace: need 2*n*n + 4*n, prefer 2*n*n + 3*n + n*nb) - call stdlib_qorgbr( 'Q', n, n, n, work( iu ), ldwrku,work( itauq ), & + call stdlib_${ri}$orgbr( 'Q', n, n, n, work( iu ), ldwrku,work( itauq ), & work( iwork ),lwork-iwork+1, ierr ) ! generate right bidiagonalizing vectors in work(ir) ! (workspace: need 2*n*n + 4*n-1, ! prefer 2*n*n+3*n+(n-1)*nb) - call stdlib_qorgbr( 'P', n, n, n, work( ir ), ldwrkr,work( itaup ), & + call stdlib_${ri}$orgbr( 'P', n, n, n, work( ir ), ldwrkr,work( itaup ), & work( iwork ),lwork-iwork+1, ierr ) iwork = ie + n ! perform bidiagonal qr iteration, computing left ! singular vectors of r in work(iu) and computing ! right singular vectors of r in work(ir) ! (workspace: need 2*n*n + bdspac) - call stdlib_qbdsqr( 'U', n, n, n, 0, s, work( ie ),work( ir ), ldwrkr, & + call stdlib_${ri}$bdsqr( 'U', n, n, n, 0, s, work( ie ),work( ir ), ldwrkr, & work( iu ),ldwrku, dum, 1, work( iwork ), info ) ! multiply q in u by left singular vectors of r in ! work(iu), storing result in a ! (workspace: need n*n) - call stdlib_qgemm( 'N', 'N', m, n, n, one, u, ldu,work( iu ), ldwrku, & + call stdlib_${ri}$gemm( 'N', 'N', m, n, n, one, u, ldu,work( iu ), ldwrku, & zero, a, lda ) ! copy left singular vectors of a from a to u - call stdlib_qlacpy( 'F', m, n, a, lda, u, ldu ) + call stdlib_${ri}$lacpy( 'F', m, n, a, lda, u, ldu ) ! copy right singular vectors of r from work(ir) to a - call stdlib_qlacpy( 'F', n, n, work( ir ), ldwrkr, a,lda ) + call stdlib_${ri}$lacpy( 'F', n, n, work( ir ), ldwrkr, a,lda ) else ! insufficient workspace for a fast algorithm itau = 1 iwork = itau + n ! compute a=q*r, copying result to u ! (workspace: need 2*n, prefer n + n*nb) - call stdlib_qgeqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib_${ri}$geqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - call stdlib_qlacpy( 'L', m, n, a, lda, u, ldu ) + call stdlib_${ri}$lacpy( 'L', m, n, a, lda, u, ldu ) ! generate q in u ! (workspace: need n + m, prefer n + m*nb) - call stdlib_qorgqr( m, m, n, u, ldu, work( itau ),work( iwork ), lwork-& + call stdlib_${ri}$orgqr( m, m, n, u, ldu, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ie = itau itauq = ie + n @@ -12226,28 +12227,28 @@ module stdlib_linalg_lapack_q iwork = itaup + n ! zero out below r in a if( n > 1 ) then - call stdlib_qlaset( 'L', n-1, n-1, zero, zero,a( 2, 1 ), lda ) + call stdlib_${ri}$laset( 'L', n-1, n-1, zero, zero,a( 2, 1 ), lda ) end if ! bidiagonalize r in a ! (workspace: need 4*n, prefer 3*n + 2*n*nb) - call stdlib_qgebrd( n, n, a, lda, s, work( ie ),work( itauq ), work( & + call stdlib_${ri}$gebrd( n, n, a, lda, s, work( ie ),work( itauq ), work( & itaup ),work( iwork ), lwork-iwork+1, ierr ) ! multiply q in u by left bidiagonalizing vectors ! in a ! (workspace: need 3*n + m, prefer 3*n + m*nb) - call stdlib_qormbr( 'Q', 'R', 'N', m, n, n, a, lda,work( itauq ), u, & + call stdlib_${ri}$ormbr( 'Q', 'R', 'N', m, n, n, a, lda,work( itauq ), u, & ldu, work( iwork ),lwork-iwork+1, ierr ) ! generate right bidiagonalizing vectors in a ! (workspace: need 4*n-1, prefer 3*n + (n-1)*nb) - call stdlib_qorgbr( 'P', n, n, n, a, lda, work( itaup ),work( iwork ), & + call stdlib_${ri}$orgbr( 'P', n, n, n, a, lda, work( itaup ),work( iwork ), & lwork-iwork+1, ierr ) iwork = ie + n ! perform bidiagonal qr iteration, computing left ! singular vectors of a in u and computing right ! singular vectors of a in a ! (workspace: need bdspac) - call stdlib_qbdsqr( 'U', n, n, m, 0, s, work( ie ), a,lda, u, ldu, dum, & + call stdlib_${ri}$bdsqr( 'U', n, n, m, 0, s, work( ie ), a,lda, u, ldu, dum, & 1, work( iwork ),info ) end if else if( wntvas ) then @@ -12269,16 +12270,16 @@ module stdlib_linalg_lapack_q iwork = itau + n ! compute a=q*r, copying result to u ! (workspace: need n*n + 2*n, prefer n*n + n + n*nb) - call stdlib_qgeqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib_${ri}$geqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - call stdlib_qlacpy( 'L', m, n, a, lda, u, ldu ) + call stdlib_${ri}$lacpy( 'L', m, n, a, lda, u, ldu ) ! generate q in u ! (workspace: need n*n + n + m, prefer n*n + n + m*nb) - call stdlib_qorgqr( m, m, n, u, ldu, work( itau ),work( iwork ), lwork-& + call stdlib_${ri}$orgqr( m, m, n, u, ldu, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ! copy r to work(iu), zeroing out below it - call stdlib_qlacpy( 'U', n, n, a, lda, work( iu ),ldwrku ) - call stdlib_qlaset( 'L', n-1, n-1, zero, zero,work( iu+1 ), ldwrku ) + call stdlib_${ri}$lacpy( 'U', n, n, a, lda, work( iu ),ldwrku ) + call stdlib_${ri}$laset( 'L', n-1, n-1, zero, zero,work( iu+1 ), ldwrku ) ie = itau itauq = ie + n @@ -12286,48 +12287,48 @@ module stdlib_linalg_lapack_q iwork = itaup + n ! bidiagonalize r in work(iu), copying result to vt ! (workspace: need n*n + 4*n, prefer n*n + 3*n + 2*n*nb) - call stdlib_qgebrd( n, n, work( iu ), ldwrku, s,work( ie ), work( itauq & + call stdlib_${ri}$gebrd( n, n, work( iu ), ldwrku, s,work( ie ), work( itauq & ),work( itaup ), work( iwork ),lwork-iwork+1, ierr ) - call stdlib_qlacpy( 'U', n, n, work( iu ), ldwrku, vt,ldvt ) + call stdlib_${ri}$lacpy( 'U', n, n, work( iu ), ldwrku, vt,ldvt ) ! generate left bidiagonalizing vectors in work(iu) ! (workspace: need n*n + 4*n, prefer n*n + 3*n + n*nb) - call stdlib_qorgbr( 'Q', n, n, n, work( iu ), ldwrku,work( itauq ), & + call stdlib_${ri}$orgbr( 'Q', n, n, n, work( iu ), ldwrku,work( itauq ), & work( iwork ),lwork-iwork+1, ierr ) ! generate right bidiagonalizing vectors in vt ! (workspace: need n*n + 4*n-1, ! prefer n*n+3*n+(n-1)*nb) - call stdlib_qorgbr( 'P', n, n, n, vt, ldvt, work( itaup ),work( iwork ),& + call stdlib_${ri}$orgbr( 'P', n, n, n, vt, ldvt, work( itaup ),work( iwork ),& lwork-iwork+1, ierr ) iwork = ie + n ! perform bidiagonal qr iteration, computing left ! singular vectors of r in work(iu) and computing ! right singular vectors of r in vt ! (workspace: need n*n + bdspac) - call stdlib_qbdsqr( 'U', n, n, n, 0, s, work( ie ), vt,ldvt, work( iu ),& + call stdlib_${ri}$bdsqr( 'U', n, n, n, 0, s, work( ie ), vt,ldvt, work( iu ),& ldwrku, dum, 1,work( iwork ), info ) ! multiply q in u by left singular vectors of r in ! work(iu), storing result in a ! (workspace: need n*n) - call stdlib_qgemm( 'N', 'N', m, n, n, one, u, ldu,work( iu ), ldwrku, & + call stdlib_${ri}$gemm( 'N', 'N', m, n, n, one, u, ldu,work( iu ), ldwrku, & zero, a, lda ) ! copy left singular vectors of a from a to u - call stdlib_qlacpy( 'F', m, n, a, lda, u, ldu ) + call stdlib_${ri}$lacpy( 'F', m, n, a, lda, u, ldu ) else ! insufficient workspace for a fast algorithm itau = 1 iwork = itau + n ! compute a=q*r, copying result to u ! (workspace: need 2*n, prefer n + n*nb) - call stdlib_qgeqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib_${ri}$geqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - call stdlib_qlacpy( 'L', m, n, a, lda, u, ldu ) + call stdlib_${ri}$lacpy( 'L', m, n, a, lda, u, ldu ) ! generate q in u ! (workspace: need n + m, prefer n + m*nb) - call stdlib_qorgqr( m, m, n, u, ldu, work( itau ),work( iwork ), lwork-& + call stdlib_${ri}$orgqr( m, m, n, u, ldu, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ! copy r from a to vt, zeroing out below it - call stdlib_qlacpy( 'U', n, n, a, lda, vt, ldvt ) - if( n>1 )call stdlib_qlaset( 'L', n-1, n-1, zero, zero,vt( 2, 1 ), ldvt & + call stdlib_${ri}$lacpy( 'U', n, n, a, lda, vt, ldvt ) + if( n>1 )call stdlib_${ri}$laset( 'L', n-1, n-1, zero, zero,vt( 2, 1 ), ldvt & ) ie = itau itauq = ie + n @@ -12335,23 +12336,23 @@ module stdlib_linalg_lapack_q iwork = itaup + n ! bidiagonalize r in vt ! (workspace: need 4*n, prefer 3*n + 2*n*nb) - call stdlib_qgebrd( n, n, vt, ldvt, s, work( ie ),work( itauq ), work( & + call stdlib_${ri}$gebrd( n, n, vt, ldvt, s, work( ie ),work( itauq ), work( & itaup ),work( iwork ), lwork-iwork+1, ierr ) ! multiply q in u by left bidiagonalizing vectors ! in vt ! (workspace: need 3*n + m, prefer 3*n + m*nb) - call stdlib_qormbr( 'Q', 'R', 'N', m, n, n, vt, ldvt,work( itauq ), u, & + call stdlib_${ri}$ormbr( 'Q', 'R', 'N', m, n, n, vt, ldvt,work( itauq ), u, & ldu, work( iwork ),lwork-iwork+1, ierr ) ! generate right bidiagonalizing vectors in vt ! (workspace: need 4*n-1, prefer 3*n + (n-1)*nb) - call stdlib_qorgbr( 'P', n, n, n, vt, ldvt, work( itaup ),work( iwork ),& + call stdlib_${ri}$orgbr( 'P', n, n, n, vt, ldvt, work( itaup ),work( iwork ),& lwork-iwork+1, ierr ) iwork = ie + n ! perform bidiagonal qr iteration, computing left ! singular vectors of a in u and computing right ! singular vectors of a in vt ! (workspace: need bdspac) - call stdlib_qbdsqr( 'U', n, n, m, 0, s, work( ie ), vt,ldvt, u, ldu, & + call stdlib_${ri}$bdsqr( 'U', n, n, m, 0, s, work( ie ), vt,ldvt, u, ldu, & dum, 1, work( iwork ),info ) end if end if @@ -12366,38 +12367,38 @@ module stdlib_linalg_lapack_q iwork = itaup + n ! bidiagonalize a ! (workspace: need 3*n + m, prefer 3*n + (m + n)*nb) - call stdlib_qgebrd( m, n, a, lda, s, work( ie ), work( itauq ),work( itaup ), & + call stdlib_${ri}$gebrd( m, n, a, lda, s, work( ie ), work( itauq ),work( itaup ), & work( iwork ), lwork-iwork+1,ierr ) if( wntuas ) then ! if left singular vectors desired in u, copy result to u ! and generate left bidiagonalizing vectors in u ! (workspace: need 3*n + ncu, prefer 3*n + ncu*nb) - call stdlib_qlacpy( 'L', m, n, a, lda, u, ldu ) + call stdlib_${ri}$lacpy( 'L', m, n, a, lda, u, ldu ) if( wntus )ncu = n if( wntua )ncu = m - call stdlib_qorgbr( 'Q', m, ncu, n, u, ldu, work( itauq ),work( iwork ), & + call stdlib_${ri}$orgbr( 'Q', m, ncu, n, u, ldu, work( itauq ),work( iwork ), & lwork-iwork+1, ierr ) end if if( wntvas ) then ! if right singular vectors desired in vt, copy result to ! vt and generate right bidiagonalizing vectors in vt ! (workspace: need 4*n-1, prefer 3*n + (n-1)*nb) - call stdlib_qlacpy( 'U', n, n, a, lda, vt, ldvt ) - call stdlib_qorgbr( 'P', n, n, n, vt, ldvt, work( itaup ),work( iwork ), & + call stdlib_${ri}$lacpy( 'U', n, n, a, lda, vt, ldvt ) + call stdlib_${ri}$orgbr( 'P', n, n, n, vt, ldvt, work( itaup ),work( iwork ), & lwork-iwork+1, ierr ) end if if( wntuo ) then ! if left singular vectors desired in a, generate left ! bidiagonalizing vectors in a ! (workspace: need 4*n, prefer 3*n + n*nb) - call stdlib_qorgbr( 'Q', m, n, n, a, lda, work( itauq ),work( iwork ), lwork-& + call stdlib_${ri}$orgbr( 'Q', m, n, n, a, lda, work( itauq ),work( iwork ), lwork-& iwork+1, ierr ) end if if( wntvo ) then ! if right singular vectors desired in a, generate right ! bidiagonalizing vectors in a ! (workspace: need 4*n-1, prefer 3*n + (n-1)*nb) - call stdlib_qorgbr( 'P', n, n, n, a, lda, work( itaup ),work( iwork ), lwork-& + call stdlib_${ri}$orgbr( 'P', n, n, n, a, lda, work( itaup ),work( iwork ), lwork-& iwork+1, ierr ) end if iwork = ie + n @@ -12410,21 +12411,21 @@ module stdlib_linalg_lapack_q ! left singular vectors in u and computing right singular ! vectors in vt ! (workspace: need bdspac) - call stdlib_qbdsqr( 'U', n, ncvt, nru, 0, s, work( ie ), vt,ldvt, u, ldu, dum,& + call stdlib_${ri}$bdsqr( 'U', n, ncvt, nru, 0, s, work( ie ), vt,ldvt, u, ldu, dum,& 1, work( iwork ), info ) else if( ( .not.wntuo ) .and. wntvo ) then ! perform bidiagonal qr iteration, if desired, computing ! left singular vectors in u and computing right singular ! vectors in a ! (workspace: need bdspac) - call stdlib_qbdsqr( 'U', n, ncvt, nru, 0, s, work( ie ), a, lda,u, ldu, dum, & + call stdlib_${ri}$bdsqr( 'U', n, ncvt, nru, 0, s, work( ie ), a, lda,u, ldu, dum, & 1, work( iwork ), info ) else ! perform bidiagonal qr iteration, if desired, computing ! left singular vectors in a and computing right singular ! vectors in vt ! (workspace: need bdspac) - call stdlib_qbdsqr( 'U', n, ncvt, nru, 0, s, work( ie ), vt,ldvt, a, lda, dum,& + call stdlib_${ri}$bdsqr( 'U', n, ncvt, nru, 0, s, work( ie ), vt,ldvt, a, lda, dum,& 1, work( iwork ), info ) end if end if @@ -12440,22 +12441,22 @@ module stdlib_linalg_lapack_q iwork = itau + m ! compute a=l*q ! (workspace: need 2*m, prefer m + m*nb) - call stdlib_qgelqf( m, n, a, lda, work( itau ), work( iwork ),lwork-iwork+1, & + call stdlib_${ri}$gelqf( m, n, a, lda, work( itau ), work( iwork ),lwork-iwork+1, & ierr ) ! zero out above l - if (m>1) call stdlib_qlaset( 'U', m-1, m-1, zero, zero, a( 1, 2 ), lda ) + if (m>1) call stdlib_${ri}$laset( 'U', m-1, m-1, zero, zero, a( 1, 2 ), lda ) ie = 1 itauq = ie + m itaup = itauq + m iwork = itaup + m ! bidiagonalize l in a ! (workspace: need 4*m, prefer 3*m + 2*m*nb) - call stdlib_qgebrd( m, m, a, lda, s, work( ie ), work( itauq ),work( itaup ), & + call stdlib_${ri}$gebrd( m, m, a, lda, s, work( ie ), work( itauq ),work( itaup ), & work( iwork ), lwork-iwork+1,ierr ) if( wntuo .or. wntuas ) then ! if left singular vectors desired, generate q ! (workspace: need 4*m, prefer 3*m + m*nb) - call stdlib_qorgbr( 'Q', m, m, m, a, lda, work( itauq ),work( iwork ), & + call stdlib_${ri}$orgbr( 'Q', m, m, m, a, lda, work( itauq ),work( iwork ), & lwork-iwork+1, ierr ) end if iwork = ie + m @@ -12464,10 +12465,10 @@ module stdlib_linalg_lapack_q ! perform bidiagonal qr iteration, computing left singular ! vectors of a in a if desired ! (workspace: need bdspac) - call stdlib_qbdsqr( 'U', m, 0, nru, 0, s, work( ie ), dum, 1, a,lda, dum, 1, & + call stdlib_${ri}$bdsqr( 'U', m, 0, nru, 0, s, work( ie ), dum, 1, a,lda, dum, 1, & work( iwork ), info ) ! if left singular vectors desired in u, copy them there - if( wntuas )call stdlib_qlacpy( 'F', m, m, a, lda, u, ldu ) + if( wntuas )call stdlib_${ri}$lacpy( 'F', m, m, a, lda, u, ldu ) else if( wntvo .and. wntun ) then ! path 2t(n much larger than m, jobu='n', jobvt='o') ! m right singular vectors to be overwritten on a and @@ -12495,15 +12496,15 @@ module stdlib_linalg_lapack_q iwork = itau + m ! compute a=l*q ! (workspace: need m*m + 2*m, prefer m*m + m + m*nb) - call stdlib_qgelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-iwork+& + call stdlib_${ri}$gelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-iwork+& 1, ierr ) ! copy l to work(ir) and zero out above it - call stdlib_qlacpy( 'L', m, m, a, lda, work( ir ), ldwrkr ) - call stdlib_qlaset( 'U', m-1, m-1, zero, zero,work( ir+ldwrkr ), ldwrkr ) + call stdlib_${ri}$lacpy( 'L', m, m, a, lda, work( ir ), ldwrkr ) + call stdlib_${ri}$laset( 'U', m-1, m-1, zero, zero,work( ir+ldwrkr ), ldwrkr ) ! generate q in a ! (workspace: need m*m + 2*m, prefer m*m + m + m*nb) - call stdlib_qorglq( m, n, m, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib_${ri}$orglq( m, n, m, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ie = itau itauq = ie + m @@ -12511,17 +12512,17 @@ module stdlib_linalg_lapack_q iwork = itaup + m ! bidiagonalize l in work(ir) ! (workspace: need m*m + 4*m, prefer m*m + 3*m + 2*m*nb) - call stdlib_qgebrd( m, m, work( ir ), ldwrkr, s, work( ie ),work( itauq ), & + call stdlib_${ri}$gebrd( m, m, work( ir ), ldwrkr, s, work( ie ),work( itauq ), & work( itaup ),work( iwork ), lwork-iwork+1, ierr ) ! generate right vectors bidiagonalizing l ! (workspace: need m*m + 4*m-1, prefer m*m + 3*m + (m-1)*nb) - call stdlib_qorgbr( 'P', m, m, m, work( ir ), ldwrkr,work( itaup ), work( & + call stdlib_${ri}$orgbr( 'P', m, m, m, work( ir ), ldwrkr,work( itaup ), work( & iwork ),lwork-iwork+1, ierr ) iwork = ie + m ! perform bidiagonal qr iteration, computing right ! singular vectors of l in work(ir) ! (workspace: need m*m + bdspac) - call stdlib_qbdsqr( 'U', m, m, 0, 0, s, work( ie ),work( ir ), ldwrkr, dum,& + call stdlib_${ri}$bdsqr( 'U', m, m, 0, 0, s, work( ie ),work( ir ), ldwrkr, dum,& 1, dum, 1,work( iwork ), info ) iu = ie + m ! multiply right singular vectors of l in work(ir) by q @@ -12529,9 +12530,9 @@ module stdlib_linalg_lapack_q ! (workspace: need m*m + 2*m, prefer m*m + m*n + m) do i = 1, n, chunk blk = min( n-i+1, chunk ) - call stdlib_qgemm( 'N', 'N', m, blk, m, one, work( ir ),ldwrkr, a( 1, i & + call stdlib_${ri}$gemm( 'N', 'N', m, blk, m, one, work( ir ),ldwrkr, a( 1, i & ), lda, zero,work( iu ), ldwrku ) - call stdlib_qlacpy( 'F', m, blk, work( iu ), ldwrku,a( 1, i ), lda ) + call stdlib_${ri}$lacpy( 'F', m, blk, work( iu ), ldwrku,a( 1, i ), lda ) end do else @@ -12542,17 +12543,17 @@ module stdlib_linalg_lapack_q iwork = itaup + m ! bidiagonalize a ! (workspace: need 3*m + n, prefer 3*m + (m + n)*nb) - call stdlib_qgebrd( m, n, a, lda, s, work( ie ),work( itauq ), work( itaup & + call stdlib_${ri}$gebrd( m, n, a, lda, s, work( ie ),work( itauq ), work( itaup & ),work( iwork ), lwork-iwork+1, ierr ) ! generate right vectors bidiagonalizing a ! (workspace: need 4*m, prefer 3*m + m*nb) - call stdlib_qorgbr( 'P', m, n, m, a, lda, work( itaup ),work( iwork ), & + call stdlib_${ri}$orgbr( 'P', m, n, m, a, lda, work( itaup ),work( iwork ), & lwork-iwork+1, ierr ) iwork = ie + m ! perform bidiagonal qr iteration, computing right ! singular vectors of a in a ! (workspace: need bdspac) - call stdlib_qbdsqr( 'L', m, n, 0, 0, s, work( ie ), a, lda,dum, 1, dum, 1, & + call stdlib_${ri}$bdsqr( 'L', m, n, 0, 0, s, work( ie ), a, lda,dum, 1, dum, 1, & work( iwork ), info ) end if else if( wntvo .and. wntuas ) then @@ -12582,14 +12583,14 @@ module stdlib_linalg_lapack_q iwork = itau + m ! compute a=l*q ! (workspace: need m*m + 2*m, prefer m*m + m + m*nb) - call stdlib_qgelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-iwork+& + call stdlib_${ri}$gelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-iwork+& 1, ierr ) ! copy l to u, zeroing about above it - call stdlib_qlacpy( 'L', m, m, a, lda, u, ldu ) - if (m>1) call stdlib_qlaset( 'U', m-1, m-1, zero, zero, u( 1, 2 ),ldu ) + call stdlib_${ri}$lacpy( 'L', m, m, a, lda, u, ldu ) + if (m>1) call stdlib_${ri}$laset( 'U', m-1, m-1, zero, zero, u( 1, 2 ),ldu ) ! generate q in a ! (workspace: need m*m + 2*m, prefer m*m + m + m*nb) - call stdlib_qorglq( m, n, m, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib_${ri}$orglq( m, n, m, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ie = itau itauq = ie + m @@ -12597,23 +12598,23 @@ module stdlib_linalg_lapack_q iwork = itaup + m ! bidiagonalize l in u, copying result to work(ir) ! (workspace: need m*m + 4*m, prefer m*m + 3*m + 2*m*nb) - call stdlib_qgebrd( m, m, u, ldu, s, work( ie ),work( itauq ), work( itaup & + call stdlib_${ri}$gebrd( m, m, u, ldu, s, work( ie ),work( itauq ), work( itaup & ),work( iwork ), lwork-iwork+1, ierr ) - call stdlib_qlacpy( 'U', m, m, u, ldu, work( ir ), ldwrkr ) + call stdlib_${ri}$lacpy( 'U', m, m, u, ldu, work( ir ), ldwrkr ) ! generate right vectors bidiagonalizing l in work(ir) ! (workspace: need m*m + 4*m-1, prefer m*m + 3*m + (m-1)*nb) - call stdlib_qorgbr( 'P', m, m, m, work( ir ), ldwrkr,work( itaup ), work( & + call stdlib_${ri}$orgbr( 'P', m, m, m, work( ir ), ldwrkr,work( itaup ), work( & iwork ),lwork-iwork+1, ierr ) ! generate left vectors bidiagonalizing l in u ! (workspace: need m*m + 4*m, prefer m*m + 3*m + m*nb) - call stdlib_qorgbr( 'Q', m, m, m, u, ldu, work( itauq ),work( iwork ), & + call stdlib_${ri}$orgbr( 'Q', m, m, m, u, ldu, work( itauq ),work( iwork ), & lwork-iwork+1, ierr ) iwork = ie + m ! perform bidiagonal qr iteration, computing left ! singular vectors of l in u, and computing right ! singular vectors of l in work(ir) ! (workspace: need m*m + bdspac) - call stdlib_qbdsqr( 'U', m, m, m, 0, s, work( ie ),work( ir ), ldwrkr, u, & + call stdlib_${ri}$bdsqr( 'U', m, m, m, 0, s, work( ie ),work( ir ), ldwrkr, u, & ldu, dum, 1,work( iwork ), info ) iu = ie + m ! multiply right singular vectors of l in work(ir) by q @@ -12621,9 +12622,9 @@ module stdlib_linalg_lapack_q ! (workspace: need m*m + 2*m, prefer m*m + m*n + m)) do i = 1, n, chunk blk = min( n-i+1, chunk ) - call stdlib_qgemm( 'N', 'N', m, blk, m, one, work( ir ),ldwrkr, a( 1, i & + call stdlib_${ri}$gemm( 'N', 'N', m, blk, m, one, work( ir ),ldwrkr, a( 1, i & ), lda, zero,work( iu ), ldwrku ) - call stdlib_qlacpy( 'F', m, blk, work( iu ), ldwrku,a( 1, i ), lda ) + call stdlib_${ri}$lacpy( 'F', m, blk, work( iu ), ldwrku,a( 1, i ), lda ) end do else @@ -12632,14 +12633,14 @@ module stdlib_linalg_lapack_q iwork = itau + m ! compute a=l*q ! (workspace: need 2*m, prefer m + m*nb) - call stdlib_qgelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-iwork+& + call stdlib_${ri}$gelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-iwork+& 1, ierr ) ! copy l to u, zeroing out above it - call stdlib_qlacpy( 'L', m, m, a, lda, u, ldu ) - if (m>1) call stdlib_qlaset( 'U', m-1, m-1, zero, zero, u( 1, 2 ),ldu ) + call stdlib_${ri}$lacpy( 'L', m, m, a, lda, u, ldu ) + if (m>1) call stdlib_${ri}$laset( 'U', m-1, m-1, zero, zero, u( 1, 2 ),ldu ) ! generate q in a ! (workspace: need 2*m, prefer m + m*nb) - call stdlib_qorglq( m, n, m, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib_${ri}$orglq( m, n, m, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ie = itau itauq = ie + m @@ -12647,22 +12648,22 @@ module stdlib_linalg_lapack_q iwork = itaup + m ! bidiagonalize l in u ! (workspace: need 4*m, prefer 3*m + 2*m*nb) - call stdlib_qgebrd( m, m, u, ldu, s, work( ie ),work( itauq ), work( itaup & + call stdlib_${ri}$gebrd( m, m, u, ldu, s, work( ie ),work( itauq ), work( itaup & ),work( iwork ), lwork-iwork+1, ierr ) ! multiply right vectors bidiagonalizing l by q in a ! (workspace: need 3*m + n, prefer 3*m + n*nb) - call stdlib_qormbr( 'P', 'L', 'T', m, n, m, u, ldu,work( itaup ), a, lda, & + call stdlib_${ri}$ormbr( 'P', 'L', 'T', m, n, m, u, ldu,work( itaup ), a, lda, & work( iwork ),lwork-iwork+1, ierr ) ! generate left vectors bidiagonalizing l in u ! (workspace: need 4*m, prefer 3*m + m*nb) - call stdlib_qorgbr( 'Q', m, m, m, u, ldu, work( itauq ),work( iwork ), & + call stdlib_${ri}$orgbr( 'Q', m, m, m, u, ldu, work( itauq ),work( iwork ), & lwork-iwork+1, ierr ) iwork = ie + m ! perform bidiagonal qr iteration, computing left ! singular vectors of a in u and computing right ! singular vectors of a in a ! (workspace: need bdspac) - call stdlib_qbdsqr( 'U', m, n, m, 0, s, work( ie ), a, lda,u, ldu, dum, 1, & + call stdlib_${ri}$bdsqr( 'U', m, n, m, 0, s, work( ie ), a, lda,u, ldu, dum, 1, & work( iwork ), info ) end if else if( wntvs ) then @@ -12684,15 +12685,15 @@ module stdlib_linalg_lapack_q iwork = itau + m ! compute a=l*q ! (workspace: need m*m + 2*m, prefer m*m + m + m*nb) - call stdlib_qgelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib_${ri}$gelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ! copy l to work(ir), zeroing out above it - call stdlib_qlacpy( 'L', m, m, a, lda, work( ir ),ldwrkr ) - call stdlib_qlaset( 'U', m-1, m-1, zero, zero,work( ir+ldwrkr ), ldwrkr & + call stdlib_${ri}$lacpy( 'L', m, m, a, lda, work( ir ),ldwrkr ) + call stdlib_${ri}$laset( 'U', m-1, m-1, zero, zero,work( ir+ldwrkr ), ldwrkr & ) ! generate q in a ! (workspace: need m*m + 2*m, prefer m*m + m + m*nb) - call stdlib_qorglq( m, n, m, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib_${ri}$orglq( m, n, m, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ie = itau itauq = ie + m @@ -12700,23 +12701,23 @@ module stdlib_linalg_lapack_q iwork = itaup + m ! bidiagonalize l in work(ir) ! (workspace: need m*m + 4*m, prefer m*m + 3*m + 2*m*nb) - call stdlib_qgebrd( m, m, work( ir ), ldwrkr, s,work( ie ), work( itauq & + call stdlib_${ri}$gebrd( m, m, work( ir ), ldwrkr, s,work( ie ), work( itauq & ),work( itaup ), work( iwork ),lwork-iwork+1, ierr ) ! generate right vectors bidiagonalizing l in ! work(ir) ! (workspace: need m*m + 4*m, prefer m*m + 3*m + (m-1)*nb) - call stdlib_qorgbr( 'P', m, m, m, work( ir ), ldwrkr,work( itaup ), & + call stdlib_${ri}$orgbr( 'P', m, m, m, work( ir ), ldwrkr,work( itaup ), & work( iwork ),lwork-iwork+1, ierr ) iwork = ie + m ! perform bidiagonal qr iteration, computing right ! singular vectors of l in work(ir) ! (workspace: need m*m + bdspac) - call stdlib_qbdsqr( 'U', m, m, 0, 0, s, work( ie ),work( ir ), ldwrkr, & + call stdlib_${ri}$bdsqr( 'U', m, m, 0, 0, s, work( ie ),work( ir ), ldwrkr, & dum, 1, dum, 1,work( iwork ), info ) ! multiply right singular vectors of l in work(ir) by ! q in a, storing result in vt ! (workspace: need m*m) - call stdlib_qgemm( 'N', 'N', m, n, m, one, work( ir ),ldwrkr, a, lda, & + call stdlib_${ri}$gemm( 'N', 'N', m, n, m, one, work( ir ),ldwrkr, a, lda, & zero, vt, ldvt ) else ! insufficient workspace for a fast algorithm @@ -12724,33 +12725,33 @@ module stdlib_linalg_lapack_q iwork = itau + m ! compute a=l*q ! (workspace: need 2*m, prefer m + m*nb) - call stdlib_qgelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib_${ri}$gelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ! copy result to vt - call stdlib_qlacpy( 'U', m, n, a, lda, vt, ldvt ) + call stdlib_${ri}$lacpy( 'U', m, n, a, lda, vt, ldvt ) ! generate q in vt ! (workspace: need 2*m, prefer m + m*nb) - call stdlib_qorglq( m, n, m, vt, ldvt, work( itau ),work( iwork ), & + call stdlib_${ri}$orglq( m, n, m, vt, ldvt, work( itau ),work( iwork ), & lwork-iwork+1, ierr ) ie = itau itauq = ie + m itaup = itauq + m iwork = itaup + m ! zero out above l in a - if (m>1) call stdlib_qlaset( 'U', m-1, m-1, zero, zero, a( 1, 2 ),lda ) + if (m>1) call stdlib_${ri}$laset( 'U', m-1, m-1, zero, zero, a( 1, 2 ),lda ) ! bidiagonalize l in a ! (workspace: need 4*m, prefer 3*m + 2*m*nb) - call stdlib_qgebrd( m, m, a, lda, s, work( ie ),work( itauq ), work( & + call stdlib_${ri}$gebrd( m, m, a, lda, s, work( ie ),work( itauq ), work( & itaup ),work( iwork ), lwork-iwork+1, ierr ) ! multiply right vectors bidiagonalizing l by q in vt ! (workspace: need 3*m + n, prefer 3*m + n*nb) - call stdlib_qormbr( 'P', 'L', 'T', m, n, m, a, lda,work( itaup ), vt, & + call stdlib_${ri}$ormbr( 'P', 'L', 'T', m, n, m, a, lda,work( itaup ), vt, & ldvt,work( iwork ), lwork-iwork+1, ierr ) iwork = ie + m ! perform bidiagonal qr iteration, computing right ! singular vectors of a in vt ! (workspace: need bdspac) - call stdlib_qbdsqr( 'U', m, n, 0, 0, s, work( ie ), vt,ldvt, dum, 1, & + call stdlib_${ri}$bdsqr( 'U', m, n, 0, 0, s, work( ie ), vt,ldvt, dum, 1, & dum, 1, work( iwork ),info ) end if else if( wntuo ) then @@ -12780,15 +12781,15 @@ module stdlib_linalg_lapack_q iwork = itau + m ! compute a=l*q ! (workspace: need 2*m*m + 2*m, prefer 2*m*m + m + m*nb) - call stdlib_qgelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib_${ri}$gelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ! copy l to work(iu), zeroing out below it - call stdlib_qlacpy( 'L', m, m, a, lda, work( iu ),ldwrku ) - call stdlib_qlaset( 'U', m-1, m-1, zero, zero,work( iu+ldwrku ), ldwrku & + call stdlib_${ri}$lacpy( 'L', m, m, a, lda, work( iu ),ldwrku ) + call stdlib_${ri}$laset( 'U', m-1, m-1, zero, zero,work( iu+ldwrku ), ldwrku & ) ! generate q in a ! (workspace: need 2*m*m + 2*m, prefer 2*m*m + m + m*nb) - call stdlib_qorglq( m, n, m, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib_${ri}$orglq( m, n, m, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ie = itau itauq = ie + m @@ -12798,71 +12799,71 @@ module stdlib_linalg_lapack_q ! work(ir) ! (workspace: need 2*m*m + 4*m, ! prefer 2*m*m+3*m+2*m*nb) - call stdlib_qgebrd( m, m, work( iu ), ldwrku, s,work( ie ), work( itauq & + call stdlib_${ri}$gebrd( m, m, work( iu ), ldwrku, s,work( ie ), work( itauq & ),work( itaup ), work( iwork ),lwork-iwork+1, ierr ) - call stdlib_qlacpy( 'L', m, m, work( iu ), ldwrku,work( ir ), ldwrkr ) + call stdlib_${ri}$lacpy( 'L', m, m, work( iu ), ldwrku,work( ir ), ldwrkr ) ! generate right bidiagonalizing vectors in work(iu) ! (workspace: need 2*m*m + 4*m-1, ! prefer 2*m*m+3*m+(m-1)*nb) - call stdlib_qorgbr( 'P', m, m, m, work( iu ), ldwrku,work( itaup ), & + call stdlib_${ri}$orgbr( 'P', m, m, m, work( iu ), ldwrku,work( itaup ), & work( iwork ),lwork-iwork+1, ierr ) ! generate left bidiagonalizing vectors in work(ir) ! (workspace: need 2*m*m + 4*m, prefer 2*m*m + 3*m + m*nb) - call stdlib_qorgbr( 'Q', m, m, m, work( ir ), ldwrkr,work( itauq ), & + call stdlib_${ri}$orgbr( 'Q', m, m, m, work( ir ), ldwrkr,work( itauq ), & work( iwork ),lwork-iwork+1, ierr ) iwork = ie + m ! perform bidiagonal qr iteration, computing left ! singular vectors of l in work(ir) and computing ! right singular vectors of l in work(iu) ! (workspace: need 2*m*m + bdspac) - call stdlib_qbdsqr( 'U', m, m, m, 0, s, work( ie ),work( iu ), ldwrku, & + call stdlib_${ri}$bdsqr( 'U', m, m, m, 0, s, work( ie ),work( iu ), ldwrku, & work( ir ),ldwrkr, dum, 1, work( iwork ), info ) ! multiply right singular vectors of l in work(iu) by ! q in a, storing result in vt ! (workspace: need m*m) - call stdlib_qgemm( 'N', 'N', m, n, m, one, work( iu ),ldwrku, a, lda, & + call stdlib_${ri}$gemm( 'N', 'N', m, n, m, one, work( iu ),ldwrku, a, lda, & zero, vt, ldvt ) ! copy left singular vectors of l to a ! (workspace: need m*m) - call stdlib_qlacpy( 'F', m, m, work( ir ), ldwrkr, a,lda ) + call stdlib_${ri}$lacpy( 'F', m, m, work( ir ), ldwrkr, a,lda ) else ! insufficient workspace for a fast algorithm itau = 1 iwork = itau + m ! compute a=l*q, copying result to vt ! (workspace: need 2*m, prefer m + m*nb) - call stdlib_qgelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib_${ri}$gelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - call stdlib_qlacpy( 'U', m, n, a, lda, vt, ldvt ) + call stdlib_${ri}$lacpy( 'U', m, n, a, lda, vt, ldvt ) ! generate q in vt ! (workspace: need 2*m, prefer m + m*nb) - call stdlib_qorglq( m, n, m, vt, ldvt, work( itau ),work( iwork ), & + call stdlib_${ri}$orglq( m, n, m, vt, ldvt, work( itau ),work( iwork ), & lwork-iwork+1, ierr ) ie = itau itauq = ie + m itaup = itauq + m iwork = itaup + m ! zero out above l in a - if (m>1) call stdlib_qlaset( 'U', m-1, m-1, zero, zero, a( 1, 2 ),lda ) + if (m>1) call stdlib_${ri}$laset( 'U', m-1, m-1, zero, zero, a( 1, 2 ),lda ) ! bidiagonalize l in a ! (workspace: need 4*m, prefer 3*m + 2*m*nb) - call stdlib_qgebrd( m, m, a, lda, s, work( ie ),work( itauq ), work( & + call stdlib_${ri}$gebrd( m, m, a, lda, s, work( ie ),work( itauq ), work( & itaup ),work( iwork ), lwork-iwork+1, ierr ) ! multiply right vectors bidiagonalizing l by q in vt ! (workspace: need 3*m + n, prefer 3*m + n*nb) - call stdlib_qormbr( 'P', 'L', 'T', m, n, m, a, lda,work( itaup ), vt, & + call stdlib_${ri}$ormbr( 'P', 'L', 'T', m, n, m, a, lda,work( itaup ), vt, & ldvt,work( iwork ), lwork-iwork+1, ierr ) ! generate left bidiagonalizing vectors of l in a ! (workspace: need 4*m, prefer 3*m + m*nb) - call stdlib_qorgbr( 'Q', m, m, m, a, lda, work( itauq ),work( iwork ), & + call stdlib_${ri}$orgbr( 'Q', m, m, m, a, lda, work( itauq ),work( iwork ), & lwork-iwork+1, ierr ) iwork = ie + m ! perform bidiagonal qr iteration, compute left ! singular vectors of a in a and compute right ! singular vectors of a in vt ! (workspace: need bdspac) - call stdlib_qbdsqr( 'U', m, n, m, 0, s, work( ie ), vt,ldvt, a, lda, & + call stdlib_${ri}$bdsqr( 'U', m, n, m, 0, s, work( ie ), vt,ldvt, a, lda, & dum, 1, work( iwork ),info ) end if else if( wntuas ) then @@ -12884,15 +12885,15 @@ module stdlib_linalg_lapack_q iwork = itau + m ! compute a=l*q ! (workspace: need m*m + 2*m, prefer m*m + m + m*nb) - call stdlib_qgelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib_${ri}$gelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ! copy l to work(iu), zeroing out above it - call stdlib_qlacpy( 'L', m, m, a, lda, work( iu ),ldwrku ) - call stdlib_qlaset( 'U', m-1, m-1, zero, zero,work( iu+ldwrku ), ldwrku & + call stdlib_${ri}$lacpy( 'L', m, m, a, lda, work( iu ),ldwrku ) + call stdlib_${ri}$laset( 'U', m-1, m-1, zero, zero,work( iu+ldwrku ), ldwrku & ) ! generate q in a ! (workspace: need m*m + 2*m, prefer m*m + m + m*nb) - call stdlib_qorglq( m, n, m, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib_${ri}$orglq( m, n, m, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ie = itau itauq = ie + m @@ -12900,29 +12901,29 @@ module stdlib_linalg_lapack_q iwork = itaup + m ! bidiagonalize l in work(iu), copying result to u ! (workspace: need m*m + 4*m, prefer m*m + 3*m + 2*m*nb) - call stdlib_qgebrd( m, m, work( iu ), ldwrku, s,work( ie ), work( itauq & + call stdlib_${ri}$gebrd( m, m, work( iu ), ldwrku, s,work( ie ), work( itauq & ),work( itaup ), work( iwork ),lwork-iwork+1, ierr ) - call stdlib_qlacpy( 'L', m, m, work( iu ), ldwrku, u,ldu ) + call stdlib_${ri}$lacpy( 'L', m, m, work( iu ), ldwrku, u,ldu ) ! generate right bidiagonalizing vectors in work(iu) ! (workspace: need m*m + 4*m-1, ! prefer m*m+3*m+(m-1)*nb) - call stdlib_qorgbr( 'P', m, m, m, work( iu ), ldwrku,work( itaup ), & + call stdlib_${ri}$orgbr( 'P', m, m, m, work( iu ), ldwrku,work( itaup ), & work( iwork ),lwork-iwork+1, ierr ) ! generate left bidiagonalizing vectors in u ! (workspace: need m*m + 4*m, prefer m*m + 3*m + m*nb) - call stdlib_qorgbr( 'Q', m, m, m, u, ldu, work( itauq ),work( iwork ), & + call stdlib_${ri}$orgbr( 'Q', m, m, m, u, ldu, work( itauq ),work( iwork ), & lwork-iwork+1, ierr ) iwork = ie + m ! perform bidiagonal qr iteration, computing left ! singular vectors of l in u and computing right ! singular vectors of l in work(iu) ! (workspace: need m*m + bdspac) - call stdlib_qbdsqr( 'U', m, m, m, 0, s, work( ie ),work( iu ), ldwrku, & + call stdlib_${ri}$bdsqr( 'U', m, m, m, 0, s, work( ie ),work( iu ), ldwrku, & u, ldu, dum, 1,work( iwork ), info ) ! multiply right singular vectors of l in work(iu) by ! q in a, storing result in vt ! (workspace: need m*m) - call stdlib_qgemm( 'N', 'N', m, n, m, one, work( iu ),ldwrku, a, lda, & + call stdlib_${ri}$gemm( 'N', 'N', m, n, m, one, work( iu ),ldwrku, a, lda, & zero, vt, ldvt ) else ! insufficient workspace for a fast algorithm @@ -12930,39 +12931,39 @@ module stdlib_linalg_lapack_q iwork = itau + m ! compute a=l*q, copying result to vt ! (workspace: need 2*m, prefer m + m*nb) - call stdlib_qgelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib_${ri}$gelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - call stdlib_qlacpy( 'U', m, n, a, lda, vt, ldvt ) + call stdlib_${ri}$lacpy( 'U', m, n, a, lda, vt, ldvt ) ! generate q in vt ! (workspace: need 2*m, prefer m + m*nb) - call stdlib_qorglq( m, n, m, vt, ldvt, work( itau ),work( iwork ), & + call stdlib_${ri}$orglq( m, n, m, vt, ldvt, work( itau ),work( iwork ), & lwork-iwork+1, ierr ) ! copy l to u, zeroing out above it - call stdlib_qlacpy( 'L', m, m, a, lda, u, ldu ) - if (m>1) call stdlib_qlaset( 'U', m-1, m-1, zero, zero, u( 1, 2 ),ldu ) + call stdlib_${ri}$lacpy( 'L', m, m, a, lda, u, ldu ) + if (m>1) call stdlib_${ri}$laset( 'U', m-1, m-1, zero, zero, u( 1, 2 ),ldu ) ie = itau itauq = ie + m itaup = itauq + m iwork = itaup + m ! bidiagonalize l in u ! (workspace: need 4*m, prefer 3*m + 2*m*nb) - call stdlib_qgebrd( m, m, u, ldu, s, work( ie ),work( itauq ), work( & + call stdlib_${ri}$gebrd( m, m, u, ldu, s, work( ie ),work( itauq ), work( & itaup ),work( iwork ), lwork-iwork+1, ierr ) ! multiply right bidiagonalizing vectors in u by q ! in vt ! (workspace: need 3*m + n, prefer 3*m + n*nb) - call stdlib_qormbr( 'P', 'L', 'T', m, n, m, u, ldu,work( itaup ), vt, & + call stdlib_${ri}$ormbr( 'P', 'L', 'T', m, n, m, u, ldu,work( itaup ), vt, & ldvt,work( iwork ), lwork-iwork+1, ierr ) ! generate left bidiagonalizing vectors in u ! (workspace: need 4*m, prefer 3*m + m*nb) - call stdlib_qorgbr( 'Q', m, m, m, u, ldu, work( itauq ),work( iwork ), & + call stdlib_${ri}$orgbr( 'Q', m, m, m, u, ldu, work( itauq ),work( iwork ), & lwork-iwork+1, ierr ) iwork = ie + m ! perform bidiagonal qr iteration, computing left ! singular vectors of a in u and computing right ! singular vectors of a in vt ! (workspace: need bdspac) - call stdlib_qbdsqr( 'U', m, n, m, 0, s, work( ie ), vt,ldvt, u, ldu, & + call stdlib_${ri}$bdsqr( 'U', m, n, m, 0, s, work( ie ), vt,ldvt, u, ldu, & dum, 1, work( iwork ),info ) end if end if @@ -12985,16 +12986,16 @@ module stdlib_linalg_lapack_q iwork = itau + m ! compute a=l*q, copying result to vt ! (workspace: need m*m + 2*m, prefer m*m + m + m*nb) - call stdlib_qgelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib_${ri}$gelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - call stdlib_qlacpy( 'U', m, n, a, lda, vt, ldvt ) + call stdlib_${ri}$lacpy( 'U', m, n, a, lda, vt, ldvt ) ! copy l to work(ir), zeroing out above it - call stdlib_qlacpy( 'L', m, m, a, lda, work( ir ),ldwrkr ) - call stdlib_qlaset( 'U', m-1, m-1, zero, zero,work( ir+ldwrkr ), ldwrkr & + call stdlib_${ri}$lacpy( 'L', m, m, a, lda, work( ir ),ldwrkr ) + call stdlib_${ri}$laset( 'U', m-1, m-1, zero, zero,work( ir+ldwrkr ), ldwrkr & ) ! generate q in vt ! (workspace: need m*m + m + n, prefer m*m + m + n*nb) - call stdlib_qorglq( n, n, m, vt, ldvt, work( itau ),work( iwork ), & + call stdlib_${ri}$orglq( n, n, m, vt, ldvt, work( itau ),work( iwork ), & lwork-iwork+1, ierr ) ie = itau itauq = ie + m @@ -13002,59 +13003,59 @@ module stdlib_linalg_lapack_q iwork = itaup + m ! bidiagonalize l in work(ir) ! (workspace: need m*m + 4*m, prefer m*m + 3*m + 2*m*nb) - call stdlib_qgebrd( m, m, work( ir ), ldwrkr, s,work( ie ), work( itauq & + call stdlib_${ri}$gebrd( m, m, work( ir ), ldwrkr, s,work( ie ), work( itauq & ),work( itaup ), work( iwork ),lwork-iwork+1, ierr ) ! generate right bidiagonalizing vectors in work(ir) ! (workspace: need m*m + 4*m-1, ! prefer m*m+3*m+(m-1)*nb) - call stdlib_qorgbr( 'P', m, m, m, work( ir ), ldwrkr,work( itaup ), & + call stdlib_${ri}$orgbr( 'P', m, m, m, work( ir ), ldwrkr,work( itaup ), & work( iwork ),lwork-iwork+1, ierr ) iwork = ie + m ! perform bidiagonal qr iteration, computing right ! singular vectors of l in work(ir) ! (workspace: need m*m + bdspac) - call stdlib_qbdsqr( 'U', m, m, 0, 0, s, work( ie ),work( ir ), ldwrkr, & + call stdlib_${ri}$bdsqr( 'U', m, m, 0, 0, s, work( ie ),work( ir ), ldwrkr, & dum, 1, dum, 1,work( iwork ), info ) ! multiply right singular vectors of l in work(ir) by ! q in vt, storing result in a ! (workspace: need m*m) - call stdlib_qgemm( 'N', 'N', m, n, m, one, work( ir ),ldwrkr, vt, ldvt, & + call stdlib_${ri}$gemm( 'N', 'N', m, n, m, one, work( ir ),ldwrkr, vt, ldvt, & zero, a, lda ) ! copy right singular vectors of a from a to vt - call stdlib_qlacpy( 'F', m, n, a, lda, vt, ldvt ) + call stdlib_${ri}$lacpy( 'F', m, n, a, lda, vt, ldvt ) else ! insufficient workspace for a fast algorithm itau = 1 iwork = itau + m ! compute a=l*q, copying result to vt ! (workspace: need 2*m, prefer m + m*nb) - call stdlib_qgelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib_${ri}$gelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - call stdlib_qlacpy( 'U', m, n, a, lda, vt, ldvt ) + call stdlib_${ri}$lacpy( 'U', m, n, a, lda, vt, ldvt ) ! generate q in vt ! (workspace: need m + n, prefer m + n*nb) - call stdlib_qorglq( n, n, m, vt, ldvt, work( itau ),work( iwork ), & + call stdlib_${ri}$orglq( n, n, m, vt, ldvt, work( itau ),work( iwork ), & lwork-iwork+1, ierr ) ie = itau itauq = ie + m itaup = itauq + m iwork = itaup + m ! zero out above l in a - if (m>1) call stdlib_qlaset( 'U', m-1, m-1, zero, zero, a( 1, 2 ),lda ) + if (m>1) call stdlib_${ri}$laset( 'U', m-1, m-1, zero, zero, a( 1, 2 ),lda ) ! bidiagonalize l in a ! (workspace: need 4*m, prefer 3*m + 2*m*nb) - call stdlib_qgebrd( m, m, a, lda, s, work( ie ),work( itauq ), work( & + call stdlib_${ri}$gebrd( m, m, a, lda, s, work( ie ),work( itauq ), work( & itaup ),work( iwork ), lwork-iwork+1, ierr ) ! multiply right bidiagonalizing vectors in a by q ! in vt ! (workspace: need 3*m + n, prefer 3*m + n*nb) - call stdlib_qormbr( 'P', 'L', 'T', m, n, m, a, lda,work( itaup ), vt, & + call stdlib_${ri}$ormbr( 'P', 'L', 'T', m, n, m, a, lda,work( itaup ), vt, & ldvt,work( iwork ), lwork-iwork+1, ierr ) iwork = ie + m ! perform bidiagonal qr iteration, computing right ! singular vectors of a in vt ! (workspace: need bdspac) - call stdlib_qbdsqr( 'U', m, n, 0, 0, s, work( ie ), vt,ldvt, dum, 1, & + call stdlib_${ri}$bdsqr( 'U', m, n, 0, 0, s, work( ie ), vt,ldvt, dum, 1, & dum, 1, work( iwork ),info ) end if else if( wntuo ) then @@ -13084,16 +13085,16 @@ module stdlib_linalg_lapack_q iwork = itau + m ! compute a=l*q, copying result to vt ! (workspace: need 2*m*m + 2*m, prefer 2*m*m + m + m*nb) - call stdlib_qgelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib_${ri}$gelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - call stdlib_qlacpy( 'U', m, n, a, lda, vt, ldvt ) + call stdlib_${ri}$lacpy( 'U', m, n, a, lda, vt, ldvt ) ! generate q in vt ! (workspace: need 2*m*m + m + n, prefer 2*m*m + m + n*nb) - call stdlib_qorglq( n, n, m, vt, ldvt, work( itau ),work( iwork ), & + call stdlib_${ri}$orglq( n, n, m, vt, ldvt, work( itau ),work( iwork ), & lwork-iwork+1, ierr ) ! copy l to work(iu), zeroing out above it - call stdlib_qlacpy( 'L', m, m, a, lda, work( iu ),ldwrku ) - call stdlib_qlaset( 'U', m-1, m-1, zero, zero,work( iu+ldwrku ), ldwrku & + call stdlib_${ri}$lacpy( 'L', m, m, a, lda, work( iu ),ldwrku ) + call stdlib_${ri}$laset( 'U', m-1, m-1, zero, zero,work( iu+ldwrku ), ldwrku & ) ie = itau itauq = ie + m @@ -13103,73 +13104,73 @@ module stdlib_linalg_lapack_q ! work(ir) ! (workspace: need 2*m*m + 4*m, ! prefer 2*m*m+3*m+2*m*nb) - call stdlib_qgebrd( m, m, work( iu ), ldwrku, s,work( ie ), work( itauq & + call stdlib_${ri}$gebrd( m, m, work( iu ), ldwrku, s,work( ie ), work( itauq & ),work( itaup ), work( iwork ),lwork-iwork+1, ierr ) - call stdlib_qlacpy( 'L', m, m, work( iu ), ldwrku,work( ir ), ldwrkr ) + call stdlib_${ri}$lacpy( 'L', m, m, work( iu ), ldwrku,work( ir ), ldwrkr ) ! generate right bidiagonalizing vectors in work(iu) ! (workspace: need 2*m*m + 4*m-1, ! prefer 2*m*m+3*m+(m-1)*nb) - call stdlib_qorgbr( 'P', m, m, m, work( iu ), ldwrku,work( itaup ), & + call stdlib_${ri}$orgbr( 'P', m, m, m, work( iu ), ldwrku,work( itaup ), & work( iwork ),lwork-iwork+1, ierr ) ! generate left bidiagonalizing vectors in work(ir) ! (workspace: need 2*m*m + 4*m, prefer 2*m*m + 3*m + m*nb) - call stdlib_qorgbr( 'Q', m, m, m, work( ir ), ldwrkr,work( itauq ), & + call stdlib_${ri}$orgbr( 'Q', m, m, m, work( ir ), ldwrkr,work( itauq ), & work( iwork ),lwork-iwork+1, ierr ) iwork = ie + m ! perform bidiagonal qr iteration, computing left ! singular vectors of l in work(ir) and computing ! right singular vectors of l in work(iu) ! (workspace: need 2*m*m + bdspac) - call stdlib_qbdsqr( 'U', m, m, m, 0, s, work( ie ),work( iu ), ldwrku, & + call stdlib_${ri}$bdsqr( 'U', m, m, m, 0, s, work( ie ),work( iu ), ldwrku, & work( ir ),ldwrkr, dum, 1, work( iwork ), info ) ! multiply right singular vectors of l in work(iu) by ! q in vt, storing result in a ! (workspace: need m*m) - call stdlib_qgemm( 'N', 'N', m, n, m, one, work( iu ),ldwrku, vt, ldvt, & + call stdlib_${ri}$gemm( 'N', 'N', m, n, m, one, work( iu ),ldwrku, vt, ldvt, & zero, a, lda ) ! copy right singular vectors of a from a to vt - call stdlib_qlacpy( 'F', m, n, a, lda, vt, ldvt ) + call stdlib_${ri}$lacpy( 'F', m, n, a, lda, vt, ldvt ) ! copy left singular vectors of a from work(ir) to a - call stdlib_qlacpy( 'F', m, m, work( ir ), ldwrkr, a,lda ) + call stdlib_${ri}$lacpy( 'F', m, m, work( ir ), ldwrkr, a,lda ) else ! insufficient workspace for a fast algorithm itau = 1 iwork = itau + m ! compute a=l*q, copying result to vt ! (workspace: need 2*m, prefer m + m*nb) - call stdlib_qgelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib_${ri}$gelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - call stdlib_qlacpy( 'U', m, n, a, lda, vt, ldvt ) + call stdlib_${ri}$lacpy( 'U', m, n, a, lda, vt, ldvt ) ! generate q in vt ! (workspace: need m + n, prefer m + n*nb) - call stdlib_qorglq( n, n, m, vt, ldvt, work( itau ),work( iwork ), & + call stdlib_${ri}$orglq( n, n, m, vt, ldvt, work( itau ),work( iwork ), & lwork-iwork+1, ierr ) ie = itau itauq = ie + m itaup = itauq + m iwork = itaup + m ! zero out above l in a - if (m>1) call stdlib_qlaset( 'U', m-1, m-1, zero, zero, a( 1, 2 ),lda ) + if (m>1) call stdlib_${ri}$laset( 'U', m-1, m-1, zero, zero, a( 1, 2 ),lda ) ! bidiagonalize l in a ! (workspace: need 4*m, prefer 3*m + 2*m*nb) - call stdlib_qgebrd( m, m, a, lda, s, work( ie ),work( itauq ), work( & + call stdlib_${ri}$gebrd( m, m, a, lda, s, work( ie ),work( itauq ), work( & itaup ),work( iwork ), lwork-iwork+1, ierr ) ! multiply right bidiagonalizing vectors in a by q ! in vt ! (workspace: need 3*m + n, prefer 3*m + n*nb) - call stdlib_qormbr( 'P', 'L', 'T', m, n, m, a, lda,work( itaup ), vt, & + call stdlib_${ri}$ormbr( 'P', 'L', 'T', m, n, m, a, lda,work( itaup ), vt, & ldvt,work( iwork ), lwork-iwork+1, ierr ) ! generate left bidiagonalizing vectors in a ! (workspace: need 4*m, prefer 3*m + m*nb) - call stdlib_qorgbr( 'Q', m, m, m, a, lda, work( itauq ),work( iwork ), & + call stdlib_${ri}$orgbr( 'Q', m, m, m, a, lda, work( itauq ),work( iwork ), & lwork-iwork+1, ierr ) iwork = ie + m ! perform bidiagonal qr iteration, computing left ! singular vectors of a in a and computing right ! singular vectors of a in vt ! (workspace: need bdspac) - call stdlib_qbdsqr( 'U', m, n, m, 0, s, work( ie ), vt,ldvt, a, lda, & + call stdlib_${ri}$bdsqr( 'U', m, n, m, 0, s, work( ie ), vt,ldvt, a, lda, & dum, 1, work( iwork ),info ) end if else if( wntuas ) then @@ -13191,16 +13192,16 @@ module stdlib_linalg_lapack_q iwork = itau + m ! compute a=l*q, copying result to vt ! (workspace: need m*m + 2*m, prefer m*m + m + m*nb) - call stdlib_qgelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib_${ri}$gelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - call stdlib_qlacpy( 'U', m, n, a, lda, vt, ldvt ) + call stdlib_${ri}$lacpy( 'U', m, n, a, lda, vt, ldvt ) ! generate q in vt ! (workspace: need m*m + m + n, prefer m*m + m + n*nb) - call stdlib_qorglq( n, n, m, vt, ldvt, work( itau ),work( iwork ), & + call stdlib_${ri}$orglq( n, n, m, vt, ldvt, work( itau ),work( iwork ), & lwork-iwork+1, ierr ) ! copy l to work(iu), zeroing out above it - call stdlib_qlacpy( 'L', m, m, a, lda, work( iu ),ldwrku ) - call stdlib_qlaset( 'U', m-1, m-1, zero, zero,work( iu+ldwrku ), ldwrku & + call stdlib_${ri}$lacpy( 'L', m, m, a, lda, work( iu ),ldwrku ) + call stdlib_${ri}$laset( 'U', m-1, m-1, zero, zero,work( iu+ldwrku ), ldwrku & ) ie = itau itauq = ie + m @@ -13208,70 +13209,70 @@ module stdlib_linalg_lapack_q iwork = itaup + m ! bidiagonalize l in work(iu), copying result to u ! (workspace: need m*m + 4*m, prefer m*m + 3*m + 2*m*nb) - call stdlib_qgebrd( m, m, work( iu ), ldwrku, s,work( ie ), work( itauq & + call stdlib_${ri}$gebrd( m, m, work( iu ), ldwrku, s,work( ie ), work( itauq & ),work( itaup ), work( iwork ),lwork-iwork+1, ierr ) - call stdlib_qlacpy( 'L', m, m, work( iu ), ldwrku, u,ldu ) + call stdlib_${ri}$lacpy( 'L', m, m, work( iu ), ldwrku, u,ldu ) ! generate right bidiagonalizing vectors in work(iu) ! (workspace: need m*m + 4*m, prefer m*m + 3*m + (m-1)*nb) - call stdlib_qorgbr( 'P', m, m, m, work( iu ), ldwrku,work( itaup ), & + call stdlib_${ri}$orgbr( 'P', m, m, m, work( iu ), ldwrku,work( itaup ), & work( iwork ),lwork-iwork+1, ierr ) ! generate left bidiagonalizing vectors in u ! (workspace: need m*m + 4*m, prefer m*m + 3*m + m*nb) - call stdlib_qorgbr( 'Q', m, m, m, u, ldu, work( itauq ),work( iwork ), & + call stdlib_${ri}$orgbr( 'Q', m, m, m, u, ldu, work( itauq ),work( iwork ), & lwork-iwork+1, ierr ) iwork = ie + m ! perform bidiagonal qr iteration, computing left ! singular vectors of l in u and computing right ! singular vectors of l in work(iu) ! (workspace: need m*m + bdspac) - call stdlib_qbdsqr( 'U', m, m, m, 0, s, work( ie ),work( iu ), ldwrku, & + call stdlib_${ri}$bdsqr( 'U', m, m, m, 0, s, work( ie ),work( iu ), ldwrku, & u, ldu, dum, 1,work( iwork ), info ) ! multiply right singular vectors of l in work(iu) by ! q in vt, storing result in a ! (workspace: need m*m) - call stdlib_qgemm( 'N', 'N', m, n, m, one, work( iu ),ldwrku, vt, ldvt, & + call stdlib_${ri}$gemm( 'N', 'N', m, n, m, one, work( iu ),ldwrku, vt, ldvt, & zero, a, lda ) ! copy right singular vectors of a from a to vt - call stdlib_qlacpy( 'F', m, n, a, lda, vt, ldvt ) + call stdlib_${ri}$lacpy( 'F', m, n, a, lda, vt, ldvt ) else ! insufficient workspace for a fast algorithm itau = 1 iwork = itau + m ! compute a=l*q, copying result to vt ! (workspace: need 2*m, prefer m + m*nb) - call stdlib_qgelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib_${ri}$gelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - call stdlib_qlacpy( 'U', m, n, a, lda, vt, ldvt ) + call stdlib_${ri}$lacpy( 'U', m, n, a, lda, vt, ldvt ) ! generate q in vt ! (workspace: need m + n, prefer m + n*nb) - call stdlib_qorglq( n, n, m, vt, ldvt, work( itau ),work( iwork ), & + call stdlib_${ri}$orglq( n, n, m, vt, ldvt, work( itau ),work( iwork ), & lwork-iwork+1, ierr ) ! copy l to u, zeroing out above it - call stdlib_qlacpy( 'L', m, m, a, lda, u, ldu ) - if (m>1) call stdlib_qlaset( 'U', m-1, m-1, zero, zero, u( 1, 2 ),ldu ) + call stdlib_${ri}$lacpy( 'L', m, m, a, lda, u, ldu ) + if (m>1) call stdlib_${ri}$laset( 'U', m-1, m-1, zero, zero, u( 1, 2 ),ldu ) ie = itau itauq = ie + m itaup = itauq + m iwork = itaup + m ! bidiagonalize l in u ! (workspace: need 4*m, prefer 3*m + 2*m*nb) - call stdlib_qgebrd( m, m, u, ldu, s, work( ie ),work( itauq ), work( & + call stdlib_${ri}$gebrd( m, m, u, ldu, s, work( ie ),work( itauq ), work( & itaup ),work( iwork ), lwork-iwork+1, ierr ) ! multiply right bidiagonalizing vectors in u by q ! in vt ! (workspace: need 3*m + n, prefer 3*m + n*nb) - call stdlib_qormbr( 'P', 'L', 'T', m, n, m, u, ldu,work( itaup ), vt, & + call stdlib_${ri}$ormbr( 'P', 'L', 'T', m, n, m, u, ldu,work( itaup ), vt, & ldvt,work( iwork ), lwork-iwork+1, ierr ) ! generate left bidiagonalizing vectors in u ! (workspace: need 4*m, prefer 3*m + m*nb) - call stdlib_qorgbr( 'Q', m, m, m, u, ldu, work( itauq ),work( iwork ), & + call stdlib_${ri}$orgbr( 'Q', m, m, m, u, ldu, work( itauq ),work( iwork ), & lwork-iwork+1, ierr ) iwork = ie + m ! perform bidiagonal qr iteration, computing left ! singular vectors of a in u and computing right ! singular vectors of a in vt ! (workspace: need bdspac) - call stdlib_qbdsqr( 'U', m, n, m, 0, s, work( ie ), vt,ldvt, u, ldu, & + call stdlib_${ri}$bdsqr( 'U', m, n, m, 0, s, work( ie ), vt,ldvt, u, ldu, & dum, 1, work( iwork ),info ) end if end if @@ -13286,38 +13287,38 @@ module stdlib_linalg_lapack_q iwork = itaup + m ! bidiagonalize a ! (workspace: need 3*m + n, prefer 3*m + (m + n)*nb) - call stdlib_qgebrd( m, n, a, lda, s, work( ie ), work( itauq ),work( itaup ), & + call stdlib_${ri}$gebrd( m, n, a, lda, s, work( ie ), work( itauq ),work( itaup ), & work( iwork ), lwork-iwork+1,ierr ) if( wntuas ) then ! if left singular vectors desired in u, copy result to u ! and generate left bidiagonalizing vectors in u ! (workspace: need 4*m-1, prefer 3*m + (m-1)*nb) - call stdlib_qlacpy( 'L', m, m, a, lda, u, ldu ) - call stdlib_qorgbr( 'Q', m, m, n, u, ldu, work( itauq ),work( iwork ), lwork-& + call stdlib_${ri}$lacpy( 'L', m, m, a, lda, u, ldu ) + call stdlib_${ri}$orgbr( 'Q', m, m, n, u, ldu, work( itauq ),work( iwork ), lwork-& iwork+1, ierr ) end if if( wntvas ) then ! if right singular vectors desired in vt, copy result to ! vt and generate right bidiagonalizing vectors in vt ! (workspace: need 3*m + nrvt, prefer 3*m + nrvt*nb) - call stdlib_qlacpy( 'U', m, n, a, lda, vt, ldvt ) + call stdlib_${ri}$lacpy( 'U', m, n, a, lda, vt, ldvt ) if( wntva )nrvt = n if( wntvs )nrvt = m - call stdlib_qorgbr( 'P', nrvt, n, m, vt, ldvt, work( itaup ),work( iwork ), & + call stdlib_${ri}$orgbr( 'P', nrvt, n, m, vt, ldvt, work( itaup ),work( iwork ), & lwork-iwork+1, ierr ) end if if( wntuo ) then ! if left singular vectors desired in a, generate left ! bidiagonalizing vectors in a ! (workspace: need 4*m-1, prefer 3*m + (m-1)*nb) - call stdlib_qorgbr( 'Q', m, m, n, a, lda, work( itauq ),work( iwork ), lwork-& + call stdlib_${ri}$orgbr( 'Q', m, m, n, a, lda, work( itauq ),work( iwork ), lwork-& iwork+1, ierr ) end if if( wntvo ) then ! if right singular vectors desired in a, generate right ! bidiagonalizing vectors in a ! (workspace: need 4*m, prefer 3*m + m*nb) - call stdlib_qorgbr( 'P', m, n, m, a, lda, work( itaup ),work( iwork ), lwork-& + call stdlib_${ri}$orgbr( 'P', m, n, m, a, lda, work( itaup ),work( iwork ), lwork-& iwork+1, ierr ) end if iwork = ie + m @@ -13330,26 +13331,26 @@ module stdlib_linalg_lapack_q ! left singular vectors in u and computing right singular ! vectors in vt ! (workspace: need bdspac) - call stdlib_qbdsqr( 'L', m, ncvt, nru, 0, s, work( ie ), vt,ldvt, u, ldu, dum,& + call stdlib_${ri}$bdsqr( 'L', m, ncvt, nru, 0, s, work( ie ), vt,ldvt, u, ldu, dum,& 1, work( iwork ), info ) else if( ( .not.wntuo ) .and. wntvo ) then ! perform bidiagonal qr iteration, if desired, computing ! left singular vectors in u and computing right singular ! vectors in a ! (workspace: need bdspac) - call stdlib_qbdsqr( 'L', m, ncvt, nru, 0, s, work( ie ), a, lda,u, ldu, dum, & + call stdlib_${ri}$bdsqr( 'L', m, ncvt, nru, 0, s, work( ie ), a, lda,u, ldu, dum, & 1, work( iwork ), info ) else ! perform bidiagonal qr iteration, if desired, computing ! left singular vectors in a and computing right singular ! vectors in vt ! (workspace: need bdspac) - call stdlib_qbdsqr( 'L', m, ncvt, nru, 0, s, work( ie ), vt,ldvt, a, lda, dum,& + call stdlib_${ri}$bdsqr( 'L', m, ncvt, nru, 0, s, work( ie ), vt,ldvt, a, lda, dum,& 1, work( iwork ), info ) end if end if end if - ! if stdlib_qbdsqr failed to converge, copy unconverged superdiagonals + ! if stdlib_${ri}$bdsqr failed to converge, copy unconverged superdiagonals ! to work( 2:minmn ) if( info/=0 ) then if( ie>2 ) then @@ -13365,22 +13366,22 @@ module stdlib_linalg_lapack_q end if ! undo scaling if necessary if( iscl==1 ) then - if( anrm>bignum )call stdlib_qlascl( 'G', 0, 0, bignum, anrm, minmn, 1, s, minmn,& + if( anrm>bignum )call stdlib_${ri}$lascl( 'G', 0, 0, bignum, anrm, minmn, 1, s, minmn,& ierr ) - if( info/=0 .and. anrm>bignum )call stdlib_qlascl( 'G', 0, 0, bignum, anrm, minmn-1,& + if( info/=0 .and. anrm>bignum )call stdlib_${ri}$lascl( 'G', 0, 0, bignum, anrm, minmn-1,& 1, work( 2 ),minmn, ierr ) - if( anrm= N. The SVD of A is written as !! [++] [xx] [x0] [xx] @@ -13397,9 +13398,9 @@ module stdlib_linalg_lapack_q integer(ilp), intent(out) :: numrank, info integer(ilp), intent(inout) :: lwork ! Array Arguments - real(qp), intent(inout) :: a(lda,*) - real(qp), intent(out) :: u(ldu,*), v(ldv,*), work(*) - real(qp), intent(out) :: s(*), rwork(*) + real(${rk}$), intent(inout) :: a(lda,*) + real(${rk}$), intent(out) :: u(ldu,*), v(ldv,*), work(*) + real(${rk}$), intent(out) :: s(*), rwork(*) integer(ilp), intent(out) :: iwork(*) ! ===================================================================== @@ -13410,9 +13411,9 @@ module stdlib_linalg_lapack_q lworq, lworq2, lworlq, minwrk, minwrk2, optwrk, optwrk2, iminwrk, rminwrk logical(lk) :: accla, acclm, acclh, ascaled, conda, dntwu, dntwv, lquery, lsvc0, lsvec,& rowprm, rsvec, rtrans, wntua, wntuf, wntur, wntus, wntva, wntvr - real(qp) :: big, epsln, rtmp, sconda, sfmin + real(${rk}$) :: big, epsln, rtmp, sconda, sfmin ! Local Arrays - real(qp) :: rdummy(1) + real(${rk}$) :: rdummy(1) ! Intrinsic Functions intrinsic :: abs,max,min,real,sqrt ! test the input arguments @@ -13494,14 +13495,14 @@ module stdlib_linalg_lapack_q ! Stdlib_Dgesvd Of An N X N Matrix lwsvd = max( 5 * n, 1 ) if ( lquery ) then - call stdlib_qgeqp3( m, n, a, lda, iwork, rdummy, rdummy, -1,ierr ) + call stdlib_${ri}$geqp3( m, n, a, lda, iwork, rdummy, rdummy, -1,ierr ) lwrk_qgeqp3 = int( rdummy(1),KIND=ilp) if ( wntus .or. wntur ) then - call stdlib_qormqr( 'L', 'N', m, n, n, a, lda, rdummy, u,ldu, rdummy, -1, & + call stdlib_${ri}$ormqr( 'L', 'N', m, n, n, a, lda, rdummy, u,ldu, rdummy, -1, & ierr ) lwrk_qormqr = int( rdummy(1),KIND=ilp) else if ( wntua ) then - call stdlib_qormqr( 'L', 'N', m, m, n, a, lda, rdummy, u,ldu, rdummy, -1, & + call stdlib_${ri}$ormqr( 'L', 'N', m, m, n, a, lda, rdummy, u,ldu, rdummy, -1, & ierr ) lwrk_qormqr = int( rdummy(1),KIND=ilp) else @@ -13519,7 +13520,7 @@ module stdlib_linalg_lapack_q minwrk = max( n+lwqp3, lwsvd ) end if if ( lquery ) then - call stdlib_qgesvd( 'N', 'N', n, n, a, lda, s, u, ldu,v, ldv, rdummy, -1, & + call stdlib_${ri}$gesvd( 'N', 'N', n, n, a, lda, s, u, ldu,v, ldv, rdummy, -1, & ierr ) lwrk_qgesvd = int( rdummy(1),KIND=ilp) if ( conda ) then @@ -13538,10 +13539,10 @@ module stdlib_linalg_lapack_q end if if ( lquery ) then if ( rtrans ) then - call stdlib_qgesvd( 'N', 'O', n, n, a, lda, s, u, ldu,v, ldv, rdummy, -1, & + call stdlib_${ri}$gesvd( 'N', 'O', n, n, a, lda, s, u, ldu,v, ldv, rdummy, -1, & ierr ) else - call stdlib_qgesvd( 'O', 'N', n, n, a, lda, s, u, ldu,v, ldv, rdummy, -1, & + call stdlib_${ri}$gesvd( 'O', 'N', n, n, a, lda, s, u, ldu,v, ldv, rdummy, -1, & ierr ) end if lwrk_qgesvd = int( rdummy(1),KIND=ilp) @@ -13561,10 +13562,10 @@ module stdlib_linalg_lapack_q end if if ( lquery ) then if ( rtrans ) then - call stdlib_qgesvd( 'O', 'N', n, n, a, lda, s, u, ldu,v, ldv, rdummy, -& + call stdlib_${ri}$gesvd( 'O', 'N', n, n, a, lda, s, u, ldu,v, ldv, rdummy, -& 1, ierr ) else - call stdlib_qgesvd( 'N', 'O', n, n, a, lda, s, u, ldu,v, ldv, rdummy, -& + call stdlib_${ri}$gesvd( 'N', 'O', n, n, a, lda, s, u, ldu,v, ldv, rdummy, -& 1, ierr ) end if lwrk_qgesvd = int( rdummy(1),KIND=ilp) @@ -13582,9 +13583,9 @@ module stdlib_linalg_lapack_q if ( conda ) minwrk = max( minwrk, lwcon ) minwrk = minwrk + n if ( wntva ) then - ! .. minimal workspace length for n x n/2 stdlib_qgeqrf + ! .. minimal workspace length for n x n/2 stdlib_${ri}$geqrf lwqrf = max( n/2, 1 ) - ! .. minimal workspace length for n/2 x n/2 stdlib_qgesvd + ! .. minimal workspace length for n/2 x n/2 stdlib_${ri}$gesvd lwsvd2 = max( 5 * (n/2), 1 ) lworq2 = max( n, 1 ) minwrk2 = max( lwqp3, n/2+lwqrf, n/2+lwsvd2,n/2+lworq2, lworq ) @@ -13597,7 +13598,7 @@ module stdlib_linalg_lapack_q if ( conda ) minwrk = max( minwrk, lwcon ) minwrk = minwrk + n if ( wntva ) then - ! .. minimal workspace length for n/2 x n stdlib_qgelqf + ! .. minimal workspace length for n/2 x n stdlib_${ri}$gelqf lwlqf = max( n/2, 1 ) lwsvd2 = max( 5 * (n/2), 1 ) lworlq = max( n , 1 ) @@ -13609,19 +13610,19 @@ module stdlib_linalg_lapack_q end if if ( lquery ) then if ( rtrans ) then - call stdlib_qgesvd( 'O', 'A', n, n, a, lda, s, u, ldu,v, ldv, rdummy, -1, & + call stdlib_${ri}$gesvd( 'O', 'A', n, n, a, lda, s, u, ldu,v, ldv, rdummy, -1, & ierr ) lwrk_qgesvd = int( rdummy(1),KIND=ilp) optwrk = max(lwrk_qgeqp3,lwrk_qgesvd,lwrk_qormqr) if ( conda ) optwrk = max( optwrk, lwcon ) optwrk = n + optwrk if ( wntva ) then - call stdlib_qgeqrf(n,n/2,u,ldu,rdummy,rdummy,-1,ierr) + call stdlib_${ri}$geqrf(n,n/2,u,ldu,rdummy,rdummy,-1,ierr) lwrk_qgeqrf = int( rdummy(1),KIND=ilp) - call stdlib_qgesvd( 'S', 'O', n/2,n/2, v,ldv, s, u,ldu,v, ldv, rdummy,& + call stdlib_${ri}$gesvd( 'S', 'O', n/2,n/2, v,ldv, s, u,ldu,v, ldv, rdummy,& -1, ierr ) lwrk_qgesvd2 = int( rdummy(1),KIND=ilp) - call stdlib_qormqr( 'R', 'C', n, n, n/2, u, ldu, rdummy,v, ldv, & + call stdlib_${ri}$ormqr( 'R', 'C', n, n, n/2, u, ldu, rdummy,v, ldv, & rdummy, -1, ierr ) lwrk_qormqr2 = int( rdummy(1),KIND=ilp) optwrk2 = max( lwrk_qgeqp3, n/2+lwrk_qgeqrf,n/2+lwrk_qgesvd2, n/2+& @@ -13631,19 +13632,19 @@ module stdlib_linalg_lapack_q optwrk = max( optwrk, optwrk2 ) end if else - call stdlib_qgesvd( 'S', 'O', n, n, a, lda, s, u, ldu,v, ldv, rdummy, -1, & + call stdlib_${ri}$gesvd( 'S', 'O', n, n, a, lda, s, u, ldu,v, ldv, rdummy, -1, & ierr ) lwrk_qgesvd = int( rdummy(1),KIND=ilp) optwrk = max(lwrk_qgeqp3,lwrk_qgesvd,lwrk_qormqr) if ( conda ) optwrk = max( optwrk, lwcon ) optwrk = n + optwrk if ( wntva ) then - call stdlib_qgelqf(n/2,n,u,ldu,rdummy,rdummy,-1,ierr) + call stdlib_${ri}$gelqf(n/2,n,u,ldu,rdummy,rdummy,-1,ierr) lwrk_qgelqf = int( rdummy(1),KIND=ilp) - call stdlib_qgesvd( 'S','O', n/2,n/2, v, ldv, s, u, ldu,v, ldv, rdummy,& + call stdlib_${ri}$gesvd( 'S','O', n/2,n/2, v, ldv, s, u, ldu,v, ldv, rdummy,& -1, ierr ) lwrk_qgesvd2 = int( rdummy(1),KIND=ilp) - call stdlib_qormlq( 'R', 'N', n, n, n/2, u, ldu, rdummy,v, ldv, rdummy,& + call stdlib_${ri}$ormlq( 'R', 'N', n, n, n/2, u, ldu, rdummy,v, ldv, rdummy,& -1,ierr ) lwrk_qormlq = int( rdummy(1),KIND=ilp) optwrk2 = max( lwrk_qgeqp3, n/2+lwrk_qgelqf,n/2+lwrk_qgesvd2, n/2+& @@ -13678,7 +13679,7 @@ module stdlib_linalg_lapack_q ! All Output Is Void return end if - big = stdlib_qlamch('O') + big = stdlib_${ri}$lamch('O') ascaled = .false. iwoff = 1 if ( rowprm ) then @@ -13688,8 +13689,8 @@ module stdlib_linalg_lapack_q ! the case of differently scaled rows. do p = 1, m ! rwork(p) = abs( a(p,stdlib_izamax(n,a(p,1),lda)) ) - ! [[stdlib_qlange will return nan if an entry of the p-th row is nan]] - rwork(p) = stdlib_qlange( 'M', 1, n, a(p,1), lda, rdummy ) + ! [[stdlib_${ri}$lange will return nan if an entry of the p-th row is nan]] + rwork(p) = stdlib_${ri}$lange( 'M', 1, n, a(p,1), lda, rdummy ) ! .. check for nan's and inf's if ( ( rwork(p) /= rwork(p) ) .or.( (rwork(p)*zero) /= zero ) ) then info = -8 @@ -13698,7 +13699,7 @@ module stdlib_linalg_lapack_q end if end do do p = 1, m - 1 - q = stdlib_iqamax( m-p+1, rwork(p), 1 ) + p - 1 + q = stdlib_i${ri}$amax( m-p+1, rwork(p), 1 ) + p - 1 iwork(n+p) = q if ( p /= q ) then rtmp = rwork(p) @@ -13709,13 +13710,13 @@ module stdlib_linalg_lapack_q if ( rwork(1) == zero ) then ! quick return: a is the m x n zero matrix. numrank = 0 - call stdlib_qlaset( 'G', n, 1, zero, zero, s, n ) - if ( wntus ) call stdlib_qlaset('G', m, n, zero, one, u, ldu) - if ( wntua ) call stdlib_qlaset('G', m, m, zero, one, u, ldu) - if ( wntva ) call stdlib_qlaset('G', n, n, zero, one, v, ldv) + call stdlib_${ri}$laset( 'G', n, 1, zero, zero, s, n ) + if ( wntus ) call stdlib_${ri}$laset('G', m, n, zero, one, u, ldu) + if ( wntua ) call stdlib_${ri}$laset('G', m, m, zero, one, u, ldu) + if ( wntva ) call stdlib_${ri}$laset('G', n, n, zero, one, v, ldv) if ( wntuf ) then - call stdlib_qlaset( 'G', n, 1, zero, zero, work, n ) - call stdlib_qlaset( 'G', m, n, zero, one, u, ldu ) + call stdlib_${ri}$laset( 'G', n, 1, zero, zero, work, n ) + call stdlib_${ri}$laset( 'G', m, n, zero, one, u, ldu ) end if do p = 1, n iwork(p) = p @@ -13729,30 +13730,30 @@ module stdlib_linalg_lapack_q rwork(2) = -1 return end if - if ( rwork(1) > big / sqrt(real(m,KIND=qp)) ) then + if ( rwork(1) > big / sqrt(real(m,KIND=${rk}$)) ) then ! .. to prevent overflow in the qr factorization, scale the ! matrix by 1/sqrt(m) if too large entry detected - call stdlib_qlascl('G',0,0,sqrt(real(m,KIND=qp)),one, m,n, a,lda, ierr) + call stdlib_${ri}$lascl('G',0,0,sqrt(real(m,KIND=${rk}$)),one, m,n, a,lda, ierr) ascaled = .true. end if - call stdlib_qlaswp( n, a, lda, 1, m-1, iwork(n+1), 1 ) + call stdlib_${ri}$laswp( n, a, lda, 1, m-1, iwork(n+1), 1 ) end if ! .. at this stage, preemptive scaling is done only to avoid column ! norms overflows during the qr factorization. the svd procedure should ! have its own scaling to save the singular values from overflows and ! underflows. that depends on the svd procedure. if ( .not.rowprm ) then - rtmp = stdlib_qlange( 'M', m, n, a, lda, rdummy ) + rtmp = stdlib_${ri}$lange( 'M', m, n, a, lda, rdummy ) if ( ( rtmp /= rtmp ) .or.( (rtmp*zero) /= zero ) ) then info = -8 call stdlib_xerbla( 'DGESVDQ', -info ) return end if - if ( rtmp > big / sqrt(real(m,KIND=qp)) ) then + if ( rtmp > big / sqrt(real(m,KIND=${rk}$)) ) then ! .. to prevent overflow in the qr factorization, scale the ! matrix by 1/sqrt(m) if too large entry detected - call stdlib_qlascl('G',0,0, sqrt(real(m,KIND=qp)),one, m,n, a,lda, ierr) + call stdlib_${ri}$lascl('G',0,0, sqrt(real(m,KIND=${rk}$)),one, m,n, a,lda, ierr) ascaled = .true. end if @@ -13764,12 +13765,12 @@ module stdlib_linalg_lapack_q ! All Columns Are Free Columns iwork(p) = 0 end do - call stdlib_qgeqp3( m, n, a, lda, iwork, work, work(n+1), lwork-n,ierr ) + call stdlib_${ri}$geqp3( m, n, a, lda, iwork, work, work(n+1), lwork-n,ierr ) ! if the user requested accuracy level allows truncation in the ! computed upper triangular factor, the matrix r is examined and, ! if possible, replaced with its leading upper trapezoidal part. - epsln = stdlib_qlamch('E') - sfmin = stdlib_qlamch('S') + epsln = stdlib_${ri}$lamch('E') + sfmin = stdlib_${ri}$lamch('S') ! small = sfmin / epsln nr = n if ( accla ) then @@ -13778,7 +13779,7 @@ module stdlib_linalg_lapack_q ! aggressive enforcement of lower numerical rank by introducing a ! backward error of the order of n*eps*||a||_f. nr = 1 - rtmp = sqrt(real(n,KIND=qp))*epsln + rtmp = sqrt(real(n,KIND=${rk}$))*epsln do p = 2, n if ( abs(a(p,p)) < (rtmp*abs(a(1,1))) ) go to 3002 nr = nr + 1 @@ -13787,7 +13788,7 @@ module stdlib_linalg_lapack_q elseif ( acclm ) then ! .. similarly as above, only slightly more gentle (less aggressive). ! sudden drop on the diagonal of r is used as the criterion for being - ! close-to-rank-deficient. the threshold is set to epsln=stdlib_qlamch('e'). + ! close-to-rank-deficient. the threshold is set to epsln=stdlib_${ri}$lamch('e'). ! [[this can be made more flexible by replacing this hard-coded value ! with a user specified threshold.]] also, the values that underflow ! will be truncated. @@ -13813,21 +13814,21 @@ module stdlib_linalg_lapack_q ! estimate the scaled condition number of a. use the fact that it is ! the same as the scaled condition number of r. ! V Is Used As Workspace - call stdlib_qlacpy( 'U', n, n, a, lda, v, ldv ) + call stdlib_${ri}$lacpy( 'U', n, n, a, lda, v, ldv ) ! only the leading nr x nr submatrix of the triangular factor ! is considered. only if nr=n will this give a reliable error ! bound. however, even for nr < n, this can be used on an ! expert level and obtain useful information in the sense of ! perturbation theory. do p = 1, nr - rtmp = stdlib_qnrm2( p, v(1,p), 1 ) - call stdlib_qscal( p, one/rtmp, v(1,p), 1 ) + rtmp = stdlib_${ri}$nrm2( p, v(1,p), 1 ) + call stdlib_${ri}$scal( p, one/rtmp, v(1,p), 1 ) end do if ( .not. ( lsvec .or. rsvec ) ) then - call stdlib_qpocon( 'U', nr, v, ldv, one, rtmp,work, iwork(n+iwoff), ierr & + call stdlib_${ri}$pocon( 'U', nr, v, ldv, one, rtmp,work, iwork(n+iwoff), ierr & ) else - call stdlib_qpocon( 'U', nr, v, ldv, one, rtmp,work(n+1), iwork(n+iwoff), & + call stdlib_${ri}$pocon( 'U', nr, v, ldv, one, rtmp,work(n+1), iwork(n+iwoff), & ierr ) end if sconda = one / sqrt(rtmp) @@ -13857,12 +13858,12 @@ module stdlib_linalg_lapack_q if ( q <= nr ) a(p,q) = zero end do end do - call stdlib_qgesvd( 'N', 'N', n, nr, a, lda, s, u, ldu,v, ldv, work, lwork, info & + call stdlib_${ri}$gesvd( 'N', 'N', n, nr, a, lda, s, u, ldu,v, ldv, work, lwork, info & ) else ! .. compute the singular values of r = [a](1:nr,1:n) - if ( nr > 1 )call stdlib_qlaset( 'L', nr-1,nr-1, zero,zero, a(2,1), lda ) - call stdlib_qgesvd( 'N', 'N', nr, n, a, lda, s, u, ldu,v, ldv, work, lwork, info & + if ( nr > 1 )call stdlib_${ri}$laset( 'L', nr-1,nr-1, zero,zero, a(2,1), lda ) + call stdlib_${ri}$gesvd( 'N', 'N', nr, n, a, lda, s, u, ldu,v, ldv, work, lwork, info & ) end if else if ( lsvec .and. ( .not. rsvec) ) then @@ -13870,7 +13871,7 @@ module stdlib_linalg_lapack_q ! The Singular Values And The Left Singular Vectors Requested ! ......................................................................."""""""" if ( rtrans ) then - ! .. apply stdlib_qgesvd to r**t + ! .. apply stdlib_${ri}$gesvd to r**t ! .. copy r**t into [u] and overwrite [u] with the right singular ! vectors of r do p = 1, nr @@ -13878,11 +13879,11 @@ module stdlib_linalg_lapack_q u(q,p) = a(p,q) end do end do - if ( nr > 1 )call stdlib_qlaset( 'U', nr-1,nr-1, zero,zero, u(1,2), ldu ) + if ( nr > 1 )call stdlib_${ri}$laset( 'U', nr-1,nr-1, zero,zero, u(1,2), ldu ) ! .. the left singular vectors not computed, the nr right singular ! vectors overwrite [u](1:nr,1:nr) as transposed. these ! will be pre-multiplied by q to build the left singular vectors of a. - call stdlib_qgesvd( 'N', 'O', n, nr, u, ldu, s, u, ldu,u, ldu, work(n+1), & + call stdlib_${ri}$gesvd( 'N', 'O', n, nr, u, ldu, s, u, ldu,u, ldu, work(n+1), & lwork-n, info ) do p = 1, nr do q = p + 1, nr @@ -13894,12 +13895,12 @@ module stdlib_linalg_lapack_q else ! Apply Stdlib_Dgesvd To R ! .. copy r into [u] and overwrite [u] with the left singular vectors - call stdlib_qlacpy( 'U', nr, n, a, lda, u, ldu ) - if ( nr > 1 )call stdlib_qlaset( 'L', nr-1, nr-1, zero, zero, u(2,1), ldu ) + call stdlib_${ri}$lacpy( 'U', nr, n, a, lda, u, ldu ) + if ( nr > 1 )call stdlib_${ri}$laset( 'L', nr-1, nr-1, zero, zero, u(2,1), ldu ) ! .. the right singular vectors not computed, the nr left singular ! vectors overwrite [u](1:nr,1:nr) - call stdlib_qgesvd( 'O', 'N', nr, n, u, ldu, s, u, ldu,v, ldv, work(n+1), & + call stdlib_${ri}$gesvd( 'O', 'N', nr, n, u, ldu, s, u, ldu,v, ldv, work(n+1), & lwork-n, info ) ! .. now [u](1:nr,1:nr) contains the nr left singular vectors of ! r. these will be pre-multiplied by q to build the left singular @@ -13908,35 +13909,35 @@ module stdlib_linalg_lapack_q ! Assemble The Left Singular Vector Matrix U Of Dimensions ! (m x nr) or (m x n) or (m x m). if ( ( nr < m ) .and. ( .not.wntuf ) ) then - call stdlib_qlaset('A', m-nr, nr, zero, zero, u(nr+1,1), ldu) + call stdlib_${ri}$laset('A', m-nr, nr, zero, zero, u(nr+1,1), ldu) if ( nr < n1 ) then - call stdlib_qlaset( 'A',nr,n1-nr,zero,zero,u(1,nr+1), ldu ) - call stdlib_qlaset( 'A',m-nr,n1-nr,zero,one,u(nr+1,nr+1), ldu ) + call stdlib_${ri}$laset( 'A',nr,n1-nr,zero,zero,u(1,nr+1), ldu ) + call stdlib_${ri}$laset( 'A',m-nr,n1-nr,zero,one,u(nr+1,nr+1), ldu ) end if end if ! the q matrix from the first qrf is built into the left singular ! vectors matrix u. - if ( .not.wntuf )call stdlib_qormqr( 'L', 'N', m, n1, n, a, lda, work, u,ldu, work(& + if ( .not.wntuf )call stdlib_${ri}$ormqr( 'L', 'N', m, n1, n, a, lda, work, u,ldu, work(& n+1), lwork-n, ierr ) - if ( rowprm .and. .not.wntuf )call stdlib_qlaswp( n1, u, ldu, 1, m-1, iwork(n+1), -& + if ( rowprm .and. .not.wntuf )call stdlib_${ri}$laswp( n1, u, ldu, 1, m-1, iwork(n+1), -& 1 ) else if ( rsvec .and. ( .not. lsvec ) ) then ! ....................................................................... ! The Singular Values And The Right Singular Vectors Requested ! ....................................................................... if ( rtrans ) then - ! .. apply stdlib_qgesvd to r**t + ! .. apply stdlib_${ri}$gesvd to r**t ! .. copy r**t into v and overwrite v with the left singular vectors do p = 1, nr do q = p, n v(q,p) = (a(p,q)) end do end do - if ( nr > 1 )call stdlib_qlaset( 'U', nr-1,nr-1, zero,zero, v(1,2), ldv ) + if ( nr > 1 )call stdlib_${ri}$laset( 'U', nr-1,nr-1, zero,zero, v(1,2), ldv ) ! .. the left singular vectors of r**t overwrite v, the right singular ! vectors not computed if ( wntvr .or. ( nr == n ) ) then - call stdlib_qgesvd( 'O', 'N', n, nr, v, ldv, s, u, ldu,u, ldu, work(n+1), & + call stdlib_${ri}$gesvd( 'O', 'N', n, nr, v, ldv, s, u, ldu,u, ldu, work(n+1), & lwork-n, info ) do p = 1, nr do q = p + 1, nr @@ -13952,15 +13953,15 @@ module stdlib_linalg_lapack_q end do end do end if - call stdlib_qlapmt( .false., nr, n, v, ldv, iwork ) + call stdlib_${ri}$lapmt( .false., nr, n, v, ldv, iwork ) else ! .. need all n right singular vectors and nr < n ! [!] this is simple implementation that augments [v](1:n,1:nr) ! by padding a zero block. in the case nr << n, a more efficient ! way is to first use the qr factorization. for more details ! how to implement this, see the " full svd " branch. - call stdlib_qlaset('G', n, n-nr, zero, zero, v(1,nr+1), ldv) - call stdlib_qgesvd( 'O', 'N', n, n, v, ldv, s, u, ldu,u, ldu, work(n+1), & + call stdlib_${ri}$laset('G', n, n-nr, zero, zero, v(1,nr+1), ldv) + call stdlib_${ri}$gesvd( 'O', 'N', n, n, v, ldv, s, u, ldu,u, ldu, work(n+1), & lwork-n, info ) do p = 1, n do q = p + 1, n @@ -13969,20 +13970,20 @@ module stdlib_linalg_lapack_q v(p,q) = rtmp end do end do - call stdlib_qlapmt( .false., n, n, v, ldv, iwork ) + call stdlib_${ri}$lapmt( .false., n, n, v, ldv, iwork ) end if else ! Aply Stdlib_Dgesvd To R ! Copy R Into V And Overwrite V With The Right Singular Vectors - call stdlib_qlacpy( 'U', nr, n, a, lda, v, ldv ) - if ( nr > 1 )call stdlib_qlaset( 'L', nr-1, nr-1, zero, zero, v(2,1), ldv ) + call stdlib_${ri}$lacpy( 'U', nr, n, a, lda, v, ldv ) + if ( nr > 1 )call stdlib_${ri}$laset( 'L', nr-1, nr-1, zero, zero, v(2,1), ldv ) ! .. the right singular vectors overwrite v, the nr left singular ! vectors stored in u(1:nr,1:nr) if ( wntvr .or. ( nr == n ) ) then - call stdlib_qgesvd( 'N', 'O', nr, n, v, ldv, s, u, ldu,v, ldv, work(n+1), & + call stdlib_${ri}$gesvd( 'N', 'O', nr, n, v, ldv, s, u, ldu,v, ldv, work(n+1), & lwork-n, info ) - call stdlib_qlapmt( .false., nr, n, v, ldv, iwork ) + call stdlib_${ri}$lapmt( .false., nr, n, v, ldv, iwork ) ! .. now [v](1:nr,1:n) contains v(1:n,1:nr)**t else ! .. need all n right singular vectors and nr < n @@ -13990,10 +13991,10 @@ module stdlib_linalg_lapack_q ! by padding a zero block. in the case nr << n, a more efficient ! way is to first use the lq factorization. for more details ! how to implement this, see the " full svd " branch. - call stdlib_qlaset('G', n-nr, n, zero,zero, v(nr+1,1), ldv) - call stdlib_qgesvd( 'N', 'O', n, n, v, ldv, s, u, ldu,v, ldv, work(n+1), & + call stdlib_${ri}$laset('G', n-nr, n, zero,zero, v(nr+1,1), ldv) + call stdlib_${ri}$gesvd( 'N', 'O', n, n, v, ldv, s, u, ldu,v, ldv, work(n+1), & lwork-n, info ) - call stdlib_qlapmt( .false., n, n, v, ldv, iwork ) + call stdlib_${ri}$lapmt( .false., n, n, v, ldv, iwork ) end if ! .. now [v] contains the transposed matrix of the right singular ! vectors of a. @@ -14003,7 +14004,7 @@ module stdlib_linalg_lapack_q ! Full Svd Requested ! ....................................................................... if ( rtrans ) then - ! .. apply stdlib_qgesvd to r**t [[this option is left for r + ! .. apply stdlib_${ri}$gesvd to r**t [[this option is left for r if ( wntvr .or. ( nr == n ) ) then ! .. copy r**t into [v] and overwrite [v] with the left singular ! vectors of r**t @@ -14012,10 +14013,10 @@ module stdlib_linalg_lapack_q v(q,p) = a(p,q) end do end do - if ( nr > 1 )call stdlib_qlaset( 'U', nr-1,nr-1, zero,zero, v(1,2), ldv ) + if ( nr > 1 )call stdlib_${ri}$laset( 'U', nr-1,nr-1, zero,zero, v(1,2), ldv ) ! .. the left singular vectors of r**t overwrite [v], the nr right ! singular vectors of r**t stored in [u](1:nr,1:nr) as transposed - call stdlib_qgesvd( 'O', 'A', n, nr, v, ldv, s, v, ldv,u, ldu, work(n+1), & + call stdlib_${ri}$gesvd( 'O', 'A', n, nr, v, ldv, s, v, ldv,u, ldu, work(n+1), & lwork-n, info ) ! Assemble V do p = 1, nr @@ -14032,7 +14033,7 @@ module stdlib_linalg_lapack_q end do end do end if - call stdlib_qlapmt( .false., nr, n, v, ldv, iwork ) + call stdlib_${ri}$lapmt( .false., nr, n, v, ldv, iwork ) do p = 1, nr do q = p + 1, nr rtmp = u(q,p) @@ -14041,10 +14042,10 @@ module stdlib_linalg_lapack_q end do end do if ( ( nr < m ) .and. .not.(wntuf)) then - call stdlib_qlaset('A', m-nr,nr, zero,zero, u(nr+1,1), ldu) + call stdlib_${ri}$laset('A', m-nr,nr, zero,zero, u(nr+1,1), ldu) if ( nr < n1 ) then - call stdlib_qlaset('A',nr,n1-nr,zero,zero,u(1,nr+1),ldu) - call stdlib_qlaset( 'A',m-nr,n1-nr,zero,one,u(nr+1,nr+1), ldu ) + call stdlib_${ri}$laset('A',nr,n1-nr,zero,zero,u(1,nr+1),ldu) + call stdlib_${ri}$laset( 'A',m-nr,n1-nr,zero,one,u(nr+1,nr+1), ldu ) end if end if else @@ -14063,10 +14064,10 @@ module stdlib_linalg_lapack_q v(q,p) = a(p,q) end do end do - if ( nr > 1 )call stdlib_qlaset('U',nr-1,nr-1, zero,zero, v(1,2),ldv) + if ( nr > 1 )call stdlib_${ri}$laset('U',nr-1,nr-1, zero,zero, v(1,2),ldv) - call stdlib_qlaset('A',n,n-nr,zero,zero,v(1,nr+1),ldv) - call stdlib_qgesvd( 'O', 'A', n, n, v, ldv, s, v, ldv,u, ldu, work(n+1), & + call stdlib_${ri}$laset('A',n,n-nr,zero,zero,v(1,nr+1),ldv) + call stdlib_${ri}$gesvd( 'O', 'A', n, n, v, ldv, s, v, ldv,u, ldu, work(n+1), & lwork-n, info ) do p = 1, n do q = p + 1, n @@ -14075,7 +14076,7 @@ module stdlib_linalg_lapack_q v(p,q) = rtmp end do end do - call stdlib_qlapmt( .false., n, n, v, ldv, iwork ) + call stdlib_${ri}$lapmt( .false., n, n, v, ldv, iwork ) ! Assemble The Left Singular Vector Matrix U Of Dimensions ! (m x n1), i.e. (m x n) or (m x m). do p = 1, n @@ -14086,10 +14087,10 @@ module stdlib_linalg_lapack_q end do end do if ( ( n < m ) .and. .not.(wntuf)) then - call stdlib_qlaset('A',m-n,n,zero,zero,u(n+1,1),ldu) + call stdlib_${ri}$laset('A',m-n,n,zero,zero,u(n+1,1),ldu) if ( n < n1 ) then - call stdlib_qlaset('A',n,n1-n,zero,zero,u(1,n+1),ldu) - call stdlib_qlaset('A',m-n,n1-n,zero,one,u(n+1,n+1), ldu ) + call stdlib_${ri}$laset('A',n,n1-n,zero,zero,u(1,n+1),ldu) + call stdlib_${ri}$laset('A',m-n,n1-n,zero,one,u(n+1,n+1), ldu ) end if end if else @@ -14100,55 +14101,55 @@ module stdlib_linalg_lapack_q u(q,nr+p) = a(p,q) end do end do - if ( nr > 1 )call stdlib_qlaset('U',nr-1,nr-1,zero,zero,u(1,nr+2),ldu) + if ( nr > 1 )call stdlib_${ri}$laset('U',nr-1,nr-1,zero,zero,u(1,nr+2),ldu) - call stdlib_qgeqrf( n, nr, u(1,nr+1), ldu, work(n+1),work(n+nr+1), lwork-& + call stdlib_${ri}$geqrf( n, nr, u(1,nr+1), ldu, work(n+1),work(n+nr+1), lwork-& n-nr, ierr ) do p = 1, nr do q = 1, n v(q,p) = u(p,nr+q) end do end do - if (nr>1) call stdlib_qlaset('U',nr-1,nr-1,zero,zero,v(1,2),ldv) - call stdlib_qgesvd( 'S', 'O', nr, nr, v, ldv, s, u, ldu,v,ldv, work(n+nr+1)& + if (nr>1) call stdlib_${ri}$laset('U',nr-1,nr-1,zero,zero,v(1,2),ldv) + call stdlib_${ri}$gesvd( 'S', 'O', nr, nr, v, ldv, s, u, ldu,v,ldv, work(n+nr+1)& ,lwork-n-nr, info ) - call stdlib_qlaset('A',n-nr,nr,zero,zero,v(nr+1,1),ldv) - call stdlib_qlaset('A',nr,n-nr,zero,zero,v(1,nr+1),ldv) - call stdlib_qlaset('A',n-nr,n-nr,zero,one,v(nr+1,nr+1),ldv) - call stdlib_qormqr('R','C', n, n, nr, u(1,nr+1), ldu,work(n+1),v,ldv,work(& + call stdlib_${ri}$laset('A',n-nr,nr,zero,zero,v(nr+1,1),ldv) + call stdlib_${ri}$laset('A',nr,n-nr,zero,zero,v(1,nr+1),ldv) + call stdlib_${ri}$laset('A',n-nr,n-nr,zero,one,v(nr+1,nr+1),ldv) + call stdlib_${ri}$ormqr('R','C', n, n, nr, u(1,nr+1), ldu,work(n+1),v,ldv,work(& n+nr+1),lwork-n-nr,ierr) - call stdlib_qlapmt( .false., n, n, v, ldv, iwork ) + call stdlib_${ri}$lapmt( .false., n, n, v, ldv, iwork ) ! Assemble The Left Singular Vector Matrix U Of Dimensions ! (m x nr) or (m x n) or (m x m). if ( ( nr < m ) .and. .not.(wntuf)) then - call stdlib_qlaset('A',m-nr,nr,zero,zero,u(nr+1,1),ldu) + call stdlib_${ri}$laset('A',m-nr,nr,zero,zero,u(nr+1,1),ldu) if ( nr < n1 ) then - call stdlib_qlaset('A',nr,n1-nr,zero,zero,u(1,nr+1),ldu) - call stdlib_qlaset( 'A',m-nr,n1-nr,zero,one,u(nr+1,nr+1),ldu) + call stdlib_${ri}$laset('A',nr,n1-nr,zero,zero,u(1,nr+1),ldu) + call stdlib_${ri}$laset( 'A',m-nr,n1-nr,zero,one,u(nr+1,nr+1),ldu) end if end if end if end if else - ! .. apply stdlib_qgesvd to r [[this is the recommended option]] + ! .. apply stdlib_${ri}$gesvd to r [[this is the recommended option]] if ( wntvr .or. ( nr == n ) ) then ! .. copy r into [v] and overwrite v with the right singular vectors - call stdlib_qlacpy( 'U', nr, n, a, lda, v, ldv ) - if ( nr > 1 )call stdlib_qlaset( 'L', nr-1,nr-1, zero,zero, v(2,1), ldv ) + call stdlib_${ri}$lacpy( 'U', nr, n, a, lda, v, ldv ) + if ( nr > 1 )call stdlib_${ri}$laset( 'L', nr-1,nr-1, zero,zero, v(2,1), ldv ) ! .. the right singular vectors of r overwrite [v], the nr left ! singular vectors of r stored in [u](1:nr,1:nr) - call stdlib_qgesvd( 'S', 'O', nr, n, v, ldv, s, u, ldu,v, ldv, work(n+1), & + call stdlib_${ri}$gesvd( 'S', 'O', nr, n, v, ldv, s, u, ldu,v, ldv, work(n+1), & lwork-n, info ) - call stdlib_qlapmt( .false., nr, n, v, ldv, iwork ) + call stdlib_${ri}$lapmt( .false., nr, n, v, ldv, iwork ) ! .. now [v](1:nr,1:n) contains v(1:n,1:nr)**t ! Assemble The Left Singular Vector Matrix U Of Dimensions ! (m x nr) or (m x n) or (m x m). if ( ( nr < m ) .and. .not.(wntuf)) then - call stdlib_qlaset('A', m-nr,nr, zero,zero, u(nr+1,1), ldu) + call stdlib_${ri}$laset('A', m-nr,nr, zero,zero, u(nr+1,1), ldu) if ( nr < n1 ) then - call stdlib_qlaset('A',nr,n1-nr,zero,zero,u(1,nr+1),ldu) - call stdlib_qlaset( 'A',m-nr,n1-nr,zero,one,u(nr+1,nr+1), ldu ) + call stdlib_${ri}$laset('A',nr,n1-nr,zero,zero,u(1,nr+1),ldu) + call stdlib_${ri}$laset( 'A',m-nr,n1-nr,zero,one,u(nr+1,nr+1), ldu ) end if end if else @@ -14162,50 +14163,50 @@ module stdlib_linalg_lapack_q ! optratio = max( optratio, 2 ) optratio = 2 if ( optratio * nr > n ) then - call stdlib_qlacpy( 'U', nr, n, a, lda, v, ldv ) - if ( nr > 1 )call stdlib_qlaset('L', nr-1,nr-1, zero,zero, v(2,1),ldv) + call stdlib_${ri}$lacpy( 'U', nr, n, a, lda, v, ldv ) + if ( nr > 1 )call stdlib_${ri}$laset('L', nr-1,nr-1, zero,zero, v(2,1),ldv) ! .. the right singular vectors of r overwrite [v], the nr left ! singular vectors of r stored in [u](1:nr,1:nr) - call stdlib_qlaset('A', n-nr,n, zero,zero, v(nr+1,1),ldv) - call stdlib_qgesvd( 'S', 'O', n, n, v, ldv, s, u, ldu,v, ldv, work(n+1), & + call stdlib_${ri}$laset('A', n-nr,n, zero,zero, v(nr+1,1),ldv) + call stdlib_${ri}$gesvd( 'S', 'O', n, n, v, ldv, s, u, ldu,v, ldv, work(n+1), & lwork-n, info ) - call stdlib_qlapmt( .false., n, n, v, ldv, iwork ) + call stdlib_${ri}$lapmt( .false., n, n, v, ldv, iwork ) ! .. now [v] contains the transposed matrix of the right ! singular vectors of a. the leading n left singular vectors ! are in [u](1:n,1:n) ! Assemble The Left Singular Vector Matrix U Of Dimensions ! (m x n1), i.e. (m x n) or (m x m). if ( ( n < m ) .and. .not.(wntuf)) then - call stdlib_qlaset('A',m-n,n,zero,zero,u(n+1,1),ldu) + call stdlib_${ri}$laset('A',m-n,n,zero,zero,u(n+1,1),ldu) if ( n < n1 ) then - call stdlib_qlaset('A',n,n1-n,zero,zero,u(1,n+1),ldu) - call stdlib_qlaset( 'A',m-n,n1-n,zero,one,u(n+1,n+1), ldu ) + call stdlib_${ri}$laset('A',n,n1-n,zero,zero,u(1,n+1),ldu) + call stdlib_${ri}$laset( 'A',m-n,n1-n,zero,one,u(n+1,n+1), ldu ) end if end if else - call stdlib_qlacpy( 'U', nr, n, a, lda, u(nr+1,1), ldu ) - if ( nr > 1 )call stdlib_qlaset('L',nr-1,nr-1,zero,zero,u(nr+2,1),ldu) + call stdlib_${ri}$lacpy( 'U', nr, n, a, lda, u(nr+1,1), ldu ) + if ( nr > 1 )call stdlib_${ri}$laset('L',nr-1,nr-1,zero,zero,u(nr+2,1),ldu) - call stdlib_qgelqf( nr, n, u(nr+1,1), ldu, work(n+1),work(n+nr+1), lwork-n-& + call stdlib_${ri}$gelqf( nr, n, u(nr+1,1), ldu, work(n+1),work(n+nr+1), lwork-n-& nr, ierr ) - call stdlib_qlacpy('L',nr,nr,u(nr+1,1),ldu,v,ldv) - if ( nr > 1 )call stdlib_qlaset('U',nr-1,nr-1,zero,zero,v(1,2),ldv) - call stdlib_qgesvd( 'S', 'O', nr, nr, v, ldv, s, u, ldu,v, ldv, work(n+nr+& + call stdlib_${ri}$lacpy('L',nr,nr,u(nr+1,1),ldu,v,ldv) + if ( nr > 1 )call stdlib_${ri}$laset('U',nr-1,nr-1,zero,zero,v(1,2),ldv) + call stdlib_${ri}$gesvd( 'S', 'O', nr, nr, v, ldv, s, u, ldu,v, ldv, work(n+nr+& 1), lwork-n-nr, info ) - call stdlib_qlaset('A',n-nr,nr,zero,zero,v(nr+1,1),ldv) - call stdlib_qlaset('A',nr,n-nr,zero,zero,v(1,nr+1),ldv) - call stdlib_qlaset('A',n-nr,n-nr,zero,one,v(nr+1,nr+1),ldv) - call stdlib_qormlq('R','N',n,n,nr,u(nr+1,1),ldu,work(n+1),v, ldv, work(n+& + call stdlib_${ri}$laset('A',n-nr,nr,zero,zero,v(nr+1,1),ldv) + call stdlib_${ri}$laset('A',nr,n-nr,zero,zero,v(1,nr+1),ldv) + call stdlib_${ri}$laset('A',n-nr,n-nr,zero,one,v(nr+1,nr+1),ldv) + call stdlib_${ri}$ormlq('R','N',n,n,nr,u(nr+1,1),ldu,work(n+1),v, ldv, work(n+& nr+1),lwork-n-nr,ierr) - call stdlib_qlapmt( .false., n, n, v, ldv, iwork ) + call stdlib_${ri}$lapmt( .false., n, n, v, ldv, iwork ) ! Assemble The Left Singular Vector Matrix U Of Dimensions ! (m x nr) or (m x n) or (m x m). if ( ( nr < m ) .and. .not.(wntuf)) then - call stdlib_qlaset('A',m-nr,nr,zero,zero,u(nr+1,1),ldu) + call stdlib_${ri}$laset('A',m-nr,nr,zero,zero,u(nr+1,1),ldu) if ( nr < n1 ) then - call stdlib_qlaset('A',nr,n1-nr,zero,zero,u(1,nr+1),ldu) - call stdlib_qlaset( 'A',m-nr,n1-nr,zero,one,u(nr+1,nr+1), ldu ) + call stdlib_${ri}$laset('A',nr,n1-nr,zero,zero,u(1,nr+1),ldu) + call stdlib_${ri}$laset( 'A',m-nr,n1-nr,zero,one,u(nr+1,nr+1), ldu ) end if end if end if @@ -14214,9 +14215,9 @@ module stdlib_linalg_lapack_q end if ! the q matrix from the first qrf is built into the left singular ! vectors matrix u. - if ( .not. wntuf )call stdlib_qormqr( 'L', 'N', m, n1, n, a, lda, work, u,ldu, work(& + if ( .not. wntuf )call stdlib_${ri}$ormqr( 'L', 'N', m, n1, n, a, lda, work, u,ldu, work(& n+1), lwork-n, ierr ) - if ( rowprm .and. .not.wntuf )call stdlib_qlaswp( n1, u, ldu, 1, m-1, iwork(n+1), -& + if ( rowprm .and. .not.wntuf )call stdlib_${ri}$laswp( n1, u, ldu, 1, m-1, iwork(n+1), -& 1 ) ! ... end of the "full svd" branch end if @@ -14230,22 +14231,22 @@ module stdlib_linalg_lapack_q 4002 continue ! .. if numerical rank deficiency is detected, the truncated ! singular values are set to zero. - if ( nr < n ) call stdlib_qlaset( 'G', n-nr,1, zero,zero, s(nr+1), n ) + if ( nr < n ) call stdlib_${ri}$laset( 'G', n-nr,1, zero,zero, s(nr+1), n ) ! .. undo scaling; this may cause overflow in the largest singular ! values. - if ( ascaled )call stdlib_qlascl( 'G',0,0, one,sqrt(real(m,KIND=qp)), nr,1, s, n, ierr & + if ( ascaled )call stdlib_${ri}$lascl( 'G',0,0, one,sqrt(real(m,KIND=${rk}$)), nr,1, s, n, ierr & ) if ( conda ) rwork(1) = sconda rwork(2) = p - nr ! .. p-nr is the number of singular values that are computed as - ! exact zeros in stdlib_qgesvd() applied to the (possibly truncated) + ! exact zeros in stdlib_${ri}$gesvd() applied to the (possibly truncated) ! full row rank triangular (trapezoidal) factor of a. numrank = nr return - end subroutine stdlib_qgesvdq + end subroutine stdlib_${ri}$gesvdq - pure subroutine stdlib_qgesvj( joba, jobu, jobv, m, n, a, lda, sva, mv, v,ldv, work, lwork, & + pure subroutine stdlib_${ri}$gesvj( joba, jobu, jobv, m, n, a, lda, sva, mv, v,ldv, work, lwork, & !! DGESVJ: computes the singular value decomposition (SVD) of a real !! M-by-N matrix A, where M >= N. The SVD of A is written as !! [++] [xx] [x0] [xx] @@ -14266,15 +14267,15 @@ module stdlib_linalg_lapack_q integer(ilp), intent(in) :: lda, ldv, lwork, m, mv, n character, intent(in) :: joba, jobu, jobv ! Array Arguments - real(qp), intent(inout) :: a(lda,*), v(ldv,*), work(lwork) - real(qp), intent(out) :: sva(n) + real(${rk}$), intent(inout) :: a(lda,*), v(ldv,*), work(lwork) + real(${rk}$), intent(out) :: sva(n) ! ===================================================================== ! Local Parameters integer(ilp), parameter :: nsweep = 30 ! Local Scalars - real(qp) :: aapp, aapp0, aapq, aaqq, apoaq, aqoap, big, bigtheta, cs, ctol, epsln, & + real(${rk}$) :: aapp, aapp0, aapq, aaqq, apoaq, aqoap, big, bigtheta, cs, ctol, epsln, & large, mxaapq, mxsinj, rootbig, rooteps, rootsfmin, roottol, skl, sfmin, small, sn, t, & temp1, theta, thsign, tol integer(ilp) :: blskip, emptsw, i, ibr, ierr, igl, ijblsk, ir1, iswrot, jbc, jgl, kbl, & @@ -14282,7 +14283,7 @@ module stdlib_linalg_lapack_q logical(lk) :: applv, goscale, lower, lsvec, noscale, rotok, rsvec, uctol, & upper ! Local Arrays - real(qp) :: fastr(5) + real(${rk}$) :: fastr(5) ! Intrinsic Functions intrinsic :: abs,max,min,real,sign,sqrt ! from lapack @@ -14335,26 +14336,26 @@ module stdlib_linalg_lapack_q else ! ... default if( lsvec .or. rsvec .or. applv ) then - ctol = sqrt( real( m,KIND=qp) ) + ctol = sqrt( real( m,KIND=${rk}$) ) else - ctol = real( m,KIND=qp) + ctol = real( m,KIND=${rk}$) end if end if ! ... and the machine dependent parameters are - ! [!] (make sure that stdlib_qlamch() works properly on the target machine.) - epsln = stdlib_qlamch( 'EPSILON' ) + ! [!] (make sure that stdlib_${ri}$lamch() works properly on the target machine.) + epsln = stdlib_${ri}$lamch( 'EPSILON' ) rooteps = sqrt( epsln ) - sfmin = stdlib_qlamch( 'SAFEMINIMUM' ) + sfmin = stdlib_${ri}$lamch( 'SAFEMINIMUM' ) rootsfmin = sqrt( sfmin ) small = sfmin / epsln - big = stdlib_qlamch( 'OVERFLOW' ) + big = stdlib_${ri}$lamch( 'OVERFLOW' ) ! big = one / sfmin rootbig = one / rootsfmin - large = big / sqrt( real( m*n,KIND=qp) ) + large = big / sqrt( real( m*n,KIND=${rk}$) ) bigtheta = one / rooteps tol = ctol*epsln roottol = sqrt( tol ) - if( real( m,KIND=qp)*epsln>=one ) then + if( real( m,KIND=${rk}$)*epsln>=one ) then info = -4 call stdlib_xerbla( 'DGESVJ', -info ) return @@ -14362,7 +14363,7 @@ module stdlib_linalg_lapack_q ! initialize the right singular vector matrix. if( rsvec ) then mvl = n - call stdlib_qlaset( 'A', mvl, n, zero, one, v, ldv ) + call stdlib_${ri}$laset( 'A', mvl, n, zero, one, v, ldv ) else if( applv ) then mvl = mv end if @@ -14375,7 +14376,7 @@ module stdlib_linalg_lapack_q ! goal is to make sure that no column norm overflows, and that ! sqrt(n)*max_i sva(i) does not overflow. if infinite entries ! in a are detected, the procedure returns with info=-6. - skl= one / sqrt( real( m,KIND=qp)*real( n,KIND=qp) ) + skl= one / sqrt( real( m,KIND=${rk}$)*real( n,KIND=${rk}$) ) noscale = .true. goscale = .true. if( lower ) then @@ -14383,7 +14384,7 @@ module stdlib_linalg_lapack_q do p = 1, n aapp = zero aaqq = one - call stdlib_qlassq( m-p+1, a( p, p ), 1, aapp, aaqq ) + call stdlib_${ri}$lassq( m-p+1, a( p, p ), 1, aapp, aaqq ) if( aapp>big ) then info = -6 call stdlib_xerbla( 'DGESVJ', -info ) @@ -14408,7 +14409,7 @@ module stdlib_linalg_lapack_q do p = 1, n aapp = zero aaqq = one - call stdlib_qlassq( p, a( 1, p ), 1, aapp, aaqq ) + call stdlib_${ri}$lassq( p, a( 1, p ), 1, aapp, aaqq ) if( aapp>big ) then info = -6 call stdlib_xerbla( 'DGESVJ', -info ) @@ -14433,7 +14434,7 @@ module stdlib_linalg_lapack_q do p = 1, n aapp = zero aaqq = one - call stdlib_qlassq( m, a( 1, p ), 1, aapp, aaqq ) + call stdlib_${ri}$lassq( m, a( 1, p ), 1, aapp, aaqq ) if( aapp>big ) then info = -6 call stdlib_xerbla( 'DGESVJ', -info ) @@ -14466,7 +14467,7 @@ module stdlib_linalg_lapack_q end do ! #:) quick return for zero matrix if( aapp==zero ) then - if( lsvec )call stdlib_qlaset( 'G', m, n, zero, one, a, lda ) + if( lsvec )call stdlib_${ri}$laset( 'G', m, n, zero, one, a, lda ) work( 1 ) = one work( 2 ) = zero work( 3 ) = zero @@ -14477,7 +14478,7 @@ module stdlib_linalg_lapack_q end if ! #:) quick return for one-column matrix if( n==1 ) then - if( lsvec )call stdlib_qlascl( 'G', 0, 0, sva( 1 ), skl, m, 1,a( 1, 1 ), lda, ierr ) + if( lsvec )call stdlib_${ri}$lascl( 'G', 0, 0, sva( 1 ), skl, m, 1,a( 1, 1 ), lda, ierr ) work( 1 ) = one / skl if( sva( 1 )>=sfmin ) then @@ -14494,14 +14495,14 @@ module stdlib_linalg_lapack_q ! protect small singular values from underflow, and try to ! avoid underflows/overflows in computing jacobi rotations. sn = sqrt( sfmin / epsln ) - temp1 = sqrt( big / real( n,KIND=qp) ) + temp1 = sqrt( big / real( n,KIND=${rk}$) ) if( ( aapp<=sn ) .or. ( aaqq>=temp1 ) .or.( ( sn<=aaqq ) .and. ( aapp<=temp1 ) ) ) & then temp1 = min( big, temp1 / aapp ) ! aaqq = aaqq*temp1 ! aapp = aapp*temp1 else if( ( aaqq<=sn ) .and. ( aapp<=temp1 ) ) then - temp1 = min( sn / aaqq, big / ( aapp*sqrt( real( n,KIND=qp) ) ) ) + temp1 = min( sn / aaqq, big / ( aapp*sqrt( real( n,KIND=${rk}$) ) ) ) ! aaqq = aaqq*temp1 ! aapp = aapp*temp1 else if( ( aaqq>=sn ) .and. ( aapp>=temp1 ) ) then @@ -14509,7 +14510,7 @@ module stdlib_linalg_lapack_q ! aaqq = aaqq*temp1 ! aapp = aapp*temp1 else if( ( aaqq<=sn ) .and. ( aapp>=temp1 ) ) then - temp1 = min( sn / aaqq, big / ( sqrt( real( n,KIND=qp) )*aapp ) ) + temp1 = min( sn / aaqq, big / ( sqrt( real( n,KIND=${rk}$) )*aapp ) ) ! aaqq = aaqq*temp1 ! aapp = aapp*temp1 else @@ -14517,11 +14518,11 @@ module stdlib_linalg_lapack_q end if ! scale, if necessary if( temp1/=one ) then - call stdlib_qlascl( 'G', 0, 0, one, temp1, n, 1, sva, n, ierr ) + call stdlib_${ri}$lascl( 'G', 0, 0, one, temp1, n, 1, sva, n, ierr ) end if skl= temp1*skl if( skl/=one ) then - call stdlib_qlascl( joba, 0, 0, one, skl, m, n, a, lda, ierr ) + call stdlib_${ri}$lascl( joba, 0, 0, one, skl, m, n, a, lda, ierr ) skl= one / skl end if ! row-cyclic jacobi svd algorithm with column pivoting @@ -14536,8 +14537,8 @@ module stdlib_linalg_lapack_q end do swband = 3 ! [tp] swband is a tuning parameter [tp]. it is meaningful and effective - ! if stdlib_qgesvj is used as a computational routine in the preconditioned - ! jacobi svd algorithm stdlib_qgesvj. for sweeps i=1:swband the procedure + ! if stdlib_${ri}$gesvj is used as a computational routine in the preconditioned + ! jacobi svd algorithm stdlib_${ri}$gesvj. for sweeps i=1:swband the procedure ! works on pivots inside a band-like region around the diagonal. ! the boundaries are determined dynamically, based on the number of ! pivots above a threshold. @@ -14577,31 +14578,31 @@ module stdlib_linalg_lapack_q ! [+ + 0 0] [0 0] ! [+ + x 0] actually work on [x 0] [x 0] ! [+ + x x] [x x]. [x x] - call stdlib_qgsvj0( jobv, m-n34, n-n34, a( n34+1, n34+1 ), lda,work( n34+1 ), & + call stdlib_${ri}$gsvj0( jobv, m-n34, n-n34, a( n34+1, n34+1 ), lda,work( n34+1 ), & sva( n34+1 ), mvl,v( n34*q+1, n34+1 ), ldv, epsln, sfmin, tol,2, work( n+1 ), & lwork-n, ierr ) - call stdlib_qgsvj0( jobv, m-n2, n34-n2, a( n2+1, n2+1 ), lda,work( n2+1 ), sva( & + call stdlib_${ri}$gsvj0( jobv, m-n2, n34-n2, a( n2+1, n2+1 ), lda,work( n2+1 ), sva( & n2+1 ), mvl,v( n2*q+1, n2+1 ), ldv, epsln, sfmin, tol, 2,work( n+1 ), lwork-n, & ierr ) - call stdlib_qgsvj1( jobv, m-n2, n-n2, n4, a( n2+1, n2+1 ), lda,work( n2+1 ), sva(& + call stdlib_${ri}$gsvj1( jobv, m-n2, n-n2, n4, a( n2+1, n2+1 ), lda,work( n2+1 ), sva(& n2+1 ), mvl,v( n2*q+1, n2+1 ), ldv, epsln, sfmin, tol, 1,work( n+1 ), lwork-n, & ierr ) - call stdlib_qgsvj0( jobv, m-n4, n2-n4, a( n4+1, n4+1 ), lda,work( n4+1 ), sva( & + call stdlib_${ri}$gsvj0( jobv, m-n4, n2-n4, a( n4+1, n4+1 ), lda,work( n4+1 ), sva( & n4+1 ), mvl,v( n4*q+1, n4+1 ), ldv, epsln, sfmin, tol, 1,work( n+1 ), lwork-n, & ierr ) - call stdlib_qgsvj0( jobv, m, n4, a, lda, work, sva, mvl, v, ldv,epsln, sfmin, & + call stdlib_${ri}$gsvj0( jobv, m, n4, a, lda, work, sva, mvl, v, ldv,epsln, sfmin, & tol, 1, work( n+1 ), lwork-n,ierr ) - call stdlib_qgsvj1( jobv, m, n2, n4, a, lda, work, sva, mvl, v,ldv, epsln, sfmin,& + call stdlib_${ri}$gsvj1( jobv, m, n2, n4, a, lda, work, sva, mvl, v,ldv, epsln, sfmin,& tol, 1, work( n+1 ),lwork-n, ierr ) else if( upper ) then - call stdlib_qgsvj0( jobv, n4, n4, a, lda, work, sva, mvl, v, ldv,epsln, sfmin, & + call stdlib_${ri}$gsvj0( jobv, n4, n4, a, lda, work, sva, mvl, v, ldv,epsln, sfmin, & tol, 2, work( n+1 ), lwork-n,ierr ) - call stdlib_qgsvj0( jobv, n2, n4, a( 1, n4+1 ), lda, work( n4+1 ),sva( n4+1 ), & + call stdlib_${ri}$gsvj0( jobv, n2, n4, a( 1, n4+1 ), lda, work( n4+1 ),sva( n4+1 ), & mvl, v( n4*q+1, n4+1 ), ldv,epsln, sfmin, tol, 1, work( n+1 ), lwork-n,ierr ) - call stdlib_qgsvj1( jobv, n2, n2, n4, a, lda, work, sva, mvl, v,ldv, epsln, & + call stdlib_${ri}$gsvj1( jobv, n2, n2, n4, a, lda, work, sva, mvl, v,ldv, epsln, & sfmin, tol, 1, work( n+1 ),lwork-n, ierr ) - call stdlib_qgsvj0( jobv, n2+n4, n4, a( 1, n2+1 ), lda,work( n2+1 ), sva( n2+1 ),& + call stdlib_${ri}$gsvj0( jobv, n2+n4, n4, a( 1, n2+1 ), lda,work( n2+1 ), sva( n2+1 ),& mvl,v( n2*q+1, n2+1 ), ldv, epsln, sfmin, tol, 1,work( n+1 ), lwork-n, ierr ) end if @@ -14624,10 +14625,10 @@ module stdlib_linalg_lapack_q igl = igl + ir1*kbl loop_2001: do p = igl, min( igl+kbl-1, n-1 ) ! .. de rijk's pivoting - q = stdlib_iqamax( n-p+1, sva( p ), 1 ) + p - 1 + q = stdlib_i${ri}$amax( n-p+1, sva( p ), 1 ) + p - 1 if( p/=q ) then - call stdlib_qswap( m, a( 1, p ), 1, a( 1, q ), 1 ) - if( rsvec )call stdlib_qswap( mvl, v( 1, p ), 1,v( 1, q ), 1 ) + call stdlib_${ri}$swap( m, a( 1, p ), 1, a( 1, q ), 1 ) + if( rsvec )call stdlib_${ri}$swap( mvl, v( 1, p ), 1,v( 1, q ), 1 ) temp1 = sva( p ) sva( p ) = sva( q ) sva( q ) = temp1 @@ -14639,20 +14640,20 @@ module stdlib_linalg_lapack_q ! column norms are periodically updated by explicit ! norm computation. ! caveat: - ! unfortunately, some blas implementations compute stdlib_qnrm2(m,a(1,p),1) - ! as sqrt(stdlib_qdot(m,a(1,p),1,a(1,p),1)), which may cause the result to + ! unfortunately, some blas implementations compute stdlib_${ri}$nrm2(m,a(1,p),1) + ! as sqrt(stdlib_${ri}$dot(m,a(1,p),1,a(1,p),1)), which may cause the result to ! overflow for ||a(:,p)||_2 > sqrt(overflow_threshold), and to ! underflow for ||a(:,p)||_2 < sqrt(underflow_threshold). - ! hence, stdlib_qnrm2 cannot be trusted, not even in the case when + ! hence, stdlib_${ri}$nrm2 cannot be trusted, not even in the case when ! the true norm is far from the under(over)flow boundaries. - ! if properly implemented stdlib_qnrm2 is available, the if-then-else - ! below should read "aapp = stdlib_qnrm2( m, a(1,p), 1 ) * work(p)". + ! if properly implemented stdlib_${ri}$nrm2 is available, the if-then-else + ! below should read "aapp = stdlib_${ri}$nrm2( m, a(1,p), 1 ) * work(p)". if( ( sva( p )rootsfmin ) ) then - sva( p ) = stdlib_qnrm2( m, a( 1, p ), 1 )*work( p ) + sva( p ) = stdlib_${ri}$nrm2( m, a( 1, p ), 1 )*work( p ) else temp1 = zero aapp = one - call stdlib_qlassq( m, a( 1, p ), 1, temp1, aapp ) + call stdlib_${ri}$lassq( m, a( 1, p ), 1, temp1, aapp ) sva( p ) = temp1*sqrt( aapp )*work( p ) end if aapp = sva( p ) @@ -14668,25 +14669,25 @@ module stdlib_linalg_lapack_q if( aaqq>=one ) then rotok = ( small*aapp )<=aaqq if( aapp<( big / aaqq ) ) then - aapq = ( stdlib_qdot( m, a( 1, p ), 1, a( 1,q ), 1 )*work( & + aapq = ( stdlib_${ri}$dot( m, a( 1, p ), 1, a( 1,q ), 1 )*work( & p )*work( q ) /aaqq ) / aapp else - call stdlib_qcopy( m, a( 1, p ), 1,work( n+1 ), 1 ) - call stdlib_qlascl( 'G', 0, 0, aapp,work( p ), m, 1,work( n+& + call stdlib_${ri}$copy( m, a( 1, p ), 1,work( n+1 ), 1 ) + call stdlib_${ri}$lascl( 'G', 0, 0, aapp,work( p ), m, 1,work( n+& 1 ), lda, ierr ) - aapq = stdlib_qdot( m, work( n+1 ), 1,a( 1, q ), 1 )*work( & + aapq = stdlib_${ri}$dot( m, work( n+1 ), 1,a( 1, q ), 1 )*work( & q ) / aaqq end if else rotok = aapp<=( aaqq / small ) if( aapp>( small / aaqq ) ) then - aapq = ( stdlib_qdot( m, a( 1, p ), 1, a( 1,q ), 1 )*work( & + aapq = ( stdlib_${ri}$dot( m, a( 1, p ), 1, a( 1,q ), 1 )*work( & p )*work( q ) /aaqq ) / aapp else - call stdlib_qcopy( m, a( 1, q ), 1,work( n+1 ), 1 ) - call stdlib_qlascl( 'G', 0, 0, aaqq,work( q ), m, 1,work( n+& + call stdlib_${ri}$copy( m, a( 1, q ), 1,work( n+1 ), 1 ) + call stdlib_${ri}$lascl( 'G', 0, 0, aaqq,work( q ), m, 1,work( n+& 1 ), lda, ierr ) - aapq = stdlib_qdot( m, work( n+1 ), 1,a( 1, p ), 1 )*work( & + aapq = stdlib_${ri}$dot( m, work( n+1 ), 1,a( 1, p ), 1 )*work( & p ) / aapp end if end if @@ -14708,9 +14709,9 @@ module stdlib_linalg_lapack_q t = half / theta fastr( 3 ) = t*work( p ) / work( q ) fastr( 4 ) = -t*work( q ) /work( p ) - call stdlib_qrotm( m, a( 1, p ), 1,a( 1, q ), 1, fastr ) + call stdlib_${ri}$rotm( m, a( 1, p ), 1,a( 1, q ), 1, fastr ) - if( rsvec )call stdlib_qrotm( mvl,v( 1, p ), 1,v( 1, q ),& + if( rsvec )call stdlib_${ri}$rotm( mvl,v( 1, p ), 1,v( 1, q ),& 1,fastr ) sva( q ) = aaqq*sqrt( max( zero,one+t*apoaq*aapq ) ) @@ -14735,63 +14736,63 @@ module stdlib_linalg_lapack_q fastr( 4 ) = -t*aqoap work( p ) = work( p )*cs work( q ) = work( q )*cs - call stdlib_qrotm( m, a( 1, p ), 1,a( 1, q ), 1,& + call stdlib_${ri}$rotm( m, a( 1, p ), 1,a( 1, q ), 1,& fastr ) - if( rsvec )call stdlib_qrotm( mvl,v( 1, p ), 1, v( & + if( rsvec )call stdlib_${ri}$rotm( mvl,v( 1, p ), 1, v( & 1, q ),1, fastr ) else - call stdlib_qaxpy( m, -t*aqoap,a( 1, q ), 1,a( 1, & + call stdlib_${ri}$axpy( m, -t*aqoap,a( 1, q ), 1,a( 1, & p ), 1 ) - call stdlib_qaxpy( m, cs*sn*apoaq,a( 1, p ), 1,a( & + call stdlib_${ri}$axpy( m, cs*sn*apoaq,a( 1, p ), 1,a( & 1, q ), 1 ) work( p ) = work( p )*cs work( q ) = work( q ) / cs if( rsvec ) then - call stdlib_qaxpy( mvl, -t*aqoap,v( 1, q ), 1,v(& + call stdlib_${ri}$axpy( mvl, -t*aqoap,v( 1, q ), 1,v(& 1, p ), 1 ) - call stdlib_qaxpy( mvl,cs*sn*apoaq,v( 1, p ), 1,& + call stdlib_${ri}$axpy( mvl,cs*sn*apoaq,v( 1, p ), 1,& v( 1, q ), 1 ) end if end if else if( work( q )>=one ) then - call stdlib_qaxpy( m, t*apoaq,a( 1, p ), 1,a( 1, q & + call stdlib_${ri}$axpy( m, t*apoaq,a( 1, p ), 1,a( 1, q & ), 1 ) - call stdlib_qaxpy( m, -cs*sn*aqoap,a( 1, q ), 1,a( & + call stdlib_${ri}$axpy( m, -cs*sn*aqoap,a( 1, q ), 1,a( & 1, p ), 1 ) work( p ) = work( p ) / cs work( q ) = work( q )*cs if( rsvec ) then - call stdlib_qaxpy( mvl, t*apoaq,v( 1, p ), 1,v( & + call stdlib_${ri}$axpy( mvl, t*apoaq,v( 1, p ), 1,v( & 1, q ), 1 ) - call stdlib_qaxpy( mvl,-cs*sn*aqoap,v( 1, q ), & + call stdlib_${ri}$axpy( mvl,-cs*sn*aqoap,v( 1, q ), & 1,v( 1, p ), 1 ) end if else if( work( p )>=work( q ) )then - call stdlib_qaxpy( m, -t*aqoap,a( 1, q ), 1,a( & + call stdlib_${ri}$axpy( m, -t*aqoap,a( 1, q ), 1,a( & 1, p ), 1 ) - call stdlib_qaxpy( m, cs*sn*apoaq,a( 1, p ), 1,& + call stdlib_${ri}$axpy( m, cs*sn*apoaq,a( 1, p ), 1,& a( 1, q ), 1 ) work( p ) = work( p )*cs work( q ) = work( q ) / cs if( rsvec ) then - call stdlib_qaxpy( mvl,-t*aqoap,v( 1, q ), 1,& + call stdlib_${ri}$axpy( mvl,-t*aqoap,v( 1, q ), 1,& v( 1, p ), 1 ) - call stdlib_qaxpy( mvl,cs*sn*apoaq,v( 1, p ),& + call stdlib_${ri}$axpy( mvl,cs*sn*apoaq,v( 1, p ),& 1,v( 1, q ), 1 ) end if else - call stdlib_qaxpy( m, t*apoaq,a( 1, p ), 1,a( 1,& + call stdlib_${ri}$axpy( m, t*apoaq,a( 1, p ), 1,a( 1,& q ), 1 ) - call stdlib_qaxpy( m,-cs*sn*aqoap,a( 1, q ), 1,& + call stdlib_${ri}$axpy( m,-cs*sn*aqoap,a( 1, q ), 1,& a( 1, p ), 1 ) work( p ) = work( p ) / cs work( q ) = work( q )*cs if( rsvec ) then - call stdlib_qaxpy( mvl,t*apoaq, v( 1, p ),1, & + call stdlib_${ri}$axpy( mvl,t*apoaq, v( 1, p ),1, & v( 1, q ), 1 ) - call stdlib_qaxpy( mvl,-cs*sn*aqoap,v( 1, q )& + call stdlib_${ri}$axpy( mvl,-cs*sn*aqoap,v( 1, q )& , 1,v( 1, p ), 1 ) end if end if @@ -14800,15 +14801,15 @@ module stdlib_linalg_lapack_q end if else ! .. have to use modified gram-schmidt like transformation - call stdlib_qcopy( m, a( 1, p ), 1,work( n+1 ), 1 ) - call stdlib_qlascl( 'G', 0, 0, aapp, one, m,1, work( n+1 ), & + call stdlib_${ri}$copy( m, a( 1, p ), 1,work( n+1 ), 1 ) + call stdlib_${ri}$lascl( 'G', 0, 0, aapp, one, m,1, work( n+1 ), & lda,ierr ) - call stdlib_qlascl( 'G', 0, 0, aaqq, one, m,1, a( 1, q ), & + call stdlib_${ri}$lascl( 'G', 0, 0, aaqq, one, m,1, a( 1, q ), & lda, ierr ) temp1 = -aapq*work( p ) / work( q ) - call stdlib_qaxpy( m, temp1, work( n+1 ), 1,a( 1, q ), 1 ) + call stdlib_${ri}$axpy( m, temp1, work( n+1 ), 1,a( 1, q ), 1 ) - call stdlib_qlascl( 'G', 0, 0, one, aaqq, m,1, a( 1, q ), & + call stdlib_${ri}$lascl( 'G', 0, 0, one, aaqq, m,1, a( 1, q ), & lda, ierr ) sva( q ) = aaqq*sqrt( max( zero,one-aapq*aapq ) ) mxsinj = max( mxsinj, sfmin ) @@ -14818,22 +14819,22 @@ module stdlib_linalg_lapack_q ! recompute sva(q), sva(p). if( ( sva( q ) / aaqq )**2<=rooteps )then if( ( aaqqrootsfmin ) ) then - sva( q ) = stdlib_qnrm2( m, a( 1, q ), 1 )*work( q ) + sva( q ) = stdlib_${ri}$nrm2( m, a( 1, q ), 1 )*work( q ) else t = zero aaqq = one - call stdlib_qlassq( m, a( 1, q ), 1, t,aaqq ) + call stdlib_${ri}$lassq( m, a( 1, q ), 1, t,aaqq ) sva( q ) = t*sqrt( aaqq )*work( q ) end if end if if( ( aapp / aapp0 )<=rooteps ) then if( ( aapprootsfmin ) ) then - aapp = stdlib_qnrm2( m, a( 1, p ), 1 )*work( p ) + aapp = stdlib_${ri}$nrm2( m, a( 1, p ), 1 )*work( p ) else t = zero aapp = one - call stdlib_qlassq( m, a( 1, p ), 1, t,aapp ) + call stdlib_${ri}$lassq( m, a( 1, p ), 1, t,aapp ) aapp = t*sqrt( aapp )*work( p ) end if sva( p ) = aapp @@ -14892,13 +14893,13 @@ module stdlib_linalg_lapack_q rotok = ( small*aaqq )<=aapp end if if( aapp<( big / aaqq ) ) then - aapq = ( stdlib_qdot( m, a( 1, p ), 1, a( 1,q ), 1 )*work( & + aapq = ( stdlib_${ri}$dot( m, a( 1, p ), 1, a( 1,q ), 1 )*work( & p )*work( q ) /aaqq ) / aapp else - call stdlib_qcopy( m, a( 1, p ), 1,work( n+1 ), 1 ) - call stdlib_qlascl( 'G', 0, 0, aapp,work( p ), m, 1,work( n+& + call stdlib_${ri}$copy( m, a( 1, p ), 1,work( n+1 ), 1 ) + call stdlib_${ri}$lascl( 'G', 0, 0, aapp,work( p ), m, 1,work( n+& 1 ), lda, ierr ) - aapq = stdlib_qdot( m, work( n+1 ), 1,a( 1, q ), 1 )*work( & + aapq = stdlib_${ri}$dot( m, work( n+1 ), 1,a( 1, q ), 1 )*work( & q ) / aaqq end if else @@ -14908,13 +14909,13 @@ module stdlib_linalg_lapack_q rotok = aaqq<=( aapp / small ) end if if( aapp>( small / aaqq ) ) then - aapq = ( stdlib_qdot( m, a( 1, p ), 1, a( 1,q ), 1 )*work( & + aapq = ( stdlib_${ri}$dot( m, a( 1, p ), 1, a( 1,q ), 1 )*work( & p )*work( q ) /aaqq ) / aapp else - call stdlib_qcopy( m, a( 1, q ), 1,work( n+1 ), 1 ) - call stdlib_qlascl( 'G', 0, 0, aaqq,work( q ), m, 1,work( n+& + call stdlib_${ri}$copy( m, a( 1, q ), 1,work( n+1 ), 1 ) + call stdlib_${ri}$lascl( 'G', 0, 0, aaqq,work( q ), m, 1,work( n+& 1 ), lda, ierr ) - aapq = stdlib_qdot( m, work( n+1 ), 1,a( 1, p ), 1 )*work( & + aapq = stdlib_${ri}$dot( m, work( n+1 ), 1,a( 1, p ), 1 )*work( & p ) / aapp end if end if @@ -14934,9 +14935,9 @@ module stdlib_linalg_lapack_q t = half / theta fastr( 3 ) = t*work( p ) / work( q ) fastr( 4 ) = -t*work( q ) /work( p ) - call stdlib_qrotm( m, a( 1, p ), 1,a( 1, q ), 1, fastr ) + call stdlib_${ri}$rotm( m, a( 1, p ), 1,a( 1, q ), 1, fastr ) - if( rsvec )call stdlib_qrotm( mvl,v( 1, p ), 1,v( 1, q ),& + if( rsvec )call stdlib_${ri}$rotm( mvl,v( 1, p ), 1,v( 1, q ),& 1,fastr ) sva( q ) = aaqq*sqrt( max( zero,one+t*apoaq*aapq ) ) @@ -14962,19 +14963,19 @@ module stdlib_linalg_lapack_q fastr( 4 ) = -t*aqoap work( p ) = work( p )*cs work( q ) = work( q )*cs - call stdlib_qrotm( m, a( 1, p ), 1,a( 1, q ), 1,& + call stdlib_${ri}$rotm( m, a( 1, p ), 1,a( 1, q ), 1,& fastr ) - if( rsvec )call stdlib_qrotm( mvl,v( 1, p ), 1, v( & + if( rsvec )call stdlib_${ri}$rotm( mvl,v( 1, p ), 1, v( & 1, q ),1, fastr ) else - call stdlib_qaxpy( m, -t*aqoap,a( 1, q ), 1,a( 1, & + call stdlib_${ri}$axpy( m, -t*aqoap,a( 1, q ), 1,a( 1, & p ), 1 ) - call stdlib_qaxpy( m, cs*sn*apoaq,a( 1, p ), 1,a( & + call stdlib_${ri}$axpy( m, cs*sn*apoaq,a( 1, p ), 1,a( & 1, q ), 1 ) if( rsvec ) then - call stdlib_qaxpy( mvl, -t*aqoap,v( 1, q ), 1,v(& + call stdlib_${ri}$axpy( mvl, -t*aqoap,v( 1, q ), 1,v(& 1, p ), 1 ) - call stdlib_qaxpy( mvl,cs*sn*apoaq,v( 1, p ), 1,& + call stdlib_${ri}$axpy( mvl,cs*sn*apoaq,v( 1, p ), 1,& v( 1, q ), 1 ) end if work( p ) = work( p )*cs @@ -14982,43 +14983,43 @@ module stdlib_linalg_lapack_q end if else if( work( q )>=one ) then - call stdlib_qaxpy( m, t*apoaq,a( 1, p ), 1,a( 1, q & + call stdlib_${ri}$axpy( m, t*apoaq,a( 1, p ), 1,a( 1, q & ), 1 ) - call stdlib_qaxpy( m, -cs*sn*aqoap,a( 1, q ), 1,a( & + call stdlib_${ri}$axpy( m, -cs*sn*aqoap,a( 1, q ), 1,a( & 1, p ), 1 ) if( rsvec ) then - call stdlib_qaxpy( mvl, t*apoaq,v( 1, p ), 1,v( & + call stdlib_${ri}$axpy( mvl, t*apoaq,v( 1, p ), 1,v( & 1, q ), 1 ) - call stdlib_qaxpy( mvl,-cs*sn*aqoap,v( 1, q ), & + call stdlib_${ri}$axpy( mvl,-cs*sn*aqoap,v( 1, q ), & 1,v( 1, p ), 1 ) end if work( p ) = work( p ) / cs work( q ) = work( q )*cs else if( work( p )>=work( q ) )then - call stdlib_qaxpy( m, -t*aqoap,a( 1, q ), 1,a( & + call stdlib_${ri}$axpy( m, -t*aqoap,a( 1, q ), 1,a( & 1, p ), 1 ) - call stdlib_qaxpy( m, cs*sn*apoaq,a( 1, p ), 1,& + call stdlib_${ri}$axpy( m, cs*sn*apoaq,a( 1, p ), 1,& a( 1, q ), 1 ) work( p ) = work( p )*cs work( q ) = work( q ) / cs if( rsvec ) then - call stdlib_qaxpy( mvl,-t*aqoap,v( 1, q ), 1,& + call stdlib_${ri}$axpy( mvl,-t*aqoap,v( 1, q ), 1,& v( 1, p ), 1 ) - call stdlib_qaxpy( mvl,cs*sn*apoaq,v( 1, p ),& + call stdlib_${ri}$axpy( mvl,cs*sn*apoaq,v( 1, p ),& 1,v( 1, q ), 1 ) end if else - call stdlib_qaxpy( m, t*apoaq,a( 1, p ), 1,a( 1,& + call stdlib_${ri}$axpy( m, t*apoaq,a( 1, p ), 1,a( 1,& q ), 1 ) - call stdlib_qaxpy( m,-cs*sn*aqoap,a( 1, q ), 1,& + call stdlib_${ri}$axpy( m,-cs*sn*aqoap,a( 1, q ), 1,& a( 1, p ), 1 ) work( p ) = work( p ) / cs work( q ) = work( q )*cs if( rsvec ) then - call stdlib_qaxpy( mvl,t*apoaq, v( 1, p ),1, & + call stdlib_${ri}$axpy( mvl,t*apoaq, v( 1, p ),1, & v( 1, q ), 1 ) - call stdlib_qaxpy( mvl,-cs*sn*aqoap,v( 1, q )& + call stdlib_${ri}$axpy( mvl,-cs*sn*aqoap,v( 1, q )& , 1,v( 1, p ), 1 ) end if end if @@ -15027,30 +15028,30 @@ module stdlib_linalg_lapack_q end if else if( aapp>aaqq ) then - call stdlib_qcopy( m, a( 1, p ), 1,work( n+1 ), 1 ) + call stdlib_${ri}$copy( m, a( 1, p ), 1,work( n+1 ), 1 ) - call stdlib_qlascl( 'G', 0, 0, aapp, one,m, 1, work( n+1 & + call stdlib_${ri}$lascl( 'G', 0, 0, aapp, one,m, 1, work( n+1 & ), lda,ierr ) - call stdlib_qlascl( 'G', 0, 0, aaqq, one,m, 1, a( 1, q ),& + call stdlib_${ri}$lascl( 'G', 0, 0, aaqq, one,m, 1, a( 1, q ),& lda,ierr ) temp1 = -aapq*work( p ) / work( q ) - call stdlib_qaxpy( m, temp1, work( n+1 ),1, a( 1, q ), 1 & + call stdlib_${ri}$axpy( m, temp1, work( n+1 ),1, a( 1, q ), 1 & ) - call stdlib_qlascl( 'G', 0, 0, one, aaqq,m, 1, a( 1, q ),& + call stdlib_${ri}$lascl( 'G', 0, 0, one, aaqq,m, 1, a( 1, q ),& lda,ierr ) sva( q ) = aaqq*sqrt( max( zero,one-aapq*aapq ) ) mxsinj = max( mxsinj, sfmin ) else - call stdlib_qcopy( m, a( 1, q ), 1,work( n+1 ), 1 ) + call stdlib_${ri}$copy( m, a( 1, q ), 1,work( n+1 ), 1 ) - call stdlib_qlascl( 'G', 0, 0, aaqq, one,m, 1, work( n+1 & + call stdlib_${ri}$lascl( 'G', 0, 0, aaqq, one,m, 1, work( n+1 & ), lda,ierr ) - call stdlib_qlascl( 'G', 0, 0, aapp, one,m, 1, a( 1, p ),& + call stdlib_${ri}$lascl( 'G', 0, 0, aapp, one,m, 1, a( 1, p ),& lda,ierr ) temp1 = -aapq*work( q ) / work( p ) - call stdlib_qaxpy( m, temp1, work( n+1 ),1, a( 1, p ), 1 & + call stdlib_${ri}$axpy( m, temp1, work( n+1 ),1, a( 1, p ), 1 & ) - call stdlib_qlascl( 'G', 0, 0, one, aapp,m, 1, a( 1, p ),& + call stdlib_${ri}$lascl( 'G', 0, 0, one, aapp,m, 1, a( 1, p ),& lda,ierr ) sva( p ) = aapp*sqrt( max( zero,one-aapq*aapq ) ) mxsinj = max( mxsinj, sfmin ) @@ -15061,22 +15062,22 @@ module stdlib_linalg_lapack_q ! .. recompute sva(q) if( ( sva( q ) / aaqq )**2<=rooteps )then if( ( aaqqrootsfmin ) ) then - sva( q ) = stdlib_qnrm2( m, a( 1, q ), 1 )*work( q ) + sva( q ) = stdlib_${ri}$nrm2( m, a( 1, q ), 1 )*work( q ) else t = zero aaqq = one - call stdlib_qlassq( m, a( 1, q ), 1, t,aaqq ) + call stdlib_${ri}$lassq( m, a( 1, q ), 1, t,aaqq ) sva( q ) = t*sqrt( aaqq )*work( q ) end if end if if( ( aapp / aapp0 )**2<=rooteps ) then if( ( aapprootsfmin ) ) then - aapp = stdlib_qnrm2( m, a( 1, p ), 1 )*work( p ) + aapp = stdlib_${ri}$nrm2( m, a( 1, p ), 1 )*work( p ) else t = zero aapp = one - call stdlib_qlassq( m, a( 1, p ), 1, t,aapp ) + call stdlib_${ri}$lassq( m, a( 1, p ), 1, t,aapp ) aapp = t*sqrt( aapp )*work( p ) end if sva( p ) = aapp @@ -15125,17 +15126,17 @@ module stdlib_linalg_lapack_q ! 2000 :: end of the ibr-loop ! .. update sva(n) if( ( sva( n )rootsfmin ) )then - sva( n ) = stdlib_qnrm2( m, a( 1, n ), 1 )*work( n ) + sva( n ) = stdlib_${ri}$nrm2( m, a( 1, n ), 1 )*work( n ) else t = zero aapp = one - call stdlib_qlassq( m, a( 1, n ), 1, t, aapp ) + call stdlib_${ri}$lassq( m, a( 1, n ), 1, t, aapp ) sva( n ) = t*sqrt( aapp )*work( n ) end if ! additional steering devices if( ( iswband+1 ) .and. ( mxaapqswband+1 ) .and. ( mxaapq=emptsw )go to 1994 @@ -15155,7 +15156,7 @@ module stdlib_linalg_lapack_q n2 = 0 n4 = 0 do p = 1, n - 1 - q = stdlib_iqamax( n-p+1, sva( p ), 1 ) + p - 1 + q = stdlib_i${ri}$amax( n-p+1, sva( p ), 1 ) + p - 1 if( p/=q ) then temp1 = sva( p ) sva( p ) = sva( q ) @@ -15163,8 +15164,8 @@ module stdlib_linalg_lapack_q temp1 = work( p ) work( p ) = work( q ) work( q ) = temp1 - call stdlib_qswap( m, a( 1, p ), 1, a( 1, q ), 1 ) - if( rsvec )call stdlib_qswap( mvl, v( 1, p ), 1, v( 1, q ), 1 ) + call stdlib_${ri}$swap( m, a( 1, p ), 1, a( 1, q ), 1 ) + if( rsvec )call stdlib_${ri}$swap( mvl, v( 1, p ), 1, v( 1, q ), 1 ) end if if( sva( p )/=zero ) then n4 = n4 + 1 @@ -15178,19 +15179,19 @@ module stdlib_linalg_lapack_q ! normalize the left singular vectors. if( lsvec .or. uctol ) then do p = 1, n2 - call stdlib_qscal( m, work( p ) / sva( p ), a( 1, p ), 1 ) + call stdlib_${ri}$scal( m, work( p ) / sva( p ), a( 1, p ), 1 ) end do end if ! scale the product of jacobi rotations (assemble the fast rotations). if( rsvec ) then if( applv ) then do p = 1, n - call stdlib_qscal( mvl, work( p ), v( 1, p ), 1 ) + call stdlib_${ri}$scal( mvl, work( p ), v( 1, p ), 1 ) end do else do p = 1, n - temp1 = one / stdlib_qnrm2( mvl, v( 1, p ), 1 ) - call stdlib_qscal( mvl, temp1, v( 1, p ), 1 ) + temp1 = one / stdlib_${ri}$nrm2( mvl, v( 1, p ), 1 ) + call stdlib_${ri}$scal( mvl, temp1, v( 1, p ), 1 ) end do end if end if @@ -15206,13 +15207,13 @@ module stdlib_linalg_lapack_q ! the singular values of a are skl*sva(1:n). if skl/=one ! then some of the singular values may overflow or underflow and ! the spectrum is given in this factored representation. - work( 2 ) = real( n4,KIND=qp) + work( 2 ) = real( n4,KIND=${rk}$) ! n4 is the number of computed nonzero singular values of a. - work( 3 ) = real( n2,KIND=qp) + work( 3 ) = real( n2,KIND=${rk}$) ! n2 is the number of singular values of a greater than sfmin. ! if n20 ) then ! compute the reciprocal pivot growth factor of the ! leading rank-deficient info columns of a. - rpvgrw = stdlib_qlantr( 'M', 'U', 'N', info, info, af, ldaf,work ) + rpvgrw = stdlib_${ri}$lantr( 'M', 'U', 'N', info, info, af, ldaf,work ) if( rpvgrw==zero ) then rpvgrw = one else - rpvgrw = stdlib_qlange( 'M', n, info, a, lda, work ) / rpvgrw + rpvgrw = stdlib_${ri}$lange( 'M', n, info, a, lda, work ) / rpvgrw end if work( 1 ) = rpvgrw rcond = zero @@ -15382,21 +15383,21 @@ module stdlib_linalg_lapack_q else norm = 'I' end if - anorm = stdlib_qlange( norm, n, n, a, lda, work ) - rpvgrw = stdlib_qlantr( 'M', 'U', 'N', n, n, af, ldaf, work ) + anorm = stdlib_${ri}$lange( norm, n, n, a, lda, work ) + rpvgrw = stdlib_${ri}$lantr( 'M', 'U', 'N', n, n, af, ldaf, work ) if( rpvgrw==zero ) then rpvgrw = one else - rpvgrw = stdlib_qlange( 'M', n, n, a, lda, work ) / rpvgrw + rpvgrw = stdlib_${ri}$lange( 'M', n, n, a, lda, work ) / rpvgrw end if ! compute the reciprocal of the condition number of a. - call stdlib_qgecon( norm, n, af, ldaf, anorm, rcond, work, iwork, info ) + call stdlib_${ri}$gecon( norm, n, af, ldaf, anorm, rcond, work, iwork, info ) ! compute the solution matrix x. - call stdlib_qlacpy( 'FULL', n, nrhs, b, ldb, x, ldx ) - call stdlib_qgetrs( trans, n, nrhs, af, ldaf, ipiv, x, ldx, info ) + call stdlib_${ri}$lacpy( 'FULL', n, nrhs, b, ldb, x, ldx ) + call stdlib_${ri}$getrs( trans, n, nrhs, af, ldaf, ipiv, x, ldx, info ) ! use iterative refinement to improve the computed solution and ! compute error bounds and backward error estimates for it. - call stdlib_qgerfs( trans, n, nrhs, a, lda, af, ldaf, ipiv, b, ldb, x,ldx, ferr, berr, & + call stdlib_${ri}$gerfs( trans, n, nrhs, a, lda, af, ldaf, ipiv, b, ldb, x,ldx, ferr, berr, & work, iwork, info ) ! transform the solution matrix x to a solution of the original ! system. @@ -15423,12 +15424,12 @@ module stdlib_linalg_lapack_q end if work( 1 ) = rpvgrw ! set info = n+1 if the matrix is singular to working precision. - if( rcond= sfmin ) then - call stdlib_qscal( m-j, one / a( j, j ), a( j+1, j ), 1 ) + call stdlib_${ri}$scal( m-j, one / a( j, j ), a( j+1, j ), 1 ) else do i = 1, m-j a( j+i, j ) = a( j+i, j ) / a( j, j ) @@ -15577,15 +15578,15 @@ module stdlib_linalg_lapack_q end if if( j=min( m, n ) ) then ! use unblocked code. - call stdlib_qgetrf2( m, n, a, lda, ipiv, info ) + call stdlib_${ri}$getrf2( m, n, a, lda, ipiv, info ) else ! use blocked code. do j = 1, min( m, n ), nb jb = min( min( m, n )-j+1, nb ) ! factor diagonal and subdiagonal blocks and test for exact ! singularity. - call stdlib_qgetrf2( m-j+1, jb, a( j, j ), lda, ipiv( j ), iinfo ) + call stdlib_${ri}$getrf2( m-j+1, jb, a( j, j ), lda, ipiv( j ), iinfo ) ! adjust info and the pivot indices. if( info==0 .and. iinfo>0 )info = iinfo + j - 1 do i = j, min( m, j+jb-1 ) ipiv( i ) = j - 1 + ipiv( i ) end do ! apply interchanges to columns 1:j-1. - call stdlib_qlaswp( j-1, a, lda, j, j+jb-1, ipiv, 1 ) + call stdlib_${ri}$laswp( j-1, a, lda, j, j+jb-1, ipiv, 1 ) if( j+jb<=n ) then ! apply interchanges to columns j+jb:n. - call stdlib_qlaswp( n-j-jb+1, a( 1, j+jb ), lda, j, j+jb-1,ipiv, 1 ) + call stdlib_${ri}$laswp( n-j-jb+1, a( 1, j+jb ), lda, j, j+jb-1,ipiv, 1 ) ! compute block row of u. - call stdlib_qtrsm( 'LEFT', 'LOWER', 'NO TRANSPOSE', 'UNIT', jb,n-j-jb+1, one, & + call stdlib_${ri}$trsm( 'LEFT', 'LOWER', 'NO TRANSPOSE', 'UNIT', jb,n-j-jb+1, one, & a( j, j ), lda, a( j, j+jb ),lda ) if( j+jb<=m ) then ! update trailing submatrix. - call stdlib_qgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', m-j-jb+1,n-j-jb+1, jb, -& + call stdlib_${ri}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', m-j-jb+1,n-j-jb+1, jb, -& one, a( j+jb, j ), lda,a( j, j+jb ), lda, one, a( j+jb, j+jb ),lda ) end if @@ -15660,10 +15661,10 @@ module stdlib_linalg_lapack_q end do end if return - end subroutine stdlib_qgetrf + end subroutine stdlib_${ri}$getrf - pure recursive subroutine stdlib_qgetrf2( m, n, a, lda, ipiv, info ) + pure recursive subroutine stdlib_${ri}$getrf2( m, n, a, lda, ipiv, info ) !! DGETRF2: computes an LU factorization of a general M-by-N matrix A !! using partial pivoting with row interchanges. !! The factorization has the form @@ -15691,11 +15692,11 @@ module stdlib_linalg_lapack_q integer(ilp), intent(in) :: lda, m, n ! Array Arguments integer(ilp), intent(out) :: ipiv(*) - real(qp), intent(inout) :: a(lda,*) + real(${rk}$), intent(inout) :: a(lda,*) ! ===================================================================== ! Local Scalars - real(qp) :: sfmin, temp + real(${rk}$) :: sfmin, temp integer(ilp) :: i, iinfo, n1, n2 ! Intrinsic Functions intrinsic :: max,min @@ -15723,9 +15724,9 @@ module stdlib_linalg_lapack_q else if( n==1 ) then ! use unblocked code for one column case ! compute machine safe minimum - sfmin = stdlib_qlamch('S') + sfmin = stdlib_${ri}$lamch('S') ! find pivot and test for singularity - i = stdlib_iqamax( m, a( 1, 1 ), 1 ) + i = stdlib_i${ri}$amax( m, a( 1, 1 ), 1 ) ipiv( 1 ) = i if( a( i, 1 )/=zero ) then ! apply the interchange @@ -15736,7 +15737,7 @@ module stdlib_linalg_lapack_q end if ! compute elements 2:m of the column if( abs(a( 1, 1 )) >= sfmin ) then - call stdlib_qscal( m-1, one / a( 1, 1 ), a( 2, 1 ), 1 ) + call stdlib_${ri}$scal( m-1, one / a( 1, 1 ), a( 2, 1 ), 1 ) else do i = 1, m-1 a( 1+i, 1 ) = a( 1+i, 1 ) / a( 1, 1 ) @@ -15752,33 +15753,33 @@ module stdlib_linalg_lapack_q ! [ a11 ] ! factor [ --- ] ! [ a21 ] - call stdlib_qgetrf2( m, n1, a, lda, ipiv, iinfo ) + call stdlib_${ri}$getrf2( m, n1, a, lda, ipiv, iinfo ) if ( info==0 .and. iinfo>0 )info = iinfo ! [ a12 ] ! apply interchanges to [ --- ] ! [ a22 ] - call stdlib_qlaswp( n2, a( 1, n1+1 ), lda, 1, n1, ipiv, 1 ) + call stdlib_${ri}$laswp( n2, a( 1, n1+1 ), lda, 1, n1, ipiv, 1 ) ! solve a12 - call stdlib_qtrsm( 'L', 'L', 'N', 'U', n1, n2, one, a, lda,a( 1, n1+1 ), lda ) + call stdlib_${ri}$trsm( 'L', 'L', 'N', 'U', n1, n2, one, a, lda,a( 1, n1+1 ), lda ) ! update a22 - call stdlib_qgemm( 'N', 'N', m-n1, n2, n1, -one, a( n1+1, 1 ), lda,a( 1, n1+1 ), & + call stdlib_${ri}$gemm( 'N', 'N', m-n1, n2, n1, -one, a( n1+1, 1 ), lda,a( 1, n1+1 ), & lda, one, a( n1+1, n1+1 ), lda ) ! factor a22 - call stdlib_qgetrf2( m-n1, n2, a( n1+1, n1+1 ), lda, ipiv( n1+1 ),iinfo ) + call stdlib_${ri}$getrf2( m-n1, n2, a( n1+1, n1+1 ), lda, ipiv( n1+1 ),iinfo ) ! adjust info and the pivot indices if ( info==0 .and. iinfo>0 )info = iinfo + n1 do i = n1+1, min( m, n ) ipiv( i ) = ipiv( i ) + n1 end do ! apply interchanges to a21 - call stdlib_qlaswp( n1, a( 1, 1 ), lda, n1+1, min( m, n), ipiv, 1 ) + call stdlib_${ri}$laswp( n1, a( 1, 1 ), lda, n1+1, min( m, n), ipiv, 1 ) end if return - end subroutine stdlib_qgetrf2 + end subroutine stdlib_${ri}$getrf2 - pure subroutine stdlib_qgetri( n, a, lda, ipiv, work, lwork, info ) + pure subroutine stdlib_${ri}$getri( n, a, lda, ipiv, work, lwork, info ) !! DGETRI: computes the inverse of a matrix using the LU factorization !! computed by DGETRF. !! This method inverts U and then computes inv(A) by solving the system @@ -15791,8 +15792,8 @@ module stdlib_linalg_lapack_q integer(ilp), intent(in) :: lda, lwork, n ! Array Arguments integer(ilp), intent(in) :: ipiv(*) - real(qp), intent(inout) :: a(lda,*) - real(qp), intent(out) :: work(*) + real(${rk}$), intent(inout) :: a(lda,*) + real(${rk}$), intent(out) :: work(*) ! ===================================================================== ! Local Scalars @@ -15822,9 +15823,9 @@ module stdlib_linalg_lapack_q end if ! quick return if possible if( n==0 )return - ! form inv(u). if info > 0 from stdlib_qtrtri, then u is singular, + ! form inv(u). if info > 0 from stdlib_${ri}$trtri, then u is singular, ! and the inverse is not computed. - call stdlib_qtrtri( 'UPPER', 'NON-UNIT', n, a, lda, info ) + call stdlib_${ri}$trtri( 'UPPER', 'NON-UNIT', n, a, lda, info ) if( info>0 )return nbmin = 2 ldwork = n @@ -15847,7 +15848,7 @@ module stdlib_linalg_lapack_q a( i, j ) = zero end do ! compute current column of inv(a). - if( j=n ) then - call stdlib_qgeqr( m, n, a, lda, tq, -1, workq, -1, info2 ) + call stdlib_${ri}$geqr( m, n, a, lda, tq, -1, workq, -1, info2 ) tszo = int( tq( 1 ),KIND=ilp) lwo = int( workq( 1 ),KIND=ilp) - call stdlib_qgemqr( 'L', trans, m, nrhs, n, a, lda, tq,tszo, b, ldb, workq, -1, & + call stdlib_${ri}$gemqr( 'L', trans, m, nrhs, n, a, lda, tq,tszo, b, ldb, workq, -1, & info2 ) lwo = max( lwo, int( workq( 1 ),KIND=ilp) ) - call stdlib_qgeqr( m, n, a, lda, tq, -2, workq, -2, info2 ) + call stdlib_${ri}$geqr( m, n, a, lda, tq, -2, workq, -2, info2 ) tszm = int( tq( 1 ),KIND=ilp) lwm = int( workq( 1 ),KIND=ilp) - call stdlib_qgemqr( 'L', trans, m, nrhs, n, a, lda, tq,tszm, b, ldb, workq, -1, & + call stdlib_${ri}$gemqr( 'L', trans, m, nrhs, n, a, lda, tq,tszm, b, ldb, workq, -1, & info2 ) lwm = max( lwm, int( workq( 1 ),KIND=ilp) ) wsizeo = tszo + lwo wsizem = tszm + lwm else - call stdlib_qgelq( m, n, a, lda, tq, -1, workq, -1, info2 ) + call stdlib_${ri}$gelq( m, n, a, lda, tq, -1, workq, -1, info2 ) tszo = int( tq( 1 ),KIND=ilp) lwo = int( workq( 1 ),KIND=ilp) - call stdlib_qgemlq( 'L', trans, n, nrhs, m, a, lda, tq,tszo, b, ldb, workq, -1, & + call stdlib_${ri}$gemlq( 'L', trans, n, nrhs, m, a, lda, tq,tszo, b, ldb, workq, -1, & info2 ) lwo = max( lwo, int( workq( 1 ),KIND=ilp) ) - call stdlib_qgelq( m, n, a, lda, tq, -2, workq, -2, info2 ) + call stdlib_${ri}$gelq( m, n, a, lda, tq, -2, workq, -2, info2 ) tszm = int( tq( 1 ),KIND=ilp) lwm = int( workq( 1 ),KIND=ilp) - call stdlib_qgemlq( 'L', trans, n, nrhs, m, a, lda, tq,tszm, b, ldb, workq, -1, & + call stdlib_${ri}$gemlq( 'L', trans, n, nrhs, m, a, lda, tq,tszm, b, ldb, workq, -1, & info2 ) lwm = max( lwm, int( workq( 1 ),KIND=ilp) ) wsizeo = tszo + lwo @@ -16042,14 +16043,14 @@ module stdlib_linalg_lapack_q if( ( lworkzero .and. anrmbignum ) then ! scale matrix norm down to bignum - call stdlib_qlascl( 'G', 0, 0, anrm, bignum, m, n, a, lda, info ) + call stdlib_${ri}$lascl( 'G', 0, 0, anrm, bignum, m, n, a, lda, info ) iascl = 2 else if( anrm==zero ) then ! matrix all zero. return zero solution. - call stdlib_qlaset( 'F', maxmn, nrhs, zero, zero, b, ldb ) + call stdlib_${ri}$laset( 'F', maxmn, nrhs, zero, zero, b, ldb ) go to 50 end if brow = m if ( tran ) then brow = n end if - bnrm = stdlib_qlange( 'M', brow, nrhs, b, ldb, work ) + bnrm = stdlib_${ri}$lange( 'M', brow, nrhs, b, ldb, work ) ibscl = 0 if( bnrm>zero .and. bnrmbignum ) then ! scale matrix norm down to bignum - call stdlib_qlascl( 'G', 0, 0, bnrm, bignum, brow, nrhs, b, ldb,info ) + call stdlib_${ri}$lascl( 'G', 0, 0, bnrm, bignum, brow, nrhs, b, ldb,info ) ibscl = 2 end if if ( m>=n ) then ! compute qr factorization of a - call stdlib_qgeqr( m, n, a, lda, work( lw2+1 ), lw1,work( 1 ), lw2, info ) + call stdlib_${ri}$geqr( m, n, a, lda, work( lw2+1 ), lw1,work( 1 ), lw2, info ) if ( .not.tran ) then ! least-squares problem min || a * x - b || ! b(1:m,1:nrhs) := q**t * b(1:m,1:nrhs) - call stdlib_qgemqr( 'L' , 'T', m, nrhs, n, a, lda,work( lw2+1 ), lw1, b, ldb, work(& + call stdlib_${ri}$gemqr( 'L' , 'T', m, nrhs, n, a, lda,work( lw2+1 ), lw1, b, ldb, work(& 1 ), lw2,info ) ! b(1:n,1:nrhs) := inv(r) * b(1:n,1:nrhs) - call stdlib_qtrtrs( 'U', 'N', 'N', n, nrhs,a, lda, b, ldb, info ) + call stdlib_${ri}$trtrs( 'U', 'N', 'N', n, nrhs,a, lda, b, ldb, info ) if( info>0 ) then return end if @@ -16116,7 +16117,7 @@ module stdlib_linalg_lapack_q else ! overdetermined system of equations a**t * x = b ! b(1:n,1:nrhs) := inv(r**t) * b(1:n,1:nrhs) - call stdlib_qtrtrs( 'U', 'T', 'N', n, nrhs,a, lda, b, ldb, info ) + call stdlib_${ri}$trtrs( 'U', 'T', 'N', n, nrhs,a, lda, b, ldb, info ) if( info>0 ) then return end if @@ -16127,18 +16128,18 @@ module stdlib_linalg_lapack_q end do end do ! b(1:m,1:nrhs) := q(1:n,:) * b(1:n,1:nrhs) - call stdlib_qgemqr( 'L', 'N', m, nrhs, n, a, lda,work( lw2+1 ), lw1, b, ldb, & + call stdlib_${ri}$gemqr( 'L', 'N', m, nrhs, n, a, lda,work( lw2+1 ), lw1, b, ldb, & work( 1 ), lw2,info ) scllen = m end if else ! compute lq factorization of a - call stdlib_qgelq( m, n, a, lda, work( lw2+1 ), lw1,work( 1 ), lw2, info ) + call stdlib_${ri}$gelq( m, n, a, lda, work( lw2+1 ), lw1,work( 1 ), lw2, info ) ! workspace at least m, optimally m*nb. if( .not.tran ) then ! underdetermined system of equations a * x = b ! b(1:m,1:nrhs) := inv(l) * b(1:m,1:nrhs) - call stdlib_qtrtrs( 'L', 'N', 'N', m, nrhs,a, lda, b, ldb, info ) + call stdlib_${ri}$trtrs( 'L', 'N', 'N', m, nrhs,a, lda, b, ldb, info ) if( info>0 ) then return end if @@ -16149,18 +16150,18 @@ module stdlib_linalg_lapack_q end do end do ! b(1:n,1:nrhs) := q(1:n,:)**t * b(1:m,1:nrhs) - call stdlib_qgemlq( 'L', 'T', n, nrhs, m, a, lda,work( lw2+1 ), lw1, b, ldb, & + call stdlib_${ri}$gemlq( 'L', 'T', n, nrhs, m, a, lda,work( lw2+1 ), lw1, b, ldb, & work( 1 ), lw2,info ) ! workspace at least nrhs, optimally nrhs*nb scllen = n else ! overdetermined system min || a**t * x - b || ! b(1:n,1:nrhs) := q * b(1:n,1:nrhs) - call stdlib_qgemlq( 'L', 'N', n, nrhs, m, a, lda,work( lw2+1 ), lw1, b, ldb, & + call stdlib_${ri}$gemlq( 'L', 'N', n, nrhs, m, a, lda,work( lw2+1 ), lw1, b, ldb, & work( 1 ), lw2,info ) ! workspace at least nrhs, optimally nrhs*nb ! b(1:m,1:nrhs) := inv(l**t) * b(1:m,1:nrhs) - call stdlib_qtrtrs( 'LOWER', 'TRANSPOSE', 'NON-UNIT', m, nrhs,a, lda, b, ldb, & + call stdlib_${ri}$trtrs( 'LOWER', 'TRANSPOSE', 'NON-UNIT', m, nrhs,a, lda, b, ldb, & info ) if( info>0 ) then return @@ -16170,22 +16171,22 @@ module stdlib_linalg_lapack_q end if ! undo scaling if( iascl==1 ) then - call stdlib_qlascl( 'G', 0, 0, anrm, smlnum, scllen, nrhs, b, ldb,info ) + call stdlib_${ri}$lascl( 'G', 0, 0, anrm, smlnum, scllen, nrhs, b, ldb,info ) else if( iascl==2 ) then - call stdlib_qlascl( 'G', 0, 0, anrm, bignum, scllen, nrhs, b, ldb,info ) + call stdlib_${ri}$lascl( 'G', 0, 0, anrm, bignum, scllen, nrhs, b, ldb,info ) end if if( ibscl==1 ) then - call stdlib_qlascl( 'G', 0, 0, smlnum, bnrm, scllen, nrhs, b, ldb,info ) + call stdlib_${ri}$lascl( 'G', 0, 0, smlnum, bnrm, scllen, nrhs, b, ldb,info ) else if( ibscl==2 ) then - call stdlib_qlascl( 'G', 0, 0, bignum, bnrm, scllen, nrhs, b, ldb,info ) + call stdlib_${ri}$lascl( 'G', 0, 0, bignum, bnrm, scllen, nrhs, b, ldb,info ) end if 50 continue - work( 1 ) = real( tszo + lwo,KIND=qp) + work( 1 ) = real( tszo + lwo,KIND=${rk}$) return - end subroutine stdlib_qgetsls + end subroutine stdlib_${ri}$getsls - pure subroutine stdlib_qgetsqrhrt( m, n, mb1, nb1, nb2, a, lda, t, ldt, work,lwork, info ) + pure subroutine stdlib_${ri}$getsqrhrt( m, n, mb1, nb1, nb2, a, lda, t, ldt, work,lwork, info ) !! DGETSQRHRT: computes a NB2-sized column blocked QR-factorization !! of a real M-by-N matrix A with M >= N, !! A = Q * R. @@ -16206,8 +16207,8 @@ module stdlib_linalg_lapack_q integer(ilp), intent(out) :: info integer(ilp), intent(in) :: lda, ldt, lwork, m, n, nb1, nb2, mb1 ! Array Arguments - real(qp), intent(inout) :: a(lda,*) - real(qp), intent(out) :: t(ldt,*), work(*) + real(${rk}$), intent(inout) :: a(lda,*) + real(${rk}$), intent(out) :: t(ldt,*), work(*) ! ===================================================================== ! Local Scalars @@ -16237,24 +16238,24 @@ module stdlib_linalg_lapack_q else ! test the input lwork for the dimension of the array work. ! this workspace is used to store array: - ! a) matrix t and work for stdlib_qlatsqr; + ! a) matrix t and work for stdlib_${ri}$latsqr; ! b) n-by-n upper-triangular factor r_tsqr; - ! c) matrix t and array work for stdlib_qorgtsqr_row; - ! d) diagonal d for stdlib_qorhr_col. + ! c) matrix t and array work for stdlib_${ri}$orgtsqr_row; + ! d) diagonal d for stdlib_${ri}$orhr_col. if( lworkzero .and. anrmzero .and. bnrm1 ) then - call stdlib_qlacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,vsl( ilo+1, ilo )& + call stdlib_${ri}$lacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,vsl( ilo+1, ilo )& , ldvsl ) end if - call stdlib_qorgqr( irows, irows, irows, vsl( ilo, ilo ), ldvsl,work( itau ), work( & + call stdlib_${ri}$orgqr( irows, irows, irows, vsl( ilo, ilo ), ldvsl,work( itau ), work( & iwrk ), lwork+1-iwrk, ierr ) end if ! initialize vsr - if( ilvsr )call stdlib_qlaset( 'FULL', n, n, zero, one, vsr, ldvsr ) + if( ilvsr )call stdlib_${ri}$laset( 'FULL', n, n, zero, one, vsr, ldvsr ) ! reduce to generalized hessenberg form ! (workspace: none needed) - call stdlib_qgghrd( jobvsl, jobvsr, n, ilo, ihi, a, lda, b, ldb, vsl,ldvsl, vsr, ldvsr,& + call stdlib_${ri}$gghrd( jobvsl, jobvsr, n, ilo, ihi, a, lda, b, ldb, vsl,ldvsl, vsr, ldvsr,& ierr ) ! perform qz algorithm, computing schur vectors if desired ! (workspace: need n) iwrk = itau - call stdlib_qhgeqz( 'S', jobvsl, jobvsr, n, ilo, ihi, a, lda, b, ldb,alphar, alphai, & + call stdlib_${ri}$hgeqz( 'S', jobvsl, jobvsr, n, ilo, ihi, a, lda, b, ldb,alphar, alphai, & beta, vsl, ldvsl, vsr, ldvsr,work( iwrk ), lwork+1-iwrk, ierr ) if( ierr/=0 ) then if( ierr>0 .and. ierr<=n ) then @@ -16944,25 +16945,25 @@ module stdlib_linalg_lapack_q if( wantst ) then ! undo scaling on eigenvalues before selctging if( ilascl ) then - call stdlib_qlascl( 'G', 0, 0, anrmto, anrm, n, 1, alphar, n,ierr ) - call stdlib_qlascl( 'G', 0, 0, anrmto, anrm, n, 1, alphai, n,ierr ) + call stdlib_${ri}$lascl( 'G', 0, 0, anrmto, anrm, n, 1, alphar, n,ierr ) + call stdlib_${ri}$lascl( 'G', 0, 0, anrmto, anrm, n, 1, alphai, n,ierr ) end if - if( ilbscl )call stdlib_qlascl( 'G', 0, 0, bnrmto, bnrm, n, 1, beta, n, ierr ) + if( ilbscl )call stdlib_${ri}$lascl( 'G', 0, 0, bnrmto, bnrm, n, 1, beta, n, ierr ) ! select eigenvalues do i = 1, n bwork( i ) = selctg( alphar( i ), alphai( i ), beta( i ) ) end do - call stdlib_qtgsen( 0, ilvsl, ilvsr, bwork, n, a, lda, b, ldb, alphar,alphai, beta, & + call stdlib_${ri}$tgsen( 0, ilvsl, ilvsr, bwork, n, a, lda, b, ldb, alphar,alphai, beta, & vsl, ldvsl, vsr, ldvsr, sdim, pvsl,pvsr, dif, work( iwrk ), lwork-iwrk+1, idum, 1,& ierr ) if( ierr==1 )info = n + 3 end if ! apply back-permutation to vsl and vsr ! (workspace: none needed) - if( ilvsl )call stdlib_qggbak( 'P', 'L', n, ilo, ihi, work( ileft ),work( iright ), n, & + if( ilvsl )call stdlib_${ri}$ggbak( 'P', 'L', n, ilo, ihi, work( ileft ),work( iright ), n, & vsl, ldvsl, ierr ) - if( ilvsr )call stdlib_qggbak( 'P', 'R', n, ilo, ihi, work( ileft ),work( iright ), n, & + if( ilvsr )call stdlib_${ri}$ggbak( 'P', 'R', n, ilo, ihi, work( ileft ),work( iright ), n, & vsr, ldvsr, ierr ) ! check if unscaling would cause over/underflow, if so, rescale ! (alphar(i),alphai(i),beta(i)) so beta(i) is on the order of @@ -17001,13 +17002,13 @@ module stdlib_linalg_lapack_q end if ! undo scaling if( ilascl ) then - call stdlib_qlascl( 'H', 0, 0, anrmto, anrm, n, n, a, lda, ierr ) - call stdlib_qlascl( 'G', 0, 0, anrmto, anrm, n, 1, alphar, n, ierr ) - call stdlib_qlascl( 'G', 0, 0, anrmto, anrm, n, 1, alphai, n, ierr ) + call stdlib_${ri}$lascl( 'H', 0, 0, anrmto, anrm, n, n, a, lda, ierr ) + call stdlib_${ri}$lascl( 'G', 0, 0, anrmto, anrm, n, 1, alphar, n, ierr ) + call stdlib_${ri}$lascl( 'G', 0, 0, anrmto, anrm, n, 1, alphai, n, ierr ) end if if( ilbscl ) then - call stdlib_qlascl( 'U', 0, 0, bnrmto, bnrm, n, n, b, ldb, ierr ) - call stdlib_qlascl( 'G', 0, 0, bnrmto, bnrm, n, 1, beta, n, ierr ) + call stdlib_${ri}$lascl( 'U', 0, 0, bnrmto, bnrm, n, n, b, ldb, ierr ) + call stdlib_${ri}$lascl( 'G', 0, 0, bnrmto, bnrm, n, 1, beta, n, ierr ) end if if( wantst ) then ! check if reordering is correct @@ -17041,10 +17042,10 @@ module stdlib_linalg_lapack_q 50 continue work( 1 ) = maxwrk return - end subroutine stdlib_qgges + end subroutine stdlib_${ri}$gges - subroutine stdlib_qgges3( jobvsl, jobvsr, sort, selctg, n, a, lda, b,ldb, sdim, alphar, & + subroutine stdlib_${ri}$gges3( jobvsl, jobvsr, sort, selctg, n, a, lda, b,ldb, sdim, alphar, & !! DGGES3: computes for a pair of N-by-N real nonsymmetric matrices (A,B), !! the generalized eigenvalues, the generalized real Schur form (S,T), !! optionally, the left and/or right matrices of Schur vectors (VSL and @@ -17081,11 +17082,11 @@ module stdlib_linalg_lapack_q integer(ilp), intent(in) :: lda, ldb, ldvsl, ldvsr, lwork, n ! Array Arguments logical(lk), intent(out) :: bwork(*) - real(qp), intent(inout) :: a(lda,*), b(ldb,*) - real(qp), intent(out) :: alphai(*), alphar(*), beta(*), vsl(ldvsl,*), vsr(ldvsr,*), & + real(${rk}$), intent(inout) :: a(lda,*), b(ldb,*) + real(${rk}$), intent(out) :: alphai(*), alphar(*), beta(*), vsl(ldvsl,*), vsr(ldvsr,*), & work(*) ! Function Arguments - procedure(stdlib_selctg_q) :: selctg + procedure(stdlib_selctg_${ri}$) :: selctg ! ===================================================================== ! Local Scalars @@ -17093,11 +17094,11 @@ module stdlib_linalg_lapack_q wantst integer(ilp) :: i, icols, ierr, ihi, ijobvl, ijobvr, ileft, ilo, ip, iright, irows, & itau, iwrk, lwkopt - real(qp) :: anrm, anrmto, bignum, bnrm, bnrmto, eps, pvsl, pvsr, safmax, safmin, & + real(${rk}$) :: anrm, anrmto, bignum, bnrm, bnrmto, eps, pvsl, pvsr, safmax, safmin, & smlnum ! Local Arrays integer(ilp) :: idum(1) - real(qp) :: dif(2) + real(${rk}$) :: dif(2) ! Intrinsic Functions intrinsic :: abs,max,sqrt ! Executable Statements @@ -17147,22 +17148,22 @@ module stdlib_linalg_lapack_q end if ! compute workspace if( info==0 ) then - call stdlib_qgeqrf( n, n, b, ldb, work, work, -1, ierr ) + call stdlib_${ri}$geqrf( n, n, b, ldb, work, work, -1, ierr ) lwkopt = max( 6*n+16, 3*n+int( work ( 1 ),KIND=ilp) ) - call stdlib_qormqr( 'L', 'T', n, n, n, b, ldb, work, a, lda, work,-1, ierr ) + call stdlib_${ri}$ormqr( 'L', 'T', n, n, n, b, ldb, work, a, lda, work,-1, ierr ) lwkopt = max( lwkopt, 3*n+int( work ( 1 ),KIND=ilp) ) if( ilvsl ) then - call stdlib_qorgqr( n, n, n, vsl, ldvsl, work, work, -1, ierr ) + call stdlib_${ri}$orgqr( n, n, n, vsl, ldvsl, work, work, -1, ierr ) lwkopt = max( lwkopt, 3*n+int( work ( 1 ),KIND=ilp) ) end if - call stdlib_qgghd3( jobvsl, jobvsr, n, 1, n, a, lda, b, ldb, vsl,ldvsl, vsr, ldvsr, & + call stdlib_${ri}$gghd3( jobvsl, jobvsr, n, 1, n, a, lda, b, ldb, vsl,ldvsl, vsr, ldvsr, & work, -1, ierr ) lwkopt = max( lwkopt, 3*n+int( work ( 1 ),KIND=ilp) ) - call stdlib_qlaqz0( 'S', jobvsl, jobvsr, n, 1, n, a, lda, b, ldb,alphar, alphai, & + call stdlib_${ri}$laqz0( 'S', jobvsl, jobvsr, n, 1, n, a, lda, b, ldb,alphar, alphai, & beta, vsl, ldvsl, vsr, ldvsr,work, -1, 0, ierr ) lwkopt = max( lwkopt, 2*n+int( work ( 1 ),KIND=ilp) ) if( wantst ) then - call stdlib_qtgsen( 0, ilvsl, ilvsr, bwork, n, a, lda, b, ldb,alphar, alphai, & + call stdlib_${ri}$tgsen( 0, ilvsl, ilvsr, bwork, n, a, lda, b, ldb,alphar, alphai, & beta, vsl, ldvsl, vsr, ldvsr,sdim, pvsl, pvsr, dif, work, -1, idum, 1,ierr ) lwkopt = max( lwkopt, 2*n+int( work ( 1 ),KIND=ilp) ) @@ -17181,14 +17182,14 @@ module stdlib_linalg_lapack_q return end if ! get machine constants - eps = stdlib_qlamch( 'P' ) - safmin = stdlib_qlamch( 'S' ) + eps = stdlib_${ri}$lamch( 'P' ) + safmin = stdlib_${ri}$lamch( 'S' ) safmax = one / safmin - call stdlib_qlabad( safmin, safmax ) + call stdlib_${ri}$labad( safmin, safmax ) smlnum = sqrt( safmin ) / eps bignum = one / smlnum ! scale a if max element outside range [smlnum,bignum] - anrm = stdlib_qlange( 'M', n, n, a, lda, work ) + anrm = stdlib_${ri}$lange( 'M', n, n, a, lda, work ) ilascl = .false. if( anrm>zero .and. anrmzero .and. bnrm1 ) then - call stdlib_qlacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,vsl( ilo+1, ilo )& + call stdlib_${ri}$lacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,vsl( ilo+1, ilo )& , ldvsl ) end if - call stdlib_qorgqr( irows, irows, irows, vsl( ilo, ilo ), ldvsl,work( itau ), work( & + call stdlib_${ri}$orgqr( irows, irows, irows, vsl( ilo, ilo ), ldvsl,work( itau ), work( & iwrk ), lwork+1-iwrk, ierr ) end if ! initialize vsr - if( ilvsr )call stdlib_qlaset( 'FULL', n, n, zero, one, vsr, ldvsr ) + if( ilvsr )call stdlib_${ri}$laset( 'FULL', n, n, zero, one, vsr, ldvsr ) ! reduce to generalized hessenberg form - call stdlib_qgghd3( jobvsl, jobvsr, n, ilo, ihi, a, lda, b, ldb, vsl,ldvsl, vsr, ldvsr,& + call stdlib_${ri}$gghd3( jobvsl, jobvsr, n, ilo, ihi, a, lda, b, ldb, vsl,ldvsl, vsr, ldvsr,& work( iwrk ), lwork+1-iwrk,ierr ) ! perform qz algorithm, computing schur vectors if desired iwrk = itau - call stdlib_qlaqz0( 'S', jobvsl, jobvsr, n, ilo, ihi, a, lda, b, ldb,alphar, alphai, & + call stdlib_${ri}$laqz0( 'S', jobvsl, jobvsr, n, ilo, ihi, a, lda, b, ldb,alphar, alphai, & beta, vsl, ldvsl, vsr, ldvsr,work( iwrk ), lwork+1-iwrk, 0, ierr ) if( ierr/=0 ) then if( ierr>0 .and. ierr<=n ) then @@ -17259,24 +17260,24 @@ module stdlib_linalg_lapack_q if( wantst ) then ! undo scaling on eigenvalues before selctging if( ilascl ) then - call stdlib_qlascl( 'G', 0, 0, anrmto, anrm, n, 1, alphar, n,ierr ) - call stdlib_qlascl( 'G', 0, 0, anrmto, anrm, n, 1, alphai, n,ierr ) + call stdlib_${ri}$lascl( 'G', 0, 0, anrmto, anrm, n, 1, alphar, n,ierr ) + call stdlib_${ri}$lascl( 'G', 0, 0, anrmto, anrm, n, 1, alphai, n,ierr ) end if - if( ilbscl )call stdlib_qlascl( 'G', 0, 0, bnrmto, bnrm, n, 1, beta, n, ierr ) + if( ilbscl )call stdlib_${ri}$lascl( 'G', 0, 0, bnrmto, bnrm, n, 1, beta, n, ierr ) ! select eigenvalues do i = 1, n bwork( i ) = selctg( alphar( i ), alphai( i ), beta( i ) ) end do - call stdlib_qtgsen( 0, ilvsl, ilvsr, bwork, n, a, lda, b, ldb, alphar,alphai, beta, & + call stdlib_${ri}$tgsen( 0, ilvsl, ilvsr, bwork, n, a, lda, b, ldb, alphar,alphai, beta, & vsl, ldvsl, vsr, ldvsr, sdim, pvsl,pvsr, dif, work( iwrk ), lwork-iwrk+1, idum, 1,& ierr ) if( ierr==1 )info = n + 3 end if ! apply back-permutation to vsl and vsr - if( ilvsl )call stdlib_qggbak( 'P', 'L', n, ilo, ihi, work( ileft ),work( iright ), n, & + if( ilvsl )call stdlib_${ri}$ggbak( 'P', 'L', n, ilo, ihi, work( ileft ),work( iright ), n, & vsl, ldvsl, ierr ) - if( ilvsr )call stdlib_qggbak( 'P', 'R', n, ilo, ihi, work( ileft ),work( iright ), n, & + if( ilvsr )call stdlib_${ri}$ggbak( 'P', 'R', n, ilo, ihi, work( ileft ),work( iright ), n, & vsr, ldvsr, ierr ) ! check if unscaling would cause over/underflow, if so, rescale ! (alphar(i),alphai(i),beta(i)) so beta(i) is on the order of @@ -17315,13 +17316,13 @@ module stdlib_linalg_lapack_q end if ! undo scaling if( ilascl ) then - call stdlib_qlascl( 'H', 0, 0, anrmto, anrm, n, n, a, lda, ierr ) - call stdlib_qlascl( 'G', 0, 0, anrmto, anrm, n, 1, alphar, n, ierr ) - call stdlib_qlascl( 'G', 0, 0, anrmto, anrm, n, 1, alphai, n, ierr ) + call stdlib_${ri}$lascl( 'H', 0, 0, anrmto, anrm, n, n, a, lda, ierr ) + call stdlib_${ri}$lascl( 'G', 0, 0, anrmto, anrm, n, 1, alphar, n, ierr ) + call stdlib_${ri}$lascl( 'G', 0, 0, anrmto, anrm, n, 1, alphai, n, ierr ) end if if( ilbscl ) then - call stdlib_qlascl( 'U', 0, 0, bnrmto, bnrm, n, n, b, ldb, ierr ) - call stdlib_qlascl( 'G', 0, 0, bnrmto, bnrm, n, 1, beta, n, ierr ) + call stdlib_${ri}$lascl( 'U', 0, 0, bnrmto, bnrm, n, n, b, ldb, ierr ) + call stdlib_${ri}$lascl( 'G', 0, 0, bnrmto, bnrm, n, 1, beta, n, ierr ) end if if( wantst ) then ! check if reordering is correct @@ -17355,10 +17356,10 @@ module stdlib_linalg_lapack_q 50 continue work( 1 ) = lwkopt return - end subroutine stdlib_qgges3 + end subroutine stdlib_${ri}$gges3 - subroutine stdlib_qggesx( jobvsl, jobvsr, sort, selctg, sense, n, a, lda,b, ldb, sdim, & + subroutine stdlib_${ri}$ggesx( jobvsl, jobvsr, sort, selctg, sense, n, a, lda,b, ldb, sdim, & !! DGGESX: computes for a pair of N-by-N real nonsymmetric matrices !! (A,B), the generalized eigenvalues, the real Schur form (S,T), and, !! optionally, the left and/or right matrices of Schur vectors (VSL and @@ -17399,11 +17400,11 @@ module stdlib_linalg_lapack_q ! Array Arguments logical(lk), intent(out) :: bwork(*) integer(ilp), intent(out) :: iwork(*) - real(qp), intent(inout) :: a(lda,*), b(ldb,*) - real(qp), intent(out) :: alphai(*), alphar(*), beta(*), rconde(2), rcondv(2), vsl(& + real(${rk}$), intent(inout) :: a(lda,*), b(ldb,*) + real(${rk}$), intent(out) :: alphai(*), alphar(*), beta(*), rconde(2), rcondv(2), vsl(& ldvsl,*), vsr(ldvsr,*), work(*) ! Function Arguments - procedure(stdlib_selctg_q) :: selctg + procedure(stdlib_selctg_${ri}$) :: selctg ! ===================================================================== ! Local Scalars @@ -17411,10 +17412,10 @@ module stdlib_linalg_lapack_q wantse, wantsn, wantst, wantsv integer(ilp) :: i, icols, ierr, ihi, ijob, ijobvl, ijobvr, ileft, ilo, ip, iright, & irows, itau, iwrk, liwmin, lwrk, maxwrk, minwrk - real(qp) :: anrm, anrmto, bignum, bnrm, bnrmto, eps, pl, pr, safmax, safmin, & + real(${rk}$) :: anrm, anrmto, bignum, bnrm, bnrmto, eps, pl, pr, safmax, safmin, & smlnum ! Local Arrays - real(qp) :: dif(2) + real(${rk}$) :: dif(2) ! Intrinsic Functions intrinsic :: abs,max,sqrt ! Executable Statements @@ -17524,14 +17525,14 @@ module stdlib_linalg_lapack_q return end if ! get machine constants - eps = stdlib_qlamch( 'P' ) - safmin = stdlib_qlamch( 'S' ) + eps = stdlib_${ri}$lamch( 'P' ) + safmin = stdlib_${ri}$lamch( 'S' ) safmax = one / safmin - call stdlib_qlabad( safmin, safmax ) + call stdlib_${ri}$labad( safmin, safmax ) smlnum = sqrt( safmin ) / eps bignum = one / smlnum ! scale a if max element outside range [smlnum,bignum] - anrm = stdlib_qlange( 'M', n, n, a, lda, work ) + anrm = stdlib_${ri}$lange( 'M', n, n, a, lda, work ) ilascl = .false. if( anrm>zero .and. anrmzero .and. bnrm1 ) then - call stdlib_qlacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,vsl( ilo+1, ilo )& + call stdlib_${ri}$lacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,vsl( ilo+1, ilo )& , ldvsl ) end if - call stdlib_qorgqr( irows, irows, irows, vsl( ilo, ilo ), ldvsl,work( itau ), work( & + call stdlib_${ri}$orgqr( irows, irows, irows, vsl( ilo, ilo ), ldvsl,work( itau ), work( & iwrk ), lwork+1-iwrk, ierr ) end if ! initialize vsr - if( ilvsr )call stdlib_qlaset( 'FULL', n, n, zero, one, vsr, ldvsr ) + if( ilvsr )call stdlib_${ri}$laset( 'FULL', n, n, zero, one, vsr, ldvsr ) ! reduce to generalized hessenberg form ! (workspace: none needed) - call stdlib_qgghrd( jobvsl, jobvsr, n, ilo, ihi, a, lda, b, ldb, vsl,ldvsl, vsr, ldvsr,& + call stdlib_${ri}$gghrd( jobvsl, jobvsr, n, ilo, ihi, a, lda, b, ldb, vsl,ldvsl, vsr, ldvsr,& ierr ) sdim = 0 ! perform qz algorithm, computing schur vectors if desired ! (workspace: need n) iwrk = itau - call stdlib_qhgeqz( 'S', jobvsl, jobvsr, n, ilo, ihi, a, lda, b, ldb,alphar, alphai, & + call stdlib_${ri}$hgeqz( 'S', jobvsl, jobvsr, n, ilo, ihi, a, lda, b, ldb,alphar, alphai, & beta, vsl, ldvsl, vsr, ldvsr,work( iwrk ), lwork+1-iwrk, ierr ) if( ierr/=0 ) then if( ierr>0 .and. ierr<=n ) then @@ -17611,10 +17612,10 @@ module stdlib_linalg_lapack_q if( wantst ) then ! undo scaling on eigenvalues before selctging if( ilascl ) then - call stdlib_qlascl( 'G', 0, 0, anrmto, anrm, n, 1, alphar, n,ierr ) - call stdlib_qlascl( 'G', 0, 0, anrmto, anrm, n, 1, alphai, n,ierr ) + call stdlib_${ri}$lascl( 'G', 0, 0, anrmto, anrm, n, 1, alphar, n,ierr ) + call stdlib_${ri}$lascl( 'G', 0, 0, anrmto, anrm, n, 1, alphai, n,ierr ) end if - if( ilbscl )call stdlib_qlascl( 'G', 0, 0, bnrmto, bnrm, n, 1, beta, n, ierr ) + if( ilbscl )call stdlib_${ri}$lascl( 'G', 0, 0, bnrmto, bnrm, n, 1, beta, n, ierr ) ! select eigenvalues do i = 1, n @@ -17622,7 +17623,7 @@ module stdlib_linalg_lapack_q end do ! reorder eigenvalues, transform generalized schur vectors, and ! compute reciprocal condition numbers - call stdlib_qtgsen( ijob, ilvsl, ilvsr, bwork, n, a, lda, b, ldb,alphar, alphai, & + call stdlib_${ri}$tgsen( ijob, ilvsl, ilvsr, bwork, n, a, lda, b, ldb,alphar, alphai, & beta, vsl, ldvsl, vsr, ldvsr,sdim, pl, pr, dif, work( iwrk ), lwork-iwrk+1,iwork, & liwork, ierr ) if( ijob>=1 )maxwrk = max( maxwrk, 2*sdim*( n-sdim ) ) @@ -17643,9 +17644,9 @@ module stdlib_linalg_lapack_q end if ! apply permutation to vsl and vsr ! (workspace: none needed) - if( ilvsl )call stdlib_qggbak( 'P', 'L', n, ilo, ihi, work( ileft ),work( iright ), n, & + if( ilvsl )call stdlib_${ri}$ggbak( 'P', 'L', n, ilo, ihi, work( ileft ),work( iright ), n, & vsl, ldvsl, ierr ) - if( ilvsr )call stdlib_qggbak( 'P', 'R', n, ilo, ihi, work( ileft ),work( iright ), n, & + if( ilvsr )call stdlib_${ri}$ggbak( 'P', 'R', n, ilo, ihi, work( ileft ),work( iright ), n, & vsr, ldvsr, ierr ) ! check if unscaling would cause over/underflow, if so, rescale ! (alphar(i),alphai(i),beta(i)) so beta(i) is on the order of @@ -17684,13 +17685,13 @@ module stdlib_linalg_lapack_q end if ! undo scaling if( ilascl ) then - call stdlib_qlascl( 'H', 0, 0, anrmto, anrm, n, n, a, lda, ierr ) - call stdlib_qlascl( 'G', 0, 0, anrmto, anrm, n, 1, alphar, n, ierr ) - call stdlib_qlascl( 'G', 0, 0, anrmto, anrm, n, 1, alphai, n, ierr ) + call stdlib_${ri}$lascl( 'H', 0, 0, anrmto, anrm, n, n, a, lda, ierr ) + call stdlib_${ri}$lascl( 'G', 0, 0, anrmto, anrm, n, 1, alphar, n, ierr ) + call stdlib_${ri}$lascl( 'G', 0, 0, anrmto, anrm, n, 1, alphai, n, ierr ) end if if( ilbscl ) then - call stdlib_qlascl( 'U', 0, 0, bnrmto, bnrm, n, n, b, ldb, ierr ) - call stdlib_qlascl( 'G', 0, 0, bnrmto, bnrm, n, 1, beta, n, ierr ) + call stdlib_${ri}$lascl( 'U', 0, 0, bnrmto, bnrm, n, n, b, ldb, ierr ) + call stdlib_${ri}$lascl( 'G', 0, 0, bnrmto, bnrm, n, 1, beta, n, ierr ) end if if( wantst ) then ! check if reordering is correct @@ -17725,10 +17726,10 @@ module stdlib_linalg_lapack_q work( 1 ) = maxwrk iwork( 1 ) = liwmin return - end subroutine stdlib_qggesx + end subroutine stdlib_${ri}$ggesx - subroutine stdlib_qggev( jobvl, jobvr, n, a, lda, b, ldb, alphar, alphai,beta, vl, ldvl, vr, & + subroutine stdlib_${ri}$ggev( jobvl, jobvr, n, a, lda, b, ldb, alphar, alphai,beta, vl, ldvl, vr, & !! DGGEV: computes for a pair of N-by-N real nonsymmetric matrices (A,B) !! the generalized eigenvalues, and optionally, the left and/or right !! generalized eigenvectors. @@ -17753,8 +17754,8 @@ module stdlib_linalg_lapack_q integer(ilp), intent(out) :: info integer(ilp), intent(in) :: lda, ldb, ldvl, ldvr, lwork, n ! Array Arguments - real(qp), intent(inout) :: a(lda,*), b(ldb,*) - real(qp), intent(out) :: alphai(*), alphar(*), beta(*), vl(ldvl,*), vr(ldvr,*), work(*) + real(${rk}$), intent(inout) :: a(lda,*), b(ldb,*) + real(${rk}$), intent(out) :: alphai(*), alphar(*), beta(*), vl(ldvl,*), vr(ldvr,*), work(*) ! ===================================================================== @@ -17763,7 +17764,7 @@ module stdlib_linalg_lapack_q character :: chtemp integer(ilp) :: icols, ierr, ihi, ijobvl, ijobvr, ileft, ilo, in, iright, irows, itau, & iwrk, jc, jr, maxwrk, minwrk - real(qp) :: anrm, anrmto, bignum, bnrm, bnrmto, eps, smlnum, temp + real(${rk}$) :: anrm, anrmto, bignum, bnrm, bnrmto, eps, smlnum, temp ! Local Arrays logical(lk) :: ldumma(1) ! Intrinsic Functions @@ -17837,14 +17838,14 @@ module stdlib_linalg_lapack_q ! quick return if possible if( n==0 )return ! get machine constants - eps = stdlib_qlamch( 'P' ) - smlnum = stdlib_qlamch( 'S' ) + eps = stdlib_${ri}$lamch( 'P' ) + smlnum = stdlib_${ri}$lamch( 'S' ) bignum = one / smlnum - call stdlib_qlabad( smlnum, bignum ) + call stdlib_${ri}$labad( smlnum, bignum ) smlnum = sqrt( smlnum ) / eps bignum = one / smlnum ! scale a if max element outside range [smlnum,bignum] - anrm = stdlib_qlange( 'M', n, n, a, lda, work ) + anrm = stdlib_${ri}$lange( 'M', n, n, a, lda, work ) ilascl = .false. if( anrm>zero .and. anrmzero .and. bnrm1 ) then - call stdlib_qlacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,vl( ilo+1, ilo ),& + call stdlib_${ri}$lacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,vl( ilo+1, ilo ),& ldvl ) end if - call stdlib_qorgqr( irows, irows, irows, vl( ilo, ilo ), ldvl,work( itau ), work( & + call stdlib_${ri}$orgqr( irows, irows, irows, vl( ilo, ilo ), ldvl,work( itau ), work( & iwrk ), lwork+1-iwrk, ierr ) end if ! initialize vr - if( ilvr )call stdlib_qlaset( 'FULL', n, n, zero, one, vr, ldvr ) + if( ilvr )call stdlib_${ri}$laset( 'FULL', n, n, zero, one, vr, ldvr ) ! reduce to generalized hessenberg form ! (workspace: none needed) if( ilv ) then ! eigenvectors requested -- work on whole matrix. - call stdlib_qgghrd( jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb, vl,ldvl, vr, ldvr, & + call stdlib_${ri}$gghrd( jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb, vl,ldvl, vr, ldvr, & ierr ) else - call stdlib_qgghrd( 'N', 'N', irows, 1, irows, a( ilo, ilo ), lda,b( ilo, ilo ), & + call stdlib_${ri}$gghrd( 'N', 'N', irows, 1, irows, a( ilo, ilo ), lda,b( ilo, ilo ), & ldb, vl, ldvl, vr, ldvr, ierr ) end if ! perform qz algorithm (compute eigenvalues, and optionally, the @@ -17920,7 +17921,7 @@ module stdlib_linalg_lapack_q else chtemp = 'E' end if - call stdlib_qhgeqz( chtemp, jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb,alphar, alphai, & + call stdlib_${ri}$hgeqz( chtemp, jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb,alphar, alphai, & beta, vl, ldvl, vr, ldvr,work( iwrk ), lwork+1-iwrk, ierr ) if( ierr/=0 ) then if( ierr>0 .and. ierr<=n ) then @@ -17944,7 +17945,7 @@ module stdlib_linalg_lapack_q else chtemp = 'R' end if - call stdlib_qtgevc( chtemp, 'B', ldumma, n, a, lda, b, ldb, vl, ldvl,vr, ldvr, n, & + call stdlib_${ri}$tgevc( chtemp, 'B', ldumma, n, a, lda, b, ldb, vl, ldvl,vr, ldvr, n, & in, work( iwrk ), ierr ) if( ierr/=0 ) then info = n + 2 @@ -17953,7 +17954,7 @@ module stdlib_linalg_lapack_q ! undo balancing on vl and vr and normalization ! (workspace: none needed) if( ilvl ) then - call stdlib_qggbak( 'P', 'L', n, ilo, ihi, work( ileft ),work( iright ), n, vl, & + call stdlib_${ri}$ggbak( 'P', 'L', n, ilo, ihi, work( ileft ),work( iright ), n, vl, & ldvl, ierr ) loop_50: do jc = 1, n if( alphai( jc )zero .and. anrmzero .and. bnrm1 ) then - call stdlib_qlacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,vl( ilo+1, ilo ),& + call stdlib_${ri}$lacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,vl( ilo+1, ilo ),& ldvl ) end if - call stdlib_qorgqr( irows, irows, irows, vl( ilo, ilo ), ldvl,work( itau ), work( & + call stdlib_${ri}$orgqr( irows, irows, irows, vl( ilo, ilo ), ldvl,work( itau ), work( & iwrk ), lwork+1-iwrk, ierr ) end if ! initialize vr - if( ilvr )call stdlib_qlaset( 'FULL', n, n, zero, one, vr, ldvr ) + if( ilvr )call stdlib_${ri}$laset( 'FULL', n, n, zero, one, vr, ldvr ) ! reduce to generalized hessenberg form if( ilv ) then ! eigenvectors requested -- work on whole matrix. - call stdlib_qgghd3( jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb, vl,ldvl, vr, ldvr, & + call stdlib_${ri}$gghd3( jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb, vl,ldvl, vr, ldvr, & work( iwrk ), lwork+1-iwrk, ierr ) else - call stdlib_qgghd3( 'N', 'N', irows, 1, irows, a( ilo, ilo ), lda,b( ilo, ilo ), & + call stdlib_${ri}$gghd3( 'N', 'N', irows, 1, irows, a( ilo, ilo ), lda,b( ilo, ilo ), & ldb, vl, ldvl, vr, ldvr,work( iwrk ), lwork+1-iwrk, ierr ) end if ! perform qz algorithm (compute eigenvalues, and optionally, the @@ -18222,7 +18223,7 @@ module stdlib_linalg_lapack_q else chtemp = 'E' end if - call stdlib_qlaqz0( chtemp, jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb,alphar, alphai, & + call stdlib_${ri}$laqz0( chtemp, jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb,alphar, alphai, & beta, vl, ldvl, vr, ldvr,work( iwrk ), lwork+1-iwrk, 0, ierr ) if( ierr/=0 ) then if( ierr>0 .and. ierr<=n ) then @@ -18245,7 +18246,7 @@ module stdlib_linalg_lapack_q else chtemp = 'R' end if - call stdlib_qtgevc( chtemp, 'B', ldumma, n, a, lda, b, ldb, vl, ldvl,vr, ldvr, n, & + call stdlib_${ri}$tgevc( chtemp, 'B', ldumma, n, a, lda, b, ldb, vl, ldvl,vr, ldvr, n, & in, work( iwrk ), ierr ) if( ierr/=0 ) then info = n + 2 @@ -18253,7 +18254,7 @@ module stdlib_linalg_lapack_q end if ! undo balancing on vl and vr and normalization if( ilvl ) then - call stdlib_qggbak( 'P', 'L', n, ilo, ihi, work( ileft ),work( iright ), n, vl, & + call stdlib_${ri}$ggbak( 'P', 'L', n, ilo, ihi, work( ileft ),work( iright ), n, vl, & ldvl, ierr ) loop_50: do jc = 1, n if( alphai( jc )zero .and. anrmzero .and. bnrm1 ) then - call stdlib_qlacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,vl( ilo+1, ilo ),& + call stdlib_${ri}$lacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,vl( ilo+1, ilo ),& ldvl ) end if - call stdlib_qorgqr( irows, irows, irows, vl( ilo, ilo ), ldvl,work( itau ), work( & + call stdlib_${ri}$orgqr( irows, irows, irows, vl( ilo, ilo ), ldvl,work( itau ), work( & iwrk ), lwork+1-iwrk, ierr ) end if - if( ilvr )call stdlib_qlaset( 'FULL', n, n, zero, one, vr, ldvr ) + if( ilvr )call stdlib_${ri}$laset( 'FULL', n, n, zero, one, vr, ldvr ) ! reduce to generalized hessenberg form ! (workspace: none needed) if( ilv .or. .not.wantsn ) then ! eigenvectors requested -- work on whole matrix. - call stdlib_qgghrd( jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb, vl,ldvl, vr, ldvr, & + call stdlib_${ri}$gghrd( jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb, vl,ldvl, vr, ldvr, & ierr ) else - call stdlib_qgghrd( 'N', 'N', irows, 1, irows, a( ilo, ilo ), lda,b( ilo, ilo ), & + call stdlib_${ri}$gghrd( 'N', 'N', irows, 1, irows, a( ilo, ilo ), lda,b( ilo, ilo ), & ldb, vl, ldvl, vr, ldvr, ierr ) end if ! perform qz algorithm (compute eigenvalues, and optionally, the @@ -18565,7 +18566,7 @@ module stdlib_linalg_lapack_q else chtemp = 'E' end if - call stdlib_qhgeqz( chtemp, jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb,alphar, alphai, & + call stdlib_${ri}$hgeqz( chtemp, jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb,alphar, alphai, & beta, vl, ldvl, vr, ldvr, work,lwork, ierr ) if( ierr/=0 ) then if( ierr>0 .and. ierr<=n ) then @@ -18578,8 +18579,8 @@ module stdlib_linalg_lapack_q go to 130 end if ! compute eigenvectors and estimate condition numbers if desired - ! (workspace: stdlib_qtgevc: need 6*n - ! stdlib_qtgsna: need 2*n*(n+2)+16 if sense = 'v' or 'b', + ! (workspace: stdlib_${ri}$tgevc: need 6*n + ! stdlib_${ri}$tgsna: need 2*n*(n+2)+16 if sense = 'v' or 'b', ! need n otherwise ) if( ilv .or. .not.wantsn ) then if( ilv ) then @@ -18592,7 +18593,7 @@ module stdlib_linalg_lapack_q else chtemp = 'R' end if - call stdlib_qtgevc( chtemp, 'B', ldumma, n, a, lda, b, ldb, vl,ldvl, vr, ldvr, n,& + call stdlib_${ri}$tgevc( chtemp, 'B', ldumma, n, a, lda, b, ldb, vl,ldvl, vr, ldvr, n,& in, work, ierr ) if( ierr/=0 ) then info = n + 2 @@ -18600,8 +18601,8 @@ module stdlib_linalg_lapack_q end if end if if( .not.wantsn ) then - ! compute eigenvectors (stdlib_qtgevc) and estimate condition - ! numbers (stdlib_qtgsna). note that the definition of the condition + ! compute eigenvectors (stdlib_${ri}$tgevc) and estimate condition + ! numbers (stdlib_${ri}$tgsna). note that the definition of the condition ! number is not invariant under transformation (u,v) to ! (q*u, z*v), where (u,v) are eigenvectors of the generalized ! schur form (s,t), q and z are orthogonal matrices. in order @@ -18634,14 +18635,14 @@ module stdlib_linalg_lapack_q ! compute a pair of left and right eigenvectors. ! (compute workspace: need up to 4*n + 6*n) if( wantse .or. wantsb ) then - call stdlib_qtgevc( 'B', 'S', bwork, n, a, lda, b, ldb,work( 1 ), n, work( & + call stdlib_${ri}$tgevc( 'B', 'S', bwork, n, a, lda, b, ldb,work( 1 ), n, work( & iwrk ), n, mm, m,work( iwrk1 ), ierr ) if( ierr/=0 ) then info = n + 2 go to 130 end if end if - call stdlib_qtgsna( sense, 'S', bwork, n, a, lda, b, ldb,work( 1 ), n, work( & + call stdlib_${ri}$tgsna( sense, 'S', bwork, n, a, lda, b, ldb,work( 1 ), n, work( & iwrk ), n, rconde( i ),rcondv( i ), mm, m, work( iwrk1 ),lwork-iwrk1+1, iwork,& ierr ) end do loop_20 @@ -18650,7 +18651,7 @@ module stdlib_linalg_lapack_q ! undo balancing on vl and vr and normalization ! (workspace: none needed) if( ilvl ) then - call stdlib_qggbak( balanc, 'L', n, ilo, ihi, lscale, rscale, n, vl,ldvl, ierr ) + call stdlib_${ri}$ggbak( balanc, 'L', n, ilo, ihi, lscale, rscale, n, vl,ldvl, ierr ) loop_70: do jc = 1, n if( alphai( jc )m ) then - call stdlib_qtrtrs( 'UPPER', 'NO TRANSPOSE', 'NON UNIT', n-m, 1,b( m+1, m+p-n+1 ), & + call stdlib_${ri}$trtrs( 'UPPER', 'NO TRANSPOSE', 'NON UNIT', n-m, 1,b( m+1, m+p-n+1 ), & ldb, d( m+1 ), n-m, info ) if( info>0 ) then info = 1 return end if - call stdlib_qcopy( n-m, d( m+1 ), 1, y( m+p-n+1 ), 1 ) + call stdlib_${ri}$copy( n-m, d( m+1 ), 1, y( m+p-n+1 ), 1 ) end if ! set y1 = 0 do i = 1, m + p - n y( i ) = zero end do ! update d1 = d1 - t12*y2 - call stdlib_qgemv( 'NO TRANSPOSE', m, n-m, -one, b( 1, m+p-n+1 ), ldb,y( m+p-n+1 ), 1, & + call stdlib_${ri}$gemv( 'NO TRANSPOSE', m, n-m, -one, b( 1, m+p-n+1 ), ldb,y( m+p-n+1 ), 1, & one, d, 1 ) ! solve triangular system: r11*x = d1 if( m>0 ) then - call stdlib_qtrtrs( 'UPPER', 'NO TRANSPOSE', 'NON UNIT', m, 1, a, lda,d, m, info ) + call stdlib_${ri}$trtrs( 'UPPER', 'NO TRANSPOSE', 'NON UNIT', m, 1, a, lda,d, m, info ) if( info>0 ) then info = 2 return end if ! copy d to x - call stdlib_qcopy( m, d, 1, x, 1 ) + call stdlib_${ri}$copy( m, d, 1, x, 1 ) end if ! backward transformation y = z**t *y - call stdlib_qormrq( 'LEFT', 'TRANSPOSE', p, 1, np,b( max( 1, n-p+1 ), 1 ), ldb, work( & + call stdlib_${ri}$ormrq( 'LEFT', 'TRANSPOSE', p, 1, np,b( max( 1, n-p+1 ), 1 ), ldb, work( & m+1 ), y,max( 1, p ), work( m+np+1 ), lwork-m-np, info ) work( 1 ) = m + np + max( lopt, int( work( m+np+1 ),KIND=ilp) ) return - end subroutine stdlib_qggglm + end subroutine stdlib_${ri}$ggglm - pure subroutine stdlib_qgghd3( compq, compz, n, ilo, ihi, a, lda, b, ldb, q,ldq, z, ldz, & + pure subroutine stdlib_${ri}$gghd3( compq, compz, n, ilo, ihi, a, lda, b, ldb, q,ldq, z, ldz, & !! DGGHD3: reduces a pair of real matrices (A,B) to generalized upper !! Hessenberg form using orthogonal transformations, where A is a !! general matrix and B is upper triangular. The form of the @@ -18892,8 +18893,8 @@ module stdlib_linalg_lapack_q integer(ilp), intent(in) :: ihi, ilo, lda, ldb, ldq, ldz, n, lwork integer(ilp), intent(out) :: info ! Array Arguments - real(qp), intent(inout) :: a(lda,*), b(ldb,*), q(ldq,*), z(ldz,*) - real(qp), intent(out) :: work(*) + real(${rk}$), intent(inout) :: a(lda,*), b(ldb,*), q(ldq,*), z(ldz,*) + real(${rk}$), intent(out) :: work(*) ! ===================================================================== ! Local Scalars @@ -18901,7 +18902,7 @@ module stdlib_linalg_lapack_q character :: compq2, compz2 integer(ilp) :: cola, i, ierr, j, j0, jcol, jj, jrow, k, kacc22, len, lwkopt, n2nb, nb,& nblst, nbmin, nh, nnb, nx, ppw, ppwo, pw, top, topq - real(qp) :: c, c1, c2, s, s1, s2, temp, temp1, temp2, temp3 + real(${rk}$) :: c, c1, c2, s, s1, s2, temp, temp1, temp2, temp3 ! Intrinsic Functions intrinsic :: real,max ! Executable Statements @@ -18909,7 +18910,7 @@ module stdlib_linalg_lapack_q info = 0 nb = stdlib_ilaenv( 1, 'DGGHD3', ' ', n, ilo, ihi, -1 ) lwkopt = max( 6*n*nb, 1 ) - work( 1 ) = real( lwkopt,KIND=qp) + work( 1 ) = real( lwkopt,KIND=${rk}$) initq = stdlib_lsame( compq, 'I' ) wantq = initq .or. stdlib_lsame( compq, 'V' ) initz = stdlib_lsame( compz, 'I' ) @@ -18943,10 +18944,10 @@ module stdlib_linalg_lapack_q return end if ! initialize q and z if desired. - if( initq )call stdlib_qlaset( 'ALL', n, n, zero, one, q, ldq ) - if( initz )call stdlib_qlaset( 'ALL', n, n, zero, one, z, ldz ) + if( initq )call stdlib_${ri}$laset( 'ALL', n, n, zero, one, q, ldq ) + if( initz )call stdlib_${ri}$laset( 'ALL', n, n, zero, one, z, ldz ) ! zero out lower triangle of b. - if( n>1 )call stdlib_qlaset( 'LOWER', n-1, n-1, zero, zero, b(2, 1), ldb ) + if( n>1 )call stdlib_${ri}$laset( 'LOWER', n-1, n-1, zero, zero, b(2, 1), ldb ) ! quick return if possible nh = ihi - ilo + 1 if( nh<=1 ) then @@ -18989,10 +18990,10 @@ module stdlib_linalg_lapack_q ! factor. n2nb = ( ihi-jcol-1 ) / nnb - 1 nblst = ihi - jcol - n2nb*nnb - call stdlib_qlaset( 'ALL', nblst, nblst, zero, one, work, nblst ) + call stdlib_${ri}$laset( 'ALL', nblst, nblst, zero, one, work, nblst ) pw = nblst * nblst + 1 do i = 1, n2nb - call stdlib_qlaset( 'ALL', 2*nnb, 2*nnb, zero, one,work( pw ), 2*nnb ) + call stdlib_${ri}$laset( 'ALL', 2*nnb, 2*nnb, zero, one,work( pw ), 2*nnb ) pw = pw + 4*nnb*nnb end do ! reduce columns jcol:jcol+nnb-1 of a to hessenberg form. @@ -19001,7 +19002,7 @@ module stdlib_linalg_lapack_q ! column of a and b, respectively. do i = ihi, j+2, -1 temp = a( i-1, j ) - call stdlib_qlartg( temp, a( i, j ), c, s, a( i-1, j ) ) + call stdlib_${ri}$lartg( temp, a( i, j ), c, s, a( i-1, j ) ) a( i, j ) = c b( i, j ) = s end do @@ -19059,9 +19060,9 @@ module stdlib_linalg_lapack_q ! annihilate b( jj+1, jj ). if( jj0 ) then do i = jj, 1, -1 - call stdlib_qrot( ihi-top, a( top+1, j+i+1 ), 1,a( top+1, j+i ), 1, a( & + call stdlib_${ri}$rot( ihi-top, a( top+1, j+i+1 ), 1,a( top+1, j+i ), 1, a( & j+1+i, j ),-b( j+1+i, j ) ) end do end if @@ -19111,16 +19112,16 @@ module stdlib_linalg_lapack_q ! where u21 is a len-by-len matrix and u12 is lower ! triangular. jrow = ihi - nblst + 1 - call stdlib_qgemv( 'TRANSPOSE', nblst, len, one, work,nblst, a( jrow, j+1 )& + call stdlib_${ri}$gemv( 'TRANSPOSE', nblst, len, one, work,nblst, a( jrow, j+1 )& , 1, zero,work( pw ), 1 ) ppw = pw + len do i = jrow, jrow+nblst-len-1 work( ppw ) = a( i, j+1 ) ppw = ppw + 1 end do - call stdlib_qtrmv( 'LOWER', 'TRANSPOSE', 'NON-UNIT',nblst-len, work( & + call stdlib_${ri}$trmv( 'LOWER', 'TRANSPOSE', 'NON-UNIT',nblst-len, work( & len*nblst + 1 ), nblst,work( pw+len ), 1 ) - call stdlib_qgemv( 'TRANSPOSE', len, nblst-len, one,work( (len+1)*nblst - & + call stdlib_${ri}$gemv( 'TRANSPOSE', len, nblst-len, one,work( (len+1)*nblst - & len + 1 ), nblst,a( jrow+nblst-len, j+1 ), 1, one,work( pw+len ), 1 ) ppw = pw @@ -19151,13 +19152,13 @@ module stdlib_linalg_lapack_q work( ppw ) = a( i, j+1 ) ppw = ppw + 1 end do - call stdlib_qtrmv( 'UPPER', 'TRANSPOSE', 'NON-UNIT', len,work( ppwo + & + call stdlib_${ri}$trmv( 'UPPER', 'TRANSPOSE', 'NON-UNIT', len,work( ppwo + & nnb ), 2*nnb, work( pw ),1 ) - call stdlib_qtrmv( 'LOWER', 'TRANSPOSE', 'NON-UNIT', nnb,work( ppwo + & + call stdlib_${ri}$trmv( 'LOWER', 'TRANSPOSE', 'NON-UNIT', nnb,work( ppwo + & 2*len*nnb ),2*nnb, work( pw + len ), 1 ) - call stdlib_qgemv( 'TRANSPOSE', nnb, len, one,work( ppwo ), 2*nnb, a( & + call stdlib_${ri}$gemv( 'TRANSPOSE', nnb, len, one,work( ppwo ), 2*nnb, a( & jrow, j+1 ), 1,one, work( pw ), 1 ) - call stdlib_qgemv( 'TRANSPOSE', len, nnb, one,work( ppwo + 2*len*nnb + & + call stdlib_${ri}$gemv( 'TRANSPOSE', len, nnb, one,work( ppwo + 2*len*nnb + & nnb ), 2*nnb,a( jrow+nnb, j+1 ), 1, one,work( pw+len ), 1 ) ppw = pw do i = jrow, jrow+len+nnb-1 @@ -19171,9 +19172,9 @@ module stdlib_linalg_lapack_q ! apply accumulated orthogonal matrices to a. cola = n - jcol - nnb + 1 j = ihi - nblst + 1 - call stdlib_qgemm( 'TRANSPOSE', 'NO TRANSPOSE', nblst,cola, nblst, one, work, & + call stdlib_${ri}$gemm( 'TRANSPOSE', 'NO TRANSPOSE', nblst,cola, nblst, one, work, & nblst,a( j, jcol+nnb ), lda, zero, work( pw ),nblst ) - call stdlib_qlacpy( 'ALL', nblst, cola, work( pw ), nblst,a( j, jcol+nnb ), lda ) + call stdlib_${ri}$lacpy( 'ALL', nblst, cola, work( pw ), nblst,a( j, jcol+nnb ), lda ) ppwo = nblst*nblst + 1 j0 = j - nnb @@ -19185,13 +19186,13 @@ module stdlib_linalg_lapack_q ! [ u21 u22 ], ! where all blocks are nnb-by-nnb, u21 is upper ! triangular and u12 is lower triangular. - call stdlib_qorm22( 'LEFT', 'TRANSPOSE', 2*nnb, cola, nnb,nnb, work( ppwo )& + call stdlib_${ri}$orm22( 'LEFT', 'TRANSPOSE', 2*nnb, cola, nnb,nnb, work( ppwo )& , 2*nnb,a( j, jcol+nnb ), lda, work( pw ),lwork-pw+1, ierr ) else ! ignore the structure of u. - call stdlib_qgemm( 'TRANSPOSE', 'NO TRANSPOSE', 2*nnb,cola, 2*nnb, one, & + call stdlib_${ri}$gemm( 'TRANSPOSE', 'NO TRANSPOSE', 2*nnb,cola, 2*nnb, one, & work( ppwo ), 2*nnb,a( j, jcol+nnb ), lda, zero, work( pw ),2*nnb ) - call stdlib_qlacpy( 'ALL', 2*nnb, cola, work( pw ), 2*nnb,a( j, jcol+nnb ),& + call stdlib_${ri}$lacpy( 'ALL', 2*nnb, cola, work( pw ), 2*nnb,a( j, jcol+nnb ),& lda ) end if ppwo = ppwo + 4*nnb*nnb @@ -19206,9 +19207,9 @@ module stdlib_linalg_lapack_q topq = 1 nh = n end if - call stdlib_qgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', nh,nblst, nblst, one, q( & + call stdlib_${ri}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', nh,nblst, nblst, one, q( & topq, j ), ldq,work, nblst, zero, work( pw ), nh ) - call stdlib_qlacpy( 'ALL', nh, nblst, work( pw ), nh,q( topq, j ), ldq ) + call stdlib_${ri}$lacpy( 'ALL', nh, nblst, work( pw ), nh,q( topq, j ), ldq ) ppwo = nblst*nblst + 1 j0 = j - nnb @@ -19219,13 +19220,13 @@ module stdlib_linalg_lapack_q end if if ( blk22 ) then ! exploit the structure of u. - call stdlib_qorm22( 'RIGHT', 'NO TRANSPOSE', nh, 2*nnb,nnb, nnb, work( & + call stdlib_${ri}$orm22( 'RIGHT', 'NO TRANSPOSE', nh, 2*nnb,nnb, nnb, work( & ppwo ), 2*nnb,q( topq, j ), ldq, work( pw ),lwork-pw+1, ierr ) else ! ignore the structure of u. - call stdlib_qgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', nh,2*nnb, 2*nnb, one,& + call stdlib_${ri}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', nh,2*nnb, 2*nnb, one,& q( topq, j ), ldq,work( ppwo ), 2*nnb, zero, work( pw ),nh ) - call stdlib_qlacpy( 'ALL', nh, 2*nnb, work( pw ), nh,q( topq, j ), ldq ) + call stdlib_${ri}$lacpy( 'ALL', nh, 2*nnb, work( pw ), nh,q( topq, j ), ldq ) end if ppwo = ppwo + 4*nnb*nnb @@ -19235,10 +19236,10 @@ module stdlib_linalg_lapack_q if ( wantz .or. top>0 ) then ! initialize small orthogonal factors that will hold the ! accumulated givens rotations in workspace. - call stdlib_qlaset( 'ALL', nblst, nblst, zero, one, work,nblst ) + call stdlib_${ri}$laset( 'ALL', nblst, nblst, zero, one, work,nblst ) pw = nblst * nblst + 1 do i = 1, n2nb - call stdlib_qlaset( 'ALL', 2*nnb, 2*nnb, zero, one,work( pw ), 2*nnb ) + call stdlib_${ri}$laset( 'ALL', 2*nnb, 2*nnb, zero, one,work( pw ), 2*nnb ) pw = pw + 4*nnb*nnb end do @@ -19282,51 +19283,51 @@ module stdlib_linalg_lapack_q end do end do else - call stdlib_qlaset( 'LOWER', ihi - jcol - 1, nnb, zero, zero,a( jcol + 2, & + call stdlib_${ri}$laset( 'LOWER', ihi - jcol - 1, nnb, zero, zero,a( jcol + 2, & jcol ), lda ) - call stdlib_qlaset( 'LOWER', ihi - jcol - 1, nnb, zero, zero,b( jcol + 2, & + call stdlib_${ri}$laset( 'LOWER', ihi - jcol - 1, nnb, zero, zero,b( jcol + 2, & jcol ), ldb ) end if ! apply accumulated orthogonal matrices to a and b. if ( top>0 ) then j = ihi - nblst + 1 - call stdlib_qgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', top,nblst, nblst, one, a( & + call stdlib_${ri}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', top,nblst, nblst, one, a( & 1, j ), lda,work, nblst, zero, work( pw ), top ) - call stdlib_qlacpy( 'ALL', top, nblst, work( pw ), top,a( 1, j ), lda ) + call stdlib_${ri}$lacpy( 'ALL', top, nblst, work( pw ), top,a( 1, j ), lda ) ppwo = nblst*nblst + 1 j0 = j - nnb do j = j0, jcol+1, -nnb if ( blk22 ) then ! exploit the structure of u. - call stdlib_qorm22( 'RIGHT', 'NO TRANSPOSE', top, 2*nnb,nnb, nnb, work( & + call stdlib_${ri}$orm22( 'RIGHT', 'NO TRANSPOSE', top, 2*nnb,nnb, nnb, work( & ppwo ), 2*nnb,a( 1, j ), lda, work( pw ),lwork-pw+1, ierr ) else ! ignore the structure of u. - call stdlib_qgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', top,2*nnb, 2*nnb, & + call stdlib_${ri}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', top,2*nnb, 2*nnb, & one, a( 1, j ), lda,work( ppwo ), 2*nnb, zero,work( pw ), top ) - call stdlib_qlacpy( 'ALL', top, 2*nnb, work( pw ), top,a( 1, j ), lda ) + call stdlib_${ri}$lacpy( 'ALL', top, 2*nnb, work( pw ), top,a( 1, j ), lda ) end if ppwo = ppwo + 4*nnb*nnb end do j = ihi - nblst + 1 - call stdlib_qgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', top,nblst, nblst, one, b( & + call stdlib_${ri}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', top,nblst, nblst, one, b( & 1, j ), ldb,work, nblst, zero, work( pw ), top ) - call stdlib_qlacpy( 'ALL', top, nblst, work( pw ), top,b( 1, j ), ldb ) + call stdlib_${ri}$lacpy( 'ALL', top, nblst, work( pw ), top,b( 1, j ), ldb ) ppwo = nblst*nblst + 1 j0 = j - nnb do j = j0, jcol+1, -nnb if ( blk22 ) then ! exploit the structure of u. - call stdlib_qorm22( 'RIGHT', 'NO TRANSPOSE', top, 2*nnb,nnb, nnb, work( & + call stdlib_${ri}$orm22( 'RIGHT', 'NO TRANSPOSE', top, 2*nnb,nnb, nnb, work( & ppwo ), 2*nnb,b( 1, j ), ldb, work( pw ),lwork-pw+1, ierr ) else ! ignore the structure of u. - call stdlib_qgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', top,2*nnb, 2*nnb, & + call stdlib_${ri}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', top,2*nnb, 2*nnb, & one, b( 1, j ), ldb,work( ppwo ), 2*nnb, zero,work( pw ), top ) - call stdlib_qlacpy( 'ALL', top, 2*nnb, work( pw ), top,b( 1, j ), ldb ) + call stdlib_${ri}$lacpy( 'ALL', top, 2*nnb, work( pw ), top,b( 1, j ), ldb ) end if ppwo = ppwo + 4*nnb*nnb @@ -19342,9 +19343,9 @@ module stdlib_linalg_lapack_q topq = 1 nh = n end if - call stdlib_qgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', nh,nblst, nblst, one, z( & + call stdlib_${ri}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', nh,nblst, nblst, one, z( & topq, j ), ldz,work, nblst, zero, work( pw ), nh ) - call stdlib_qlacpy( 'ALL', nh, nblst, work( pw ), nh,z( topq, j ), ldz ) + call stdlib_${ri}$lacpy( 'ALL', nh, nblst, work( pw ), nh,z( topq, j ), ldz ) ppwo = nblst*nblst + 1 j0 = j - nnb @@ -19355,13 +19356,13 @@ module stdlib_linalg_lapack_q end if if ( blk22 ) then ! exploit the structure of u. - call stdlib_qorm22( 'RIGHT', 'NO TRANSPOSE', nh, 2*nnb,nnb, nnb, work( & + call stdlib_${ri}$orm22( 'RIGHT', 'NO TRANSPOSE', nh, 2*nnb,nnb, nnb, work( & ppwo ), 2*nnb,z( topq, j ), ldz, work( pw ),lwork-pw+1, ierr ) else ! ignore the structure of u. - call stdlib_qgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', nh,2*nnb, 2*nnb, one,& + call stdlib_${ri}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', nh,2*nnb, 2*nnb, one,& z( topq, j ), ldz,work( ppwo ), 2*nnb, zero, work( pw ),nh ) - call stdlib_qlacpy( 'ALL', nh, 2*nnb, work( pw ), nh,z( topq, j ), ldz ) + call stdlib_${ri}$lacpy( 'ALL', nh, 2*nnb, work( pw ), nh,z( topq, j ), ldz ) end if ppwo = ppwo + 4*nnb*nnb @@ -19377,14 +19378,14 @@ module stdlib_linalg_lapack_q if ( wantq )compq2 = 'V' if ( wantz )compz2 = 'V' end if - if ( jcol0 ) then - call stdlib_qtrtrs( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', p, 1,b( 1, n-p+1 ), ldb, d,& + call stdlib_${ri}$trtrs( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', p, 1,b( 1, n-p+1 ), ldb, d,& p, info ) if( info>0 ) then info = 1 return end if ! put the solution in x - call stdlib_qcopy( p, d, 1, x( n-p+1 ), 1 ) + call stdlib_${ri}$copy( p, d, 1, x( n-p+1 ), 1 ) ! update c1 - call stdlib_qgemv( 'NO TRANSPOSE', n-p, p, -one, a( 1, n-p+1 ), lda,d, 1, one, c, 1 & + call stdlib_${ri}$gemv( 'NO TRANSPOSE', n-p, p, -one, a( 1, n-p+1 ), lda,d, 1, one, c, 1 & ) end if ! solve r11*x1 = c1 for x1 if( n>p ) then - call stdlib_qtrtrs( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', n-p, 1,a, lda, c, n-p, & + call stdlib_${ri}$trtrs( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', n-p, 1,a, lda, c, n-p, & info ) if( info>0 ) then info = 2 return end if ! put the solutions in x - call stdlib_qcopy( n-p, c, 1, x, 1 ) + call stdlib_${ri}$copy( n-p, c, 1, x, 1 ) end if ! compute the residual vector: if( m0 )call stdlib_qgemv( 'NO TRANSPOSE', nr, n-m, -one, a( n-p+1, m+1 ),lda, d( & + if( nr>0 )call stdlib_${ri}$gemv( 'NO TRANSPOSE', nr, n-m, -one, a( n-p+1, m+1 ),lda, d( & nr+1 ), 1, one, c( n-p+1 ), 1 ) else nr = p end if if( nr>0 ) then - call stdlib_qtrmv( 'UPPER', 'NO TRANSPOSE', 'NON UNIT', nr,a( n-p+1, n-p+1 ), lda, & + call stdlib_${ri}$trmv( 'UPPER', 'NO TRANSPOSE', 'NON UNIT', nr,a( n-p+1, n-p+1 ), lda, & d, 1 ) - call stdlib_qaxpy( nr, -one, d, 1, c( n-p+1 ), 1 ) + call stdlib_${ri}$axpy( nr, -one, d, 1, c( n-p+1 ), 1 ) end if ! backward transformation x = q**t*x - call stdlib_qormrq( 'LEFT', 'TRANSPOSE', n, 1, p, b, ldb, work( 1 ), x,n, work( p+mn+1 & + call stdlib_${ri}$ormrq( 'LEFT', 'TRANSPOSE', n, 1, p, b, ldb, work( 1 ), x,n, work( p+mn+1 & ), lwork-p-mn, info ) work( 1 ) = p + mn + max( lopt, int( work( p+mn+1 ),KIND=ilp) ) return - end subroutine stdlib_qgglse + end subroutine stdlib_${ri}$gglse - pure subroutine stdlib_qggqrf( n, m, p, a, lda, taua, b, ldb, taub, work,lwork, info ) + pure subroutine stdlib_${ri}$ggqrf( n, m, p, a, lda, taua, b, ldb, taub, work,lwork, info ) !! DGGQRF: computes a generalized QR factorization of an N-by-M matrix A !! and an N-by-P matrix B: !! A = Q*R, B = Q*T*Z, @@ -19673,8 +19674,8 @@ module stdlib_linalg_lapack_q integer(ilp), intent(out) :: info integer(ilp), intent(in) :: lda, ldb, lwork, m, n, p ! Array Arguments - real(qp), intent(inout) :: a(lda,*), b(ldb,*) - real(qp), intent(out) :: taua(*), taub(*), work(*) + real(${rk}$), intent(inout) :: a(lda,*), b(ldb,*) + real(${rk}$), intent(out) :: taua(*), taub(*), work(*) ! ===================================================================== ! Local Scalars logical(lk) :: lquery @@ -19711,20 +19712,20 @@ module stdlib_linalg_lapack_q return end if ! qr factorization of n-by-m matrix a: a = q*r - call stdlib_qgeqrf( n, m, a, lda, taua, work, lwork, info ) + call stdlib_${ri}$geqrf( n, m, a, lda, taua, work, lwork, info ) lopt = work( 1 ) ! update b := q**t*b. - call stdlib_qormqr( 'LEFT', 'TRANSPOSE', n, p, min( n, m ), a, lda, taua,b, ldb, work, & + call stdlib_${ri}$ormqr( 'LEFT', 'TRANSPOSE', n, p, min( n, m ), a, lda, taua,b, ldb, work, & lwork, info ) lopt = max( lopt, int( work( 1 ),KIND=ilp) ) ! rq factorization of n-by-p matrix b: b = t*z. - call stdlib_qgerqf( n, p, b, ldb, taub, work, lwork, info ) + call stdlib_${ri}$gerqf( n, p, b, ldb, taub, work, lwork, info ) work( 1 ) = max( lopt, int( work( 1 ),KIND=ilp) ) return - end subroutine stdlib_qggqrf + end subroutine stdlib_${ri}$ggqrf - pure subroutine stdlib_qggrqf( m, p, n, a, lda, taua, b, ldb, taub, work,lwork, info ) + pure subroutine stdlib_${ri}$ggrqf( m, p, n, a, lda, taua, b, ldb, taub, work,lwork, info ) !! DGGRQF: computes a generalized RQ factorization of an M-by-N matrix A !! and a P-by-N matrix B: !! A = R*Q, B = Z*T*Q, @@ -19751,8 +19752,8 @@ module stdlib_linalg_lapack_q integer(ilp), intent(out) :: info integer(ilp), intent(in) :: lda, ldb, lwork, m, n, p ! Array Arguments - real(qp), intent(inout) :: a(lda,*), b(ldb,*) - real(qp), intent(out) :: taua(*), taub(*), work(*) + real(${rk}$), intent(inout) :: a(lda,*), b(ldb,*) + real(${rk}$), intent(out) :: taua(*), taub(*), work(*) ! ===================================================================== ! Local Scalars logical(lk) :: lquery @@ -19789,20 +19790,20 @@ module stdlib_linalg_lapack_q return end if ! rq factorization of m-by-n matrix a: a = r*q - call stdlib_qgerqf( m, n, a, lda, taua, work, lwork, info ) + call stdlib_${ri}$gerqf( m, n, a, lda, taua, work, lwork, info ) lopt = work( 1 ) ! update b := b*q**t - call stdlib_qormrq( 'RIGHT', 'TRANSPOSE', p, n, min( m, n ),a( max( 1, m-n+1 ), 1 ), & + call stdlib_${ri}$ormrq( 'RIGHT', 'TRANSPOSE', p, n, min( m, n ),a( max( 1, m-n+1 ), 1 ), & lda, taua, b, ldb, work,lwork, info ) lopt = max( lopt, int( work( 1 ),KIND=ilp) ) ! qr factorization of p-by-n matrix b: b = z*t - call stdlib_qgeqrf( p, n, b, ldb, taub, work, lwork, info ) + call stdlib_${ri}$geqrf( p, n, b, ldb, taub, work, lwork, info ) work( 1 ) = max( lopt, int( work( 1 ),KIND=ilp) ) return - end subroutine stdlib_qggrqf + end subroutine stdlib_${ri}$ggrqf - pure subroutine stdlib_qgsvj0( jobv, m, n, a, lda, d, sva, mv, v, ldv, eps,sfmin, tol, & + pure subroutine stdlib_${ri}$gsvj0( jobv, m, n, a, lda, d, sva, mv, v, ldv, eps,sfmin, tol, & !! DGSVJ0: is called from DGESVJ as a pre-processor and that is its main !! purpose. It applies Jacobi rotations in the same way as DGESVJ does, but !! it does not check convergence (stopping criterion). Few tuning @@ -19814,21 +19815,21 @@ module stdlib_linalg_lapack_q ! Scalar Arguments integer(ilp), intent(out) :: info integer(ilp), intent(in) :: lda, ldv, lwork, m, mv, n, nsweep - real(qp), intent(in) :: eps, sfmin, tol + real(${rk}$), intent(in) :: eps, sfmin, tol character, intent(in) :: jobv ! Array Arguments - real(qp), intent(inout) :: a(lda,*), sva(n), d(n), v(ldv,*) - real(qp), intent(out) :: work(lwork) + real(${rk}$), intent(inout) :: a(lda,*), sva(n), d(n), v(ldv,*) + real(${rk}$), intent(out) :: work(lwork) ! ===================================================================== ! Local Scalars - real(qp) :: aapp, aapp0, aapq, aaqq, apoaq, aqoap, big, bigtheta, cs, mxaapq, mxsinj, & + real(${rk}$) :: aapp, aapp0, aapq, aaqq, apoaq, aqoap, big, bigtheta, cs, mxaapq, mxsinj, & rootbig, rooteps, rootsfmin, roottol, small, sn, t, temp1, theta, thsign integer(ilp) :: blskip, emptsw, i, ibr, ierr, igl, ijblsk, ir1, iswrot, jbc, jgl, kbl, & lkahead, mvl, nbl, notrot, p, pskipped, q, rowskip, swband logical(lk) :: applv, rotok, rsvec ! Local Arrays - real(qp) :: fastr(5) + real(${rk}$) :: fastr(5) ! Intrinsic Functions intrinsic :: abs,max,real,min,sign,sqrt ! Executable Statements @@ -19912,10 +19913,10 @@ module stdlib_linalg_lapack_q igl = igl + ir1*kbl loop_2001: do p = igl, min( igl+kbl-1, n-1 ) ! .. de rijk's pivoting - q = stdlib_iqamax( n-p+1, sva( p ), 1 ) + p - 1 + q = stdlib_i${ri}$amax( n-p+1, sva( p ), 1 ) + p - 1 if( p/=q ) then - call stdlib_qswap( m, a( 1, p ), 1, a( 1, q ), 1 ) - if( rsvec )call stdlib_qswap( mvl, v( 1, p ), 1,v( 1, q ), 1 ) + call stdlib_${ri}$swap( m, a( 1, p ), 1, a( 1, q ), 1 ) + if( rsvec )call stdlib_${ri}$swap( mvl, v( 1, p ), 1,v( 1, q ), 1 ) temp1 = sva( p ) sva( p ) = sva( q ) sva( q ) = temp1 @@ -19927,20 +19928,20 @@ module stdlib_linalg_lapack_q ! column norms are periodically updated by explicit ! norm computation. ! caveat: - ! some blas implementations compute stdlib_qnrm2(m,a(1,p),1) - ! as sqrt(stdlib_qdot(m,a(1,p),1,a(1,p),1)), which may result in + ! some blas implementations compute stdlib_${ri}$nrm2(m,a(1,p),1) + ! as sqrt(stdlib_${ri}$dot(m,a(1,p),1,a(1,p),1)), which may result in ! overflow for ||a(:,p)||_2 > sqrt(overflow_threshold), and ! underflow for ||a(:,p)||_2 < sqrt(underflow_threshold). - ! hence, stdlib_qnrm2 cannot be trusted, not even in the case when + ! hence, stdlib_${ri}$nrm2 cannot be trusted, not even in the case when ! the true norm is far from the under(over)flow boundaries. - ! if properly implemented stdlib_qnrm2 is available, the if-then-else - ! below should read "aapp = stdlib_qnrm2( m, a(1,p), 1 ) * d(p)". + ! if properly implemented stdlib_${ri}$nrm2 is available, the if-then-else + ! below should read "aapp = stdlib_${ri}$nrm2( m, a(1,p), 1 ) * d(p)". if( ( sva( p )rootsfmin ) ) then - sva( p ) = stdlib_qnrm2( m, a( 1, p ), 1 )*d( p ) + sva( p ) = stdlib_${ri}$nrm2( m, a( 1, p ), 1 )*d( p ) else temp1 = zero aapp = one - call stdlib_qlassq( m, a( 1, p ), 1, temp1, aapp ) + call stdlib_${ri}$lassq( m, a( 1, p ), 1, temp1, aapp ) sva( p ) = temp1*sqrt( aapp )*d( p ) end if aapp = sva( p ) @@ -19956,25 +19957,25 @@ module stdlib_linalg_lapack_q if( aaqq>=one ) then rotok = ( small*aapp )<=aaqq if( aapp<( big / aaqq ) ) then - aapq = ( stdlib_qdot( m, a( 1, p ), 1, a( 1,q ), 1 )*d( p )& + aapq = ( stdlib_${ri}$dot( m, a( 1, p ), 1, a( 1,q ), 1 )*d( p )& *d( q ) / aaqq )/ aapp else - call stdlib_qcopy( m, a( 1, p ), 1, work, 1 ) - call stdlib_qlascl( 'G', 0, 0, aapp, d( p ),m, 1, work, lda,& + call stdlib_${ri}$copy( m, a( 1, p ), 1, work, 1 ) + call stdlib_${ri}$lascl( 'G', 0, 0, aapp, d( p ),m, 1, work, lda,& ierr ) - aapq = stdlib_qdot( m, work, 1, a( 1, q ),1 )*d( q ) / & + aapq = stdlib_${ri}$dot( m, work, 1, a( 1, q ),1 )*d( q ) / & aaqq end if else rotok = aapp<=( aaqq / small ) if( aapp>( small / aaqq ) ) then - aapq = ( stdlib_qdot( m, a( 1, p ), 1, a( 1,q ), 1 )*d( p )& + aapq = ( stdlib_${ri}$dot( m, a( 1, p ), 1, a( 1,q ), 1 )*d( p )& *d( q ) / aaqq )/ aapp else - call stdlib_qcopy( m, a( 1, q ), 1, work, 1 ) - call stdlib_qlascl( 'G', 0, 0, aaqq, d( q ),m, 1, work, lda,& + call stdlib_${ri}$copy( m, a( 1, q ), 1, work, 1 ) + call stdlib_${ri}$lascl( 'G', 0, 0, aaqq, d( q ),m, 1, work, lda,& ierr ) - aapq = stdlib_qdot( m, work, 1, a( 1, p ),1 )*d( p ) / & + aapq = stdlib_${ri}$dot( m, work, 1, a( 1, p ),1 )*d( p ) / & aapp end if end if @@ -19996,9 +19997,9 @@ module stdlib_linalg_lapack_q t = half / theta fastr( 3 ) = t*d( p ) / d( q ) fastr( 4 ) = -t*d( q ) / d( p ) - call stdlib_qrotm( m, a( 1, p ), 1,a( 1, q ), 1, fastr ) + call stdlib_${ri}$rotm( m, a( 1, p ), 1,a( 1, q ), 1, fastr ) - if( rsvec )call stdlib_qrotm( mvl,v( 1, p ), 1,v( 1, q ),& + if( rsvec )call stdlib_${ri}$rotm( mvl,v( 1, p ), 1,v( 1, q ),& 1,fastr ) sva( q ) = aaqq*sqrt( max( zero,one+t*apoaq*aapq ) ) @@ -20023,63 +20024,63 @@ module stdlib_linalg_lapack_q fastr( 4 ) = -t*aqoap d( p ) = d( p )*cs d( q ) = d( q )*cs - call stdlib_qrotm( m, a( 1, p ), 1,a( 1, q ), 1,& + call stdlib_${ri}$rotm( m, a( 1, p ), 1,a( 1, q ), 1,& fastr ) - if( rsvec )call stdlib_qrotm( mvl,v( 1, p ), 1, v( & + if( rsvec )call stdlib_${ri}$rotm( mvl,v( 1, p ), 1, v( & 1, q ),1, fastr ) else - call stdlib_qaxpy( m, -t*aqoap,a( 1, q ), 1,a( 1, & + call stdlib_${ri}$axpy( m, -t*aqoap,a( 1, q ), 1,a( 1, & p ), 1 ) - call stdlib_qaxpy( m, cs*sn*apoaq,a( 1, p ), 1,a( & + call stdlib_${ri}$axpy( m, cs*sn*apoaq,a( 1, p ), 1,a( & 1, q ), 1 ) d( p ) = d( p )*cs d( q ) = d( q ) / cs if( rsvec ) then - call stdlib_qaxpy( mvl, -t*aqoap,v( 1, q ), 1,v(& + call stdlib_${ri}$axpy( mvl, -t*aqoap,v( 1, q ), 1,v(& 1, p ), 1 ) - call stdlib_qaxpy( mvl,cs*sn*apoaq,v( 1, p ), 1,& + call stdlib_${ri}$axpy( mvl,cs*sn*apoaq,v( 1, p ), 1,& v( 1, q ), 1 ) end if end if else if( d( q )>=one ) then - call stdlib_qaxpy( m, t*apoaq,a( 1, p ), 1,a( 1, q & + call stdlib_${ri}$axpy( m, t*apoaq,a( 1, p ), 1,a( 1, q & ), 1 ) - call stdlib_qaxpy( m, -cs*sn*aqoap,a( 1, q ), 1,a( & + call stdlib_${ri}$axpy( m, -cs*sn*aqoap,a( 1, q ), 1,a( & 1, p ), 1 ) d( p ) = d( p ) / cs d( q ) = d( q )*cs if( rsvec ) then - call stdlib_qaxpy( mvl, t*apoaq,v( 1, p ), 1,v( & + call stdlib_${ri}$axpy( mvl, t*apoaq,v( 1, p ), 1,v( & 1, q ), 1 ) - call stdlib_qaxpy( mvl,-cs*sn*aqoap,v( 1, q ), & + call stdlib_${ri}$axpy( mvl,-cs*sn*aqoap,v( 1, q ), & 1,v( 1, p ), 1 ) end if else if( d( p )>=d( q ) ) then - call stdlib_qaxpy( m, -t*aqoap,a( 1, q ), 1,a( & + call stdlib_${ri}$axpy( m, -t*aqoap,a( 1, q ), 1,a( & 1, p ), 1 ) - call stdlib_qaxpy( m, cs*sn*apoaq,a( 1, p ), 1,& + call stdlib_${ri}$axpy( m, cs*sn*apoaq,a( 1, p ), 1,& a( 1, q ), 1 ) d( p ) = d( p )*cs d( q ) = d( q ) / cs if( rsvec ) then - call stdlib_qaxpy( mvl,-t*aqoap,v( 1, q ), 1,& + call stdlib_${ri}$axpy( mvl,-t*aqoap,v( 1, q ), 1,& v( 1, p ), 1 ) - call stdlib_qaxpy( mvl,cs*sn*apoaq,v( 1, p ),& + call stdlib_${ri}$axpy( mvl,cs*sn*apoaq,v( 1, p ),& 1,v( 1, q ), 1 ) end if else - call stdlib_qaxpy( m, t*apoaq,a( 1, p ), 1,a( 1,& + call stdlib_${ri}$axpy( m, t*apoaq,a( 1, p ), 1,a( 1,& q ), 1 ) - call stdlib_qaxpy( m,-cs*sn*aqoap,a( 1, q ), 1,& + call stdlib_${ri}$axpy( m,-cs*sn*aqoap,a( 1, q ), 1,& a( 1, p ), 1 ) d( p ) = d( p ) / cs d( q ) = d( q )*cs if( rsvec ) then - call stdlib_qaxpy( mvl,t*apoaq, v( 1, p ),1, & + call stdlib_${ri}$axpy( mvl,t*apoaq, v( 1, p ),1, & v( 1, q ), 1 ) - call stdlib_qaxpy( mvl,-cs*sn*aqoap,v( 1, q )& + call stdlib_${ri}$axpy( mvl,-cs*sn*aqoap,v( 1, q )& , 1,v( 1, p ), 1 ) end if end if @@ -20088,14 +20089,14 @@ module stdlib_linalg_lapack_q end if else ! .. have to use modified gram-schmidt like transformation - call stdlib_qcopy( m, a( 1, p ), 1, work, 1 ) - call stdlib_qlascl( 'G', 0, 0, aapp, one, m,1, work, lda, & + call stdlib_${ri}$copy( m, a( 1, p ), 1, work, 1 ) + call stdlib_${ri}$lascl( 'G', 0, 0, aapp, one, m,1, work, lda, & ierr ) - call stdlib_qlascl( 'G', 0, 0, aaqq, one, m,1, a( 1, q ), & + call stdlib_${ri}$lascl( 'G', 0, 0, aaqq, one, m,1, a( 1, q ), & lda, ierr ) temp1 = -aapq*d( p ) / d( q ) - call stdlib_qaxpy( m, temp1, work, 1,a( 1, q ), 1 ) - call stdlib_qlascl( 'G', 0, 0, one, aaqq, m,1, a( 1, q ), & + call stdlib_${ri}$axpy( m, temp1, work, 1,a( 1, q ), 1 ) + call stdlib_${ri}$lascl( 'G', 0, 0, one, aaqq, m,1, a( 1, q ), & lda, ierr ) sva( q ) = aaqq*sqrt( max( zero,one-aapq*aapq ) ) mxsinj = max( mxsinj, sfmin ) @@ -20105,21 +20106,21 @@ module stdlib_linalg_lapack_q ! recompute sva(q), sva(p). if( ( sva( q ) / aaqq )**2<=rooteps )then if( ( aaqqrootsfmin ) ) then - sva( q ) = stdlib_qnrm2( m, a( 1, q ), 1 )*d( q ) + sva( q ) = stdlib_${ri}$nrm2( m, a( 1, q ), 1 )*d( q ) else t = zero aaqq = one - call stdlib_qlassq( m, a( 1, q ), 1, t,aaqq ) + call stdlib_${ri}$lassq( m, a( 1, q ), 1, t,aaqq ) sva( q ) = t*sqrt( aaqq )*d( q ) end if end if if( ( aapp / aapp0 )<=rooteps ) then if( ( aapprootsfmin ) ) then - aapp = stdlib_qnrm2( m, a( 1, p ), 1 )*d( p ) + aapp = stdlib_${ri}$nrm2( m, a( 1, p ), 1 )*d( p ) else t = zero aapp = one - call stdlib_qlassq( m, a( 1, p ), 1, t,aapp ) + call stdlib_${ri}$lassq( m, a( 1, p ), 1, t,aapp ) aapp = t*sqrt( aapp )*d( p ) end if sva( p ) = aapp @@ -20178,13 +20179,13 @@ module stdlib_linalg_lapack_q rotok = ( small*aaqq )<=aapp end if if( aapp<( big / aaqq ) ) then - aapq = ( stdlib_qdot( m, a( 1, p ), 1, a( 1,q ), 1 )*d( p )& + aapq = ( stdlib_${ri}$dot( m, a( 1, p ), 1, a( 1,q ), 1 )*d( p )& *d( q ) / aaqq )/ aapp else - call stdlib_qcopy( m, a( 1, p ), 1, work, 1 ) - call stdlib_qlascl( 'G', 0, 0, aapp, d( p ),m, 1, work, lda,& + call stdlib_${ri}$copy( m, a( 1, p ), 1, work, 1 ) + call stdlib_${ri}$lascl( 'G', 0, 0, aapp, d( p ),m, 1, work, lda,& ierr ) - aapq = stdlib_qdot( m, work, 1, a( 1, q ),1 )*d( q ) / & + aapq = stdlib_${ri}$dot( m, work, 1, a( 1, q ),1 )*d( q ) / & aaqq end if else @@ -20194,13 +20195,13 @@ module stdlib_linalg_lapack_q rotok = aaqq<=( aapp / small ) end if if( aapp>( small / aaqq ) ) then - aapq = ( stdlib_qdot( m, a( 1, p ), 1, a( 1,q ), 1 )*d( p )& + aapq = ( stdlib_${ri}$dot( m, a( 1, p ), 1, a( 1,q ), 1 )*d( p )& *d( q ) / aaqq )/ aapp else - call stdlib_qcopy( m, a( 1, q ), 1, work, 1 ) - call stdlib_qlascl( 'G', 0, 0, aaqq, d( q ),m, 1, work, lda,& + call stdlib_${ri}$copy( m, a( 1, q ), 1, work, 1 ) + call stdlib_${ri}$lascl( 'G', 0, 0, aaqq, d( q ),m, 1, work, lda,& ierr ) - aapq = stdlib_qdot( m, work, 1, a( 1, p ),1 )*d( p ) / & + aapq = stdlib_${ri}$dot( m, work, 1, a( 1, p ),1 )*d( p ) / & aapp end if end if @@ -20220,9 +20221,9 @@ module stdlib_linalg_lapack_q t = half / theta fastr( 3 ) = t*d( p ) / d( q ) fastr( 4 ) = -t*d( q ) / d( p ) - call stdlib_qrotm( m, a( 1, p ), 1,a( 1, q ), 1, fastr ) + call stdlib_${ri}$rotm( m, a( 1, p ), 1,a( 1, q ), 1, fastr ) - if( rsvec )call stdlib_qrotm( mvl,v( 1, p ), 1,v( 1, q ),& + if( rsvec )call stdlib_${ri}$rotm( mvl,v( 1, p ), 1,v( 1, q ),& 1,fastr ) sva( q ) = aaqq*sqrt( max( zero,one+t*apoaq*aapq ) ) @@ -20248,19 +20249,19 @@ module stdlib_linalg_lapack_q fastr( 4 ) = -t*aqoap d( p ) = d( p )*cs d( q ) = d( q )*cs - call stdlib_qrotm( m, a( 1, p ), 1,a( 1, q ), 1,& + call stdlib_${ri}$rotm( m, a( 1, p ), 1,a( 1, q ), 1,& fastr ) - if( rsvec )call stdlib_qrotm( mvl,v( 1, p ), 1, v( & + if( rsvec )call stdlib_${ri}$rotm( mvl,v( 1, p ), 1, v( & 1, q ),1, fastr ) else - call stdlib_qaxpy( m, -t*aqoap,a( 1, q ), 1,a( 1, & + call stdlib_${ri}$axpy( m, -t*aqoap,a( 1, q ), 1,a( 1, & p ), 1 ) - call stdlib_qaxpy( m, cs*sn*apoaq,a( 1, p ), 1,a( & + call stdlib_${ri}$axpy( m, cs*sn*apoaq,a( 1, p ), 1,a( & 1, q ), 1 ) if( rsvec ) then - call stdlib_qaxpy( mvl, -t*aqoap,v( 1, q ), 1,v(& + call stdlib_${ri}$axpy( mvl, -t*aqoap,v( 1, q ), 1,v(& 1, p ), 1 ) - call stdlib_qaxpy( mvl,cs*sn*apoaq,v( 1, p ), 1,& + call stdlib_${ri}$axpy( mvl,cs*sn*apoaq,v( 1, p ), 1,& v( 1, q ), 1 ) end if d( p ) = d( p )*cs @@ -20268,43 +20269,43 @@ module stdlib_linalg_lapack_q end if else if( d( q )>=one ) then - call stdlib_qaxpy( m, t*apoaq,a( 1, p ), 1,a( 1, q & + call stdlib_${ri}$axpy( m, t*apoaq,a( 1, p ), 1,a( 1, q & ), 1 ) - call stdlib_qaxpy( m, -cs*sn*aqoap,a( 1, q ), 1,a( & + call stdlib_${ri}$axpy( m, -cs*sn*aqoap,a( 1, q ), 1,a( & 1, p ), 1 ) if( rsvec ) then - call stdlib_qaxpy( mvl, t*apoaq,v( 1, p ), 1,v( & + call stdlib_${ri}$axpy( mvl, t*apoaq,v( 1, p ), 1,v( & 1, q ), 1 ) - call stdlib_qaxpy( mvl,-cs*sn*aqoap,v( 1, q ), & + call stdlib_${ri}$axpy( mvl,-cs*sn*aqoap,v( 1, q ), & 1,v( 1, p ), 1 ) end if d( p ) = d( p ) / cs d( q ) = d( q )*cs else if( d( p )>=d( q ) ) then - call stdlib_qaxpy( m, -t*aqoap,a( 1, q ), 1,a( & + call stdlib_${ri}$axpy( m, -t*aqoap,a( 1, q ), 1,a( & 1, p ), 1 ) - call stdlib_qaxpy( m, cs*sn*apoaq,a( 1, p ), 1,& + call stdlib_${ri}$axpy( m, cs*sn*apoaq,a( 1, p ), 1,& a( 1, q ), 1 ) d( p ) = d( p )*cs d( q ) = d( q ) / cs if( rsvec ) then - call stdlib_qaxpy( mvl,-t*aqoap,v( 1, q ), 1,& + call stdlib_${ri}$axpy( mvl,-t*aqoap,v( 1, q ), 1,& v( 1, p ), 1 ) - call stdlib_qaxpy( mvl,cs*sn*apoaq,v( 1, p ),& + call stdlib_${ri}$axpy( mvl,cs*sn*apoaq,v( 1, p ),& 1,v( 1, q ), 1 ) end if else - call stdlib_qaxpy( m, t*apoaq,a( 1, p ), 1,a( 1,& + call stdlib_${ri}$axpy( m, t*apoaq,a( 1, p ), 1,a( 1,& q ), 1 ) - call stdlib_qaxpy( m,-cs*sn*aqoap,a( 1, q ), 1,& + call stdlib_${ri}$axpy( m,-cs*sn*aqoap,a( 1, q ), 1,& a( 1, p ), 1 ) d( p ) = d( p ) / cs d( q ) = d( q )*cs if( rsvec ) then - call stdlib_qaxpy( mvl,t*apoaq, v( 1, p ),1, & + call stdlib_${ri}$axpy( mvl,t*apoaq, v( 1, p ),1, & v( 1, q ), 1 ) - call stdlib_qaxpy( mvl,-cs*sn*aqoap,v( 1, q )& + call stdlib_${ri}$axpy( mvl,-cs*sn*aqoap,v( 1, q )& , 1,v( 1, p ), 1 ) end if end if @@ -20313,28 +20314,28 @@ module stdlib_linalg_lapack_q end if else if( aapp>aaqq ) then - call stdlib_qcopy( m, a( 1, p ), 1, work,1 ) - call stdlib_qlascl( 'G', 0, 0, aapp, one,m, 1, work, lda,& + call stdlib_${ri}$copy( m, a( 1, p ), 1, work,1 ) + call stdlib_${ri}$lascl( 'G', 0, 0, aapp, one,m, 1, work, lda,& ierr ) - call stdlib_qlascl( 'G', 0, 0, aaqq, one,m, 1, a( 1, q ),& + call stdlib_${ri}$lascl( 'G', 0, 0, aaqq, one,m, 1, a( 1, q ),& lda,ierr ) temp1 = -aapq*d( p ) / d( q ) - call stdlib_qaxpy( m, temp1, work, 1,a( 1, q ), 1 ) + call stdlib_${ri}$axpy( m, temp1, work, 1,a( 1, q ), 1 ) - call stdlib_qlascl( 'G', 0, 0, one, aaqq,m, 1, a( 1, q ),& + call stdlib_${ri}$lascl( 'G', 0, 0, one, aaqq,m, 1, a( 1, q ),& lda,ierr ) sva( q ) = aaqq*sqrt( max( zero,one-aapq*aapq ) ) mxsinj = max( mxsinj, sfmin ) else - call stdlib_qcopy( m, a( 1, q ), 1, work,1 ) - call stdlib_qlascl( 'G', 0, 0, aaqq, one,m, 1, work, lda,& + call stdlib_${ri}$copy( m, a( 1, q ), 1, work,1 ) + call stdlib_${ri}$lascl( 'G', 0, 0, aaqq, one,m, 1, work, lda,& ierr ) - call stdlib_qlascl( 'G', 0, 0, aapp, one,m, 1, a( 1, p ),& + call stdlib_${ri}$lascl( 'G', 0, 0, aapp, one,m, 1, a( 1, p ),& lda,ierr ) temp1 = -aapq*d( q ) / d( p ) - call stdlib_qaxpy( m, temp1, work, 1,a( 1, p ), 1 ) + call stdlib_${ri}$axpy( m, temp1, work, 1,a( 1, p ), 1 ) - call stdlib_qlascl( 'G', 0, 0, one, aapp,m, 1, a( 1, p ),& + call stdlib_${ri}$lascl( 'G', 0, 0, one, aapp,m, 1, a( 1, p ),& lda,ierr ) sva( p ) = aapp*sqrt( max( zero,one-aapq*aapq ) ) mxsinj = max( mxsinj, sfmin ) @@ -20345,21 +20346,21 @@ module stdlib_linalg_lapack_q ! .. recompute sva(q) if( ( sva( q ) / aaqq )**2<=rooteps )then if( ( aaqqrootsfmin ) ) then - sva( q ) = stdlib_qnrm2( m, a( 1, q ), 1 )*d( q ) + sva( q ) = stdlib_${ri}$nrm2( m, a( 1, q ), 1 )*d( q ) else t = zero aaqq = one - call stdlib_qlassq( m, a( 1, q ), 1, t,aaqq ) + call stdlib_${ri}$lassq( m, a( 1, q ), 1, t,aaqq ) sva( q ) = t*sqrt( aaqq )*d( q ) end if end if if( ( aapp / aapp0 )**2<=rooteps ) then if( ( aapprootsfmin ) ) then - aapp = stdlib_qnrm2( m, a( 1, p ), 1 )*d( p ) + aapp = stdlib_${ri}$nrm2( m, a( 1, p ), 1 )*d( p ) else t = zero aapp = one - call stdlib_qlassq( m, a( 1, p ), 1, t,aapp ) + call stdlib_${ri}$lassq( m, a( 1, p ), 1, t,aapp ) aapp = t*sqrt( aapp )*d( p ) end if sva( p ) = aapp @@ -20406,16 +20407,16 @@ module stdlib_linalg_lapack_q ! 2000 :: end of the ibr-loop ! .. update sva(n) if( ( sva( n )rootsfmin ) )then - sva( n ) = stdlib_qnrm2( m, a( 1, n ), 1 )*d( n ) + sva( n ) = stdlib_${ri}$nrm2( m, a( 1, n ), 1 )*d( n ) else t = zero aapp = one - call stdlib_qlassq( m, a( 1, n ), 1, t, aapp ) + call stdlib_${ri}$lassq( m, a( 1, n ), 1, t, aapp ) sva( n ) = t*sqrt( aapp )*d( n ) end if ! additional steering devices if( ( iswband+1 ) .and. ( mxaapqswband+1 ) .and. ( mxaapq( small / aaqq ) ) then - aapq = ( stdlib_qdot( m, a( 1, p ), 1, a( 1,q ), 1 )*d( p )& + aapq = ( stdlib_${ri}$dot( m, a( 1, p ), 1, a( 1,q ), 1 )*d( p )& *d( q ) / aaqq )/ aapp else - call stdlib_qcopy( m, a( 1, q ), 1, work, 1 ) - call stdlib_qlascl( 'G', 0, 0, aaqq, d( q ),m, 1, work, lda,& + call stdlib_${ri}$copy( m, a( 1, q ), 1, work, 1 ) + call stdlib_${ri}$lascl( 'G', 0, 0, aaqq, d( q ),m, 1, work, lda,& ierr ) - aapq = stdlib_qdot( m, work, 1, a( 1, p ),1 )*d( p ) / & + aapq = stdlib_${ri}$dot( m, work, 1, a( 1, p ),1 )*d( p ) / & aapp end if end if @@ -20647,9 +20648,9 @@ module stdlib_linalg_lapack_q t = half / theta fastr( 3 ) = t*d( p ) / d( q ) fastr( 4 ) = -t*d( q ) / d( p ) - call stdlib_qrotm( m, a( 1, p ), 1,a( 1, q ), 1, fastr ) + call stdlib_${ri}$rotm( m, a( 1, p ), 1,a( 1, q ), 1, fastr ) - if( rsvec )call stdlib_qrotm( mvl,v( 1, p ), 1,v( 1, q ),& + if( rsvec )call stdlib_${ri}$rotm( mvl,v( 1, p ), 1,v( 1, q ),& 1,fastr ) sva( q ) = aaqq*sqrt( max( zero,one+t*apoaq*aapq ) ) @@ -20675,19 +20676,19 @@ module stdlib_linalg_lapack_q fastr( 4 ) = -t*aqoap d( p ) = d( p )*cs d( q ) = d( q )*cs - call stdlib_qrotm( m, a( 1, p ), 1,a( 1, q ), 1,& + call stdlib_${ri}$rotm( m, a( 1, p ), 1,a( 1, q ), 1,& fastr ) - if( rsvec )call stdlib_qrotm( mvl,v( 1, p ), 1, v( & + if( rsvec )call stdlib_${ri}$rotm( mvl,v( 1, p ), 1, v( & 1, q ),1, fastr ) else - call stdlib_qaxpy( m, -t*aqoap,a( 1, q ), 1,a( 1, & + call stdlib_${ri}$axpy( m, -t*aqoap,a( 1, q ), 1,a( 1, & p ), 1 ) - call stdlib_qaxpy( m, cs*sn*apoaq,a( 1, p ), 1,a( & + call stdlib_${ri}$axpy( m, cs*sn*apoaq,a( 1, p ), 1,a( & 1, q ), 1 ) if( rsvec ) then - call stdlib_qaxpy( mvl, -t*aqoap,v( 1, q ), 1,v(& + call stdlib_${ri}$axpy( mvl, -t*aqoap,v( 1, q ), 1,v(& 1, p ), 1 ) - call stdlib_qaxpy( mvl,cs*sn*apoaq,v( 1, p ), 1,& + call stdlib_${ri}$axpy( mvl,cs*sn*apoaq,v( 1, p ), 1,& v( 1, q ), 1 ) end if d( p ) = d( p )*cs @@ -20695,43 +20696,43 @@ module stdlib_linalg_lapack_q end if else if( d( q )>=one ) then - call stdlib_qaxpy( m, t*apoaq,a( 1, p ), 1,a( 1, q & + call stdlib_${ri}$axpy( m, t*apoaq,a( 1, p ), 1,a( 1, q & ), 1 ) - call stdlib_qaxpy( m, -cs*sn*aqoap,a( 1, q ), 1,a( & + call stdlib_${ri}$axpy( m, -cs*sn*aqoap,a( 1, q ), 1,a( & 1, p ), 1 ) if( rsvec ) then - call stdlib_qaxpy( mvl, t*apoaq,v( 1, p ), 1,v( & + call stdlib_${ri}$axpy( mvl, t*apoaq,v( 1, p ), 1,v( & 1, q ), 1 ) - call stdlib_qaxpy( mvl,-cs*sn*aqoap,v( 1, q ), & + call stdlib_${ri}$axpy( mvl,-cs*sn*aqoap,v( 1, q ), & 1,v( 1, p ), 1 ) end if d( p ) = d( p ) / cs d( q ) = d( q )*cs else if( d( p )>=d( q ) ) then - call stdlib_qaxpy( m, -t*aqoap,a( 1, q ), 1,a( & + call stdlib_${ri}$axpy( m, -t*aqoap,a( 1, q ), 1,a( & 1, p ), 1 ) - call stdlib_qaxpy( m, cs*sn*apoaq,a( 1, p ), 1,& + call stdlib_${ri}$axpy( m, cs*sn*apoaq,a( 1, p ), 1,& a( 1, q ), 1 ) d( p ) = d( p )*cs d( q ) = d( q ) / cs if( rsvec ) then - call stdlib_qaxpy( mvl,-t*aqoap,v( 1, q ), 1,& + call stdlib_${ri}$axpy( mvl,-t*aqoap,v( 1, q ), 1,& v( 1, p ), 1 ) - call stdlib_qaxpy( mvl,cs*sn*apoaq,v( 1, p ),& + call stdlib_${ri}$axpy( mvl,cs*sn*apoaq,v( 1, p ),& 1,v( 1, q ), 1 ) end if else - call stdlib_qaxpy( m, t*apoaq,a( 1, p ), 1,a( 1,& + call stdlib_${ri}$axpy( m, t*apoaq,a( 1, p ), 1,a( 1,& q ), 1 ) - call stdlib_qaxpy( m,-cs*sn*aqoap,a( 1, q ), 1,& + call stdlib_${ri}$axpy( m,-cs*sn*aqoap,a( 1, q ), 1,& a( 1, p ), 1 ) d( p ) = d( p ) / cs d( q ) = d( q )*cs if( rsvec ) then - call stdlib_qaxpy( mvl,t*apoaq, v( 1, p ),1, & + call stdlib_${ri}$axpy( mvl,t*apoaq, v( 1, p ),1, & v( 1, q ), 1 ) - call stdlib_qaxpy( mvl,-cs*sn*aqoap,v( 1, q )& + call stdlib_${ri}$axpy( mvl,-cs*sn*aqoap,v( 1, q )& , 1,v( 1, p ), 1 ) end if end if @@ -20740,28 +20741,28 @@ module stdlib_linalg_lapack_q end if else if( aapp>aaqq ) then - call stdlib_qcopy( m, a( 1, p ), 1, work,1 ) - call stdlib_qlascl( 'G', 0, 0, aapp, one,m, 1, work, lda,& + call stdlib_${ri}$copy( m, a( 1, p ), 1, work,1 ) + call stdlib_${ri}$lascl( 'G', 0, 0, aapp, one,m, 1, work, lda,& ierr ) - call stdlib_qlascl( 'G', 0, 0, aaqq, one,m, 1, a( 1, q ),& + call stdlib_${ri}$lascl( 'G', 0, 0, aaqq, one,m, 1, a( 1, q ),& lda,ierr ) temp1 = -aapq*d( p ) / d( q ) - call stdlib_qaxpy( m, temp1, work, 1,a( 1, q ), 1 ) + call stdlib_${ri}$axpy( m, temp1, work, 1,a( 1, q ), 1 ) - call stdlib_qlascl( 'G', 0, 0, one, aaqq,m, 1, a( 1, q ),& + call stdlib_${ri}$lascl( 'G', 0, 0, one, aaqq,m, 1, a( 1, q ),& lda,ierr ) sva( q ) = aaqq*sqrt( max( zero,one-aapq*aapq ) ) mxsinj = max( mxsinj, sfmin ) else - call stdlib_qcopy( m, a( 1, q ), 1, work,1 ) - call stdlib_qlascl( 'G', 0, 0, aaqq, one,m, 1, work, lda,& + call stdlib_${ri}$copy( m, a( 1, q ), 1, work,1 ) + call stdlib_${ri}$lascl( 'G', 0, 0, aaqq, one,m, 1, work, lda,& ierr ) - call stdlib_qlascl( 'G', 0, 0, aapp, one,m, 1, a( 1, p ),& + call stdlib_${ri}$lascl( 'G', 0, 0, aapp, one,m, 1, a( 1, p ),& lda,ierr ) temp1 = -aapq*d( q ) / d( p ) - call stdlib_qaxpy( m, temp1, work, 1,a( 1, p ), 1 ) + call stdlib_${ri}$axpy( m, temp1, work, 1,a( 1, p ), 1 ) - call stdlib_qlascl( 'G', 0, 0, one, aapp,m, 1, a( 1, p ),& + call stdlib_${ri}$lascl( 'G', 0, 0, one, aapp,m, 1, a( 1, p ),& lda,ierr ) sva( p ) = aapp*sqrt( max( zero,one-aapq*aapq ) ) mxsinj = max( mxsinj, sfmin ) @@ -20772,21 +20773,21 @@ module stdlib_linalg_lapack_q ! .. recompute sva(q) if( ( sva( q ) / aaqq )**2<=rooteps )then if( ( aaqqrootsfmin ) ) then - sva( q ) = stdlib_qnrm2( m, a( 1, q ), 1 )*d( q ) + sva( q ) = stdlib_${ri}$nrm2( m, a( 1, q ), 1 )*d( q ) else t = zero aaqq = one - call stdlib_qlassq( m, a( 1, q ), 1, t,aaqq ) + call stdlib_${ri}$lassq( m, a( 1, q ), 1, t,aaqq ) sva( q ) = t*sqrt( aaqq )*d( q ) end if end if if( ( aapp / aapp0 )**2<=rooteps ) then if( ( aapprootsfmin ) ) then - aapp = stdlib_qnrm2( m, a( 1, p ), 1 )*d( p ) + aapp = stdlib_${ri}$nrm2( m, a( 1, p ), 1 )*d( p ) else t = zero aapp = one - call stdlib_qlassq( m, a( 1, p ), 1, t,aapp ) + call stdlib_${ri}$lassq( m, a( 1, p ), 1, t,aapp ) aapp = t*sqrt( aapp )*d( p ) end if sva( p ) = aapp @@ -20837,16 +20838,16 @@ module stdlib_linalg_lapack_q ! 2000 :: end of the ibr-loop ! .. update sva(n) if( ( sva( n )rootsfmin ) )then - sva( n ) = stdlib_qnrm2( m, a( 1, n ), 1 )*d( n ) + sva( n ) = stdlib_${ri}$nrm2( m, a( 1, n ), 1 )*d( n ) else t = zero aapp = one - call stdlib_qlassq( m, a( 1, n ), 1, t, aapp ) + call stdlib_${ri}$lassq( m, a( 1, n ), 1, t, aapp ) sva( n ) = t*sqrt( aapp )*d( n ) end if ! additional steering devices if( ( iswband+1 ) .and. ( mxaapqswband+1 ) .and. ( mxaapqeps .and. two*berr( j )<=lstres .and.count<=itmax ) then ! update solution and try again. - call stdlib_qgttrs( trans, n, 1, dlf, df, duf, du2, ipiv,work( n+1 ), n, info ) + call stdlib_${ri}$gttrs( trans, n, 1, dlf, df, duf, du2, ipiv,work( n+1 ), n, info ) - call stdlib_qaxpy( n, one, work( n+1 ), 1, x( 1, j ), 1 ) + call stdlib_${ri}$axpy( n, one, work( n+1 ), 1, x( 1, j ), 1 ) lstres = berr( j ) count = count + 1 go to 20 @@ -21123,7 +21124,7 @@ module stdlib_linalg_lapack_q ! the i-th component of abs(r)+nz*eps*(abs(op(a))*abs(x)+abs(b)) ! is incremented by safe1 if the i-th component of ! abs(op(a))*abs(x) + abs(b) is less than safe2. - ! use stdlib_qlacn2 to estimate the infinity-norm of the matrix + ! use stdlib_${ri}$lacn2 to estimate the infinity-norm of the matrix ! inv(op(a)) * diag(w), ! where w = abs(r) + nz*eps*( abs(op(a))*abs(x)+abs(b) ))) do i = 1, n @@ -21135,12 +21136,12 @@ module stdlib_linalg_lapack_q end do kase = 0 70 continue - call stdlib_qlacn2( n, work( 2*n+1 ), work( n+1 ), iwork, ferr( j ),kase, isave ) + call stdlib_${ri}$lacn2( n, work( 2*n+1 ), work( n+1 ), iwork, ferr( j ),kase, isave ) if( kase/=0 ) then if( kase==1 ) then ! multiply by diag(w)*inv(op(a)**t). - call stdlib_qgttrs( transt, n, 1, dlf, df, duf, du2, ipiv,work( n+1 ), n, & + call stdlib_${ri}$gttrs( transt, n, 1, dlf, df, duf, du2, ipiv,work( n+1 ), n, & info ) do i = 1, n work( n+i ) = work( i )*work( n+i ) @@ -21150,7 +21151,7 @@ module stdlib_linalg_lapack_q do i = 1, n work( n+i ) = work( i )*work( n+i ) end do - call stdlib_qgttrs( transn, n, 1, dlf, df, duf, du2, ipiv,work( n+1 ), n, & + call stdlib_${ri}$gttrs( transn, n, 1, dlf, df, duf, du2, ipiv,work( n+1 ), n, & info ) end if go to 70 @@ -21163,10 +21164,10 @@ module stdlib_linalg_lapack_q if( lstres/=zero )ferr( j ) = ferr( j ) / lstres end do loop_110 return - end subroutine stdlib_qgtrfs + end subroutine stdlib_${ri}$gtrfs - pure subroutine stdlib_qgtsv( n, nrhs, dl, d, du, b, ldb, info ) + pure subroutine stdlib_${ri}$gtsv( n, nrhs, dl, d, du, b, ldb, info ) !! DGTSV: solves the equation !! A*X = B, !! where A is an n by n tridiagonal matrix, by Gaussian elimination with @@ -21180,12 +21181,12 @@ module stdlib_linalg_lapack_q integer(ilp), intent(out) :: info integer(ilp), intent(in) :: ldb, n, nrhs ! Array Arguments - real(qp), intent(inout) :: b(ldb,*), d(*), dl(*), du(*) + real(${rk}$), intent(inout) :: b(ldb,*), d(*), dl(*), du(*) ! ===================================================================== ! Local Scalars integer(ilp) :: i, j - real(qp) :: fact, temp + real(${rk}$) :: fact, temp ! Intrinsic Functions intrinsic :: abs,max ! Executable Statements @@ -21342,10 +21343,10 @@ module stdlib_linalg_lapack_q end do end if return - end subroutine stdlib_qgtsv + end subroutine stdlib_${ri}$gtsv - pure subroutine stdlib_qgtsvx( fact, trans, n, nrhs, dl, d, du, dlf, df, duf,du2, ipiv, b, & + pure subroutine stdlib_${ri}$gtsvx( fact, trans, n, nrhs, dl, d, du, dlf, df, duf,du2, ipiv, b, & !! DGTSVX: uses the LU factorization to compute the solution to a real !! system of linear equations A * X = B or A**T * X = B, !! where A is a tridiagonal matrix of order N and X and B are N-by-NRHS @@ -21360,19 +21361,19 @@ module stdlib_linalg_lapack_q character, intent(in) :: fact, trans integer(ilp), intent(out) :: info integer(ilp), intent(in) :: ldb, ldx, n, nrhs - real(qp), intent(out) :: rcond + real(${rk}$), intent(out) :: rcond ! Array Arguments integer(ilp), intent(inout) :: ipiv(*) integer(ilp), intent(out) :: iwork(*) - real(qp), intent(in) :: b(ldb,*), d(*), dl(*), du(*) - real(qp), intent(out) :: berr(*), ferr(*), work(*), x(ldx,*) - real(qp), intent(inout) :: df(*), dlf(*), du2(*), duf(*) + real(${rk}$), intent(in) :: b(ldb,*), d(*), dl(*), du(*) + real(${rk}$), intent(out) :: berr(*), ferr(*), work(*), x(ldx,*) + real(${rk}$), intent(inout) :: df(*), dlf(*), du2(*), duf(*) ! ===================================================================== ! Local Scalars logical(lk) :: nofact, notran character :: norm - real(qp) :: anorm + real(${rk}$) :: anorm ! Intrinsic Functions intrinsic :: max ! Executable Statements @@ -21399,12 +21400,12 @@ module stdlib_linalg_lapack_q end if if( nofact ) then ! compute the lu factorization of a. - call stdlib_qcopy( n, d, 1, df, 1 ) + call stdlib_${ri}$copy( n, d, 1, df, 1 ) if( n>1 ) then - call stdlib_qcopy( n-1, dl, 1, dlf, 1 ) - call stdlib_qcopy( n-1, du, 1, duf, 1 ) + call stdlib_${ri}$copy( n-1, dl, 1, dlf, 1 ) + call stdlib_${ri}$copy( n-1, du, 1, duf, 1 ) end if - call stdlib_qgttrf( n, dlf, df, duf, du2, ipiv, info ) + call stdlib_${ri}$gttrf( n, dlf, df, duf, du2, ipiv, info ) ! return if info is non-zero. if( info>0 )then rcond = zero @@ -21417,24 +21418,24 @@ module stdlib_linalg_lapack_q else norm = 'I' end if - anorm = stdlib_qlangt( norm, n, dl, d, du ) + anorm = stdlib_${ri}$langt( norm, n, dl, d, du ) ! compute the reciprocal of the condition number of a. - call stdlib_qgtcon( norm, n, dlf, df, duf, du2, ipiv, anorm, rcond, work,iwork, info ) + call stdlib_${ri}$gtcon( norm, n, dlf, df, duf, du2, ipiv, anorm, rcond, work,iwork, info ) ! compute the solution vectors x. - call stdlib_qlacpy( 'FULL', n, nrhs, b, ldb, x, ldx ) - call stdlib_qgttrs( trans, n, nrhs, dlf, df, duf, du2, ipiv, x, ldx,info ) + call stdlib_${ri}$lacpy( 'FULL', n, nrhs, b, ldb, x, ldx ) + call stdlib_${ri}$gttrs( trans, n, nrhs, dlf, df, duf, du2, ipiv, x, ldx,info ) ! use iterative refinement to improve the computed solutions and ! compute error bounds and backward error estimates for them. - call stdlib_qgtrfs( trans, n, nrhs, dl, d, du, dlf, df, duf, du2, ipiv,b, ldb, x, ldx, & + call stdlib_${ri}$gtrfs( trans, n, nrhs, dl, d, du, dlf, df, duf, du2, ipiv,b, ldb, x, ldx, & ferr, berr, work, iwork, info ) ! set info = n+1 if the matrix is singular to working precision. - if( rcond=nrhs ) then - call stdlib_qgtts2( itrans, n, nrhs, dl, d, du, du2, ipiv, b, ldb ) + call stdlib_${ri}$gtts2( itrans, n, nrhs, dl, d, du, du2, ipiv, b, ldb ) else do j = 1, nrhs, nb jb = min( nrhs-j+1, nb ) - call stdlib_qgtts2( itrans, n, jb, dl, d, du, du2, ipiv, b( 1, j ),ldb ) + call stdlib_${ri}$gtts2( itrans, n, jb, dl, d, du, du2, ipiv, b( 1, j ),ldb ) end do end if - end subroutine stdlib_qgttrs + end subroutine stdlib_${ri}$gttrs - pure subroutine stdlib_qgtts2( itrans, n, nrhs, dl, d, du, du2, ipiv, b, ldb ) + pure subroutine stdlib_${ri}$gtts2( itrans, n, nrhs, dl, d, du, du2, ipiv, b, ldb ) !! DGTTS2: solves one of the systems of equations !! A*X = B or A**T*X = B, !! with a tridiagonal matrix A using the LU factorization computed @@ -21602,12 +21603,12 @@ module stdlib_linalg_lapack_q integer(ilp), intent(in) :: itrans, ldb, n, nrhs ! Array Arguments integer(ilp), intent(in) :: ipiv(*) - real(qp), intent(inout) :: b(ldb,*) - real(qp), intent(in) :: d(*), dl(*), du(*), du2(*) + real(${rk}$), intent(inout) :: b(ldb,*) + real(${rk}$), intent(in) :: d(*), dl(*), du(*), du2(*) ! ===================================================================== ! Local Scalars integer(ilp) :: i, ip, j - real(qp) :: temp + real(${rk}$) :: temp ! Executable Statements ! quick return if possible if( n==0 .or. nrhs==0 )return @@ -21700,10 +21701,10 @@ module stdlib_linalg_lapack_q end do end if end if - end subroutine stdlib_qgtts2 + end subroutine stdlib_${ri}$gtts2 - subroutine stdlib_qhgeqz( job, compq, compz, n, ilo, ihi, h, ldh, t, ldt,alphar, alphai, & + subroutine stdlib_${ri}$hgeqz( job, compq, compz, n, ilo, ihi, h, ldh, t, ldt,alphar, alphai, & !! DHGEQZ: computes the eigenvalues of a real matrix pair (H,T), !! where H is an upper Hessenberg matrix and T is upper triangular, !! using the double-shift QZ method. @@ -21756,25 +21757,25 @@ module stdlib_linalg_lapack_q integer(ilp), intent(in) :: ihi, ilo, ldh, ldq, ldt, ldz, lwork, n integer(ilp), intent(out) :: info ! Array Arguments - real(qp), intent(out) :: alphai(*), alphar(*), beta(*), work(*) - real(qp), intent(inout) :: h(ldh,*), q(ldq,*), t(ldt,*), z(ldz,*) + real(${rk}$), intent(out) :: alphai(*), alphar(*), beta(*), work(*) + real(${rk}$), intent(inout) :: h(ldh,*), q(ldq,*), t(ldt,*), z(ldz,*) ! ===================================================================== ! Parameters - real(qp), parameter :: safety = 1.0e+2_qp + real(${rk}$), parameter :: safety = 1.0e+2_${rk}$ ! $ safety = one ) ! Local Scalars logical(lk) :: ilazr2, ilazro, ilpivt, ilq, ilschr, ilz, lquery integer(ilp) :: icompq, icompz, ifirst, ifrstm, iiter, ilast, ilastm, in, ischur, & istart, j, jc, jch, jiter, jr, maxit - real(qp) :: a11, a12, a1i, a1r, a21, a22, a2i, a2r, ad11, ad11l, ad12, ad12l, ad21, & + real(${rk}$) :: a11, a12, a1i, a1r, a21, a22, a2i, a2r, ad11, ad11l, ad12, ad12l, ad21, & ad21l, ad22, ad22l, ad32l, an, anorm, ascale, atol, b11, b1a, b1i, b1r, b22, b2a, b2i, & b2r, bn, bnorm, bscale, btol, c, c11i, c11r, c12, c21, c22i, c22r, cl, cq, cr, cz, & eshift, s, s1, s1inv, s2, safmax, safmin, scale, sl, sqi, sqr, sr, szi, szr, t1, tau, & temp, temp2, tempi, tempr, u1, u12, u12l, u2, ulp, vs, w11, w12, w21, w22, wabs, wi, & wr, wr2 ! Local Arrays - real(qp) :: v(3) + real(${rk}$) :: v(3) ! Intrinsic Functions intrinsic :: abs,real,max,min,sqrt ! Executable Statements @@ -21847,19 +21848,19 @@ module stdlib_linalg_lapack_q end if ! quick return if possible if( n<=0 ) then - work( 1 ) = real( 1,KIND=qp) + work( 1 ) = real( 1,KIND=${rk}$) return end if ! initialize q and z - if( icompq==3 )call stdlib_qlaset( 'FULL', n, n, zero, one, q, ldq ) - if( icompz==3 )call stdlib_qlaset( 'FULL', n, n, zero, one, z, ldz ) + if( icompq==3 )call stdlib_${ri}$laset( 'FULL', n, n, zero, one, q, ldq ) + if( icompz==3 )call stdlib_${ri}$laset( 'FULL', n, n, zero, one, z, ldz ) ! machine constants in = ihi + 1 - ilo - safmin = stdlib_qlamch( 'S' ) + safmin = stdlib_${ri}$lamch( 'S' ) safmax = one / safmin - ulp = stdlib_qlamch( 'E' )*stdlib_qlamch( 'B' ) - anorm = stdlib_qlanhs( 'F', in, h( ilo, ilo ), ldh, work ) - bnorm = stdlib_qlanhs( 'F', in, t( ilo, ilo ), ldt, work ) + ulp = stdlib_${ri}$lamch( 'E' )*stdlib_${ri}$lamch( 'B' ) + anorm = stdlib_${ri}$lanhs( 'F', in, h( ilo, ilo ), ldh, work ) + bnorm = stdlib_${ri}$lanhs( 'F', in, t( ilo, ilo ), ldt, work ) atol = max( safmin, ulp*anorm ) btol = max( safmin, ulp*bnorm ) ascale = one / max( safmin, anorm ) @@ -21970,13 +21971,13 @@ module stdlib_linalg_lapack_q if( ilazro .or. ilazr2 ) then do jch = j, ilast - 1 temp = h( jch, jch ) - call stdlib_qlartg( temp, h( jch+1, jch ), c, s,h( jch, jch ) ) + call stdlib_${ri}$lartg( temp, h( jch+1, jch ), c, s,h( jch, jch ) ) h( jch+1, jch ) = zero - call stdlib_qrot( ilastm-jch, h( jch, jch+1 ), ldh,h( jch+1, jch+1 ), & + call stdlib_${ri}$rot( ilastm-jch, h( jch, jch+1 ), ldh,h( jch+1, jch+1 ), & ldh, c, s ) - call stdlib_qrot( ilastm-jch, t( jch, jch+1 ), ldt,t( jch+1, jch+1 ), & + call stdlib_${ri}$rot( ilastm-jch, t( jch, jch+1 ), ldt,t( jch+1, jch+1 ), & ldt, c, s ) - if( ilq )call stdlib_qrot( n, q( 1, jch ), 1, q( 1, jch+1 ), 1,c, s ) + if( ilq )call stdlib_${ri}$rot( n, q( 1, jch ), 1, q( 1, jch+1 ), 1,c, s ) if( ilazr2 )h( jch, jch-1 ) = h( jch, jch-1 )*c ilazr2 = .false. @@ -21996,24 +21997,24 @@ module stdlib_linalg_lapack_q ! then process as in the case t(ilast,ilast)=0 do jch = j, ilast - 1 temp = t( jch, jch+1 ) - call stdlib_qlartg( temp, t( jch+1, jch+1 ), c, s,t( jch, jch+1 ) ) + call stdlib_${ri}$lartg( temp, t( jch+1, jch+1 ), c, s,t( jch, jch+1 ) ) t( jch+1, jch+1 ) = zero - if( jch abs( (wr2/s2)*t( & ilast, ilast )- h( ilast, ilast ) ) ) then @@ -22142,12 +22143,12 @@ module stdlib_linalg_lapack_q ! initial q temp = s1*h( istart, istart ) - wr*t( istart, istart ) temp2 = s1*h( istart+1, istart ) - call stdlib_qlartg( temp, temp2, c, s, tempr ) + call stdlib_${ri}$lartg( temp, temp2, c, s, tempr ) ! sweep loop_190: do j = istart, ilast - 1 if( j>istart ) then temp = h( j, j-1 ) - call stdlib_qlartg( temp, h( j+1, j-1 ), c, s, h( j, j-1 ) ) + call stdlib_${ri}$lartg( temp, h( j+1, j-1 ), c, s, h( j, j-1 ) ) h( j+1, j-1 ) = zero end if do jc = j, ilastm @@ -22166,7 +22167,7 @@ module stdlib_linalg_lapack_q end do end if temp = t( j+1, j+1 ) - call stdlib_qlartg( temp, t( j+1, j ), c, s, t( j+1, j+1 ) ) + call stdlib_${ri}$lartg( temp, t( j+1, j ), c, s, t( j+1, j+1 ) ) t( j+1, j ) = zero do jr = ifrstm, min( j+2, ilast ) temp = c*h( jr, j+1 ) + s*h( jr, j ) @@ -22199,7 +22200,7 @@ module stdlib_linalg_lapack_q ! ( b11 0 ) ! b = ( ) with b11 non-negative. ! ( 0 b22 ) - call stdlib_qlasv2( t( ilast-1, ilast-1 ), t( ilast-1, ilast ),t( ilast, ilast ),& + call stdlib_${ri}$lasv2( t( ilast-1, ilast-1 ), t( ilast-1, ilast ),t( ilast, ilast ),& b22, b11, sr, cr, sl, cl ) if( b11abs( c21 )+abs( c22r )+abs( c22i ) ) & then - t1 = stdlib_qlapy3( c12, c11r, c11i ) + t1 = stdlib_${ri}$lapy3( c12, c11r, c11i ) cz = c12 / t1 szr = -c11r / t1 szi = -c11i / t1 else - cz = stdlib_qlapy2( c22r, c22i ) + cz = stdlib_${ri}$lapy2( c22r, c22i ) if( cz<=safmin ) then cz = zero szr = one @@ -22275,7 +22276,7 @@ module stdlib_linalg_lapack_q else tempr = c22r / cz tempi = c22i / cz - t1 = stdlib_qlapy2( cz, c21 ) + t1 = stdlib_${ri}$lapy2( cz, c21 ) cz = cz / t1 szr = -c21*tempr / t1 szi = c21*tempi / t1 @@ -22297,7 +22298,7 @@ module stdlib_linalg_lapack_q a1i = szi*a12 a2r = cz*a21 + szr*a22 a2i = szi*a22 - cq = stdlib_qlapy2( a1r, a1i ) + cq = stdlib_${ri}$lapy2( a1r, a1i ) if( cq<=safmin ) then cq = zero sqr = one @@ -22309,7 +22310,7 @@ module stdlib_linalg_lapack_q sqi = tempi*a2r - tempr*a2i end if end if - t1 = stdlib_qlapy3( cq, sqr, sqi ) + t1 = stdlib_${ri}$lapy3( cq, sqr, sqi ) cq = cq / t1 sqr = sqr / t1 sqi = sqi / t1 @@ -22318,10 +22319,10 @@ module stdlib_linalg_lapack_q tempi = sqr*szi + sqi*szr b1r = cq*cz*b11 + tempr*b22 b1i = tempi*b22 - b1a = stdlib_qlapy2( b1r, b1i ) + b1a = stdlib_${ri}$lapy2( b1r, b1i ) b2r = cq*cz*b22 + tempr*b11 b2i = -tempi*b11 - b2a = stdlib_qlapy2( b2r, b2i ) + b2a = stdlib_${ri}$lapy2( b2r, b2i ) ! normalize so beta > 0, and im( alpha1 ) > 0 beta( ilast-1 ) = b1a beta( ilast ) = b2a @@ -22369,7 +22370,7 @@ module stdlib_linalg_lapack_q *ad21l v( 3 ) = ad32l*ad21l istart = ifirst - call stdlib_qlarfg( 3, v( 1 ), v( 2 ), 1, tau ) + call stdlib_${ri}$larfg( 3, v( 1 ), v( 2 ), 1, tau ) v( 1 ) = one ! sweep loop_290: do j = istart, ilast - 2 @@ -22379,7 +22380,7 @@ module stdlib_linalg_lapack_q v( 1 ) = h( j, j-1 ) v( 2 ) = h( j+1, j-1 ) v( 3 ) = h( j+2, j-1 ) - call stdlib_qlarfg( 3, h( j, j-1 ), v( 2 ), 1, tau ) + call stdlib_${ri}$larfg( 3, h( j, j-1 ), v( 2 ), 1, tau ) v( 1 ) = one h( j+1, j-1 ) = zero h( j+2, j-1 ) = zero @@ -22498,7 +22499,7 @@ module stdlib_linalg_lapack_q ! rotations from the left j = ilast - 1 temp = h( j, j-1 ) - call stdlib_qlartg( temp, h( j+1, j-1 ), c, s, h( j, j-1 ) ) + call stdlib_${ri}$lartg( temp, h( j+1, j-1 ), c, s, h( j, j-1 ) ) h( j+1, j-1 ) = zero do jc = j, ilastm temp = c*h( j, jc ) + s*h( j+1, jc ) @@ -22517,7 +22518,7 @@ module stdlib_linalg_lapack_q end if ! rotations from the right. temp = t( j+1, j+1 ) - call stdlib_qlartg( temp, t( j+1, j ), c, s, t( j+1, j+1 ) ) + call stdlib_${ri}$lartg( temp, t( j+1, j ), c, s, t( j+1, j+1 ) ) t( j+1, j ) = zero do jr = ifrstm, ilast temp = c*h( jr, j+1 ) + s*h( jr, j ) @@ -22573,12 +22574,12 @@ module stdlib_linalg_lapack_q info = 0 ! exit (other than argument error) -- return optimal workspace size 420 continue - work( 1 ) = real( n,KIND=qp) + work( 1 ) = real( n,KIND=${rk}$) return - end subroutine stdlib_qhgeqz + end subroutine stdlib_${ri}$hgeqz - subroutine stdlib_qhsein( side, eigsrc, initv, select, n, h, ldh, wr, wi,vl, ldvl, vr, ldvr, & + subroutine stdlib_${ri}$hsein( side, eigsrc, initv, select, n, h, ldh, wr, wi,vl, ldvl, vr, ldvr, & !! DHSEIN: uses inverse iteration to find specified right and/or left !! eigenvectors of a real upper Hessenberg matrix H. !! The right eigenvector x and the left eigenvector y of the matrix H @@ -22596,15 +22597,15 @@ module stdlib_linalg_lapack_q ! Array Arguments logical(lk), intent(inout) :: select(*) integer(ilp), intent(out) :: ifaill(*), ifailr(*) - real(qp), intent(in) :: h(ldh,*), wi(*) - real(qp), intent(inout) :: vl(ldvl,*), vr(ldvr,*), wr(*) - real(qp), intent(out) :: work(*) + real(${rk}$), intent(in) :: h(ldh,*), wi(*) + real(${rk}$), intent(inout) :: vl(ldvl,*), vr(ldvr,*), wr(*) + real(${rk}$), intent(out) :: work(*) ! ===================================================================== ! Local Scalars logical(lk) :: bothv, fromqr, leftv, noinit, pair, rightv integer(ilp) :: i, iinfo, k, kl, kln, kr, ksi, ksr, ldwork - real(qp) :: bignum, eps3, hnorm, smlnum, ulp, unfl, wki, wkr + real(${rk}$) :: bignum, eps3, hnorm, smlnum, ulp, unfl, wki, wkr ! Intrinsic Functions intrinsic :: abs,max ! Executable Statements @@ -22659,8 +22660,8 @@ module stdlib_linalg_lapack_q ! quick return if possible. if( n==0 )return ! set machine-dependent constants. - unfl = stdlib_qlamch( 'SAFE MINIMUM' ) - ulp = stdlib_qlamch( 'PRECISION' ) + unfl = stdlib_${ri}$lamch( 'SAFE MINIMUM' ) + ulp = stdlib_${ri}$lamch( 'PRECISION' ) smlnum = unfl*( n / ulp ) bignum = ( one-ulp ) / smlnum ldwork = n + 1 @@ -22701,8 +22702,8 @@ module stdlib_linalg_lapack_q kln = kl ! compute infinity-norm of submatrix h(kl:kr,kl:kr) if it ! has not ben computed before. - hnorm = stdlib_qlanhs( 'I', kr-kl+1, h( kl, kl ), ldh, work ) - if( stdlib_qisnan( hnorm ) ) then + hnorm = stdlib_${ri}$lanhs( 'I', kr-kl+1, h( kl, kl ), ldh, work ) + if( stdlib_${ri}$isnan( hnorm ) ) then info = -6 return else if( hnorm>zero ) then @@ -22733,7 +22734,7 @@ module stdlib_linalg_lapack_q end if if( leftv ) then ! compute left eigenvector. - call stdlib_qlaein( .false., noinit, n-kl+1, h( kl, kl ), ldh,wkr, wki, vl( & + call stdlib_${ri}$laein( .false., noinit, n-kl+1, h( kl, kl ), ldh,wkr, wki, vl( & kl, ksr ), vl( kl, ksi ),work, ldwork, work( n*n+n+1 ), eps3, smlnum,bignum, & iinfo ) if( iinfo>0 ) then @@ -22759,7 +22760,7 @@ module stdlib_linalg_lapack_q end if if( rightv ) then ! compute right eigenvector. - call stdlib_qlaein( .true., noinit, kr, h, ldh, wkr, wki,vr( 1, ksr ), vr( 1, & + call stdlib_${ri}$laein( .true., noinit, kr, h, ldh, wkr, wki,vr( 1, ksr ), vr( 1, & ksi ), work, ldwork,work( n*n+n+1 ), eps3, smlnum, bignum,iinfo ) if( iinfo>0 ) then if( pair ) then @@ -22790,10 +22791,10 @@ module stdlib_linalg_lapack_q end if end do loop_120 return - end subroutine stdlib_qhsein + end subroutine stdlib_${ri}$hsein - subroutine stdlib_qhseqr( job, compz, n, ilo, ihi, h, ldh, wr, wi, z,ldz, work, lwork, info ) + subroutine stdlib_${ri}$hseqr( job, compz, n, ilo, ihi, h, ldh, wr, wi, z,ldz, work, lwork, info ) !! DHSEQR: computes the eigenvalues of a Hessenberg matrix H !! and, optionally, the matrices T and Z from the Schur decomposition !! H = Z T Z**T, where T is an upper quasi-triangular matrix (the @@ -22811,18 +22812,18 @@ module stdlib_linalg_lapack_q integer(ilp), intent(out) :: info character, intent(in) :: compz, job ! Array Arguments - real(qp), intent(inout) :: h(ldh,*), z(ldz,*) - real(qp), intent(out) :: wi(*), work(*), wr(*) + real(${rk}$), intent(inout) :: h(ldh,*), z(ldz,*) + real(${rk}$), intent(out) :: wi(*), work(*), wr(*) ! ===================================================================== ! Parameters integer(ilp), parameter :: ntiny = 15 integer(ilp), parameter :: nl = 49 ! ==== matrices of order ntiny or smaller must be processed by - ! . stdlib_qlahqr because of insufficient subdiagonal scratch space. + ! . stdlib_${ri}$lahqr because of insufficient subdiagonal scratch space. ! . (this is a hard limit.) ==== ! ==== nl allocates some local workspace to help small matrices - ! . through a rare stdlib_qlahqr failure. nl > ntiny = 15 is + ! . through a rare stdlib_${ri}$lahqr failure. nl > ntiny = 15 is ! . required and nl <= nmin = stdlib_ilaenv(ispec=12,...) is recom- ! . mended. (the default value of nmin is 75.) using nl = 49 ! . allows up to six simultaneous shifts and a 16-by-16 @@ -22830,7 +22831,7 @@ module stdlib_linalg_lapack_q ! Local Arrays - real(qp) :: hl(nl,nl), workl(nl) + real(${rk}$) :: hl(nl,nl), workl(nl) ! Local Scalars integer(ilp) :: i, kbot, nmin logical(lk) :: initz, lquery, wantt, wantz @@ -22841,7 +22842,7 @@ module stdlib_linalg_lapack_q wantt = stdlib_lsame( job, 'S' ) initz = stdlib_lsame( compz, 'I' ) wantz = initz .or. stdlib_lsame( compz, 'V' ) - work( 1 ) = real( max( 1, n ),KIND=qp) + work( 1 ) = real( max( 1, n ),KIND=${rk}$) lquery = lwork==-1 info = 0 if( .not.stdlib_lsame( job, 'E' ) .and. .not.wantt ) then @@ -22870,14 +22871,14 @@ module stdlib_linalg_lapack_q return else if( lquery ) then ! ==== quick return in case of a workspace query ==== - call stdlib_qlaqr0( wantt, wantz, n, ilo, ihi, h, ldh, wr, wi, ilo,ihi, z, ldz, & + call stdlib_${ri}$laqr0( wantt, wantz, n, ilo, ihi, h, ldh, wr, wi, ilo,ihi, z, ldz, & work, lwork, info ) ! ==== ensure reported workspace size is backward-compatible with ! . previous lapack versions. ==== - work( 1 ) = max( real( max( 1, n ),KIND=qp), work( 1 ) ) + work( 1 ) = max( real( max( 1, n ),KIND=${rk}$), work( 1 ) ) return else - ! ==== copy eigenvalues isolated by stdlib_qgebal ==== + ! ==== copy eigenvalues isolated by stdlib_${ri}$gebal ==== do i = 1, ilo - 1 wr( i ) = h( i, i ) wi( i ) = zero @@ -22887,60 +22888,60 @@ module stdlib_linalg_lapack_q wi( i ) = zero end do ! ==== initialize z, if requested ==== - if( initz )call stdlib_qlaset( 'A', n, n, zero, one, z, ldz ) + if( initz )call stdlib_${ri}$laset( 'A', n, n, zero, one, z, ldz ) ! ==== quick return if possible ==== if( ilo==ihi ) then wr( ilo ) = h( ilo, ilo ) wi( ilo ) = zero return end if - ! ==== stdlib_qlahqr/stdlib_qlaqr0 crossover point ==== + ! ==== stdlib_${ri}$lahqr/stdlib_${ri}$laqr0 crossover point ==== nmin = stdlib_ilaenv( 12, 'DHSEQR', job( : 1 ) // compz( : 1 ), n,ilo, ihi, lwork ) nmin = max( ntiny, nmin ) - ! ==== stdlib_qlaqr0 for big matrices; stdlib_qlahqr for small ones ==== + ! ==== stdlib_${ri}$laqr0 for big matrices; stdlib_${ri}$lahqr for small ones ==== if( n>nmin ) then - call stdlib_qlaqr0( wantt, wantz, n, ilo, ihi, h, ldh, wr, wi, ilo,ihi, z, ldz, & + call stdlib_${ri}$laqr0( wantt, wantz, n, ilo, ihi, h, ldh, wr, wi, ilo,ihi, z, ldz, & work, lwork, info ) else ! ==== small matrix ==== - call stdlib_qlahqr( wantt, wantz, n, ilo, ihi, h, ldh, wr, wi, ilo,ihi, z, ldz, & + call stdlib_${ri}$lahqr( wantt, wantz, n, ilo, ihi, h, ldh, wr, wi, ilo,ihi, z, ldz, & info ) if( info>0 ) then - ! ==== a rare stdlib_qlahqr failure! stdlib_qlaqr0 sometimes succeeds - ! . when stdlib_qlahqr fails. ==== + ! ==== a rare stdlib_${ri}$lahqr failure! stdlib_${ri}$laqr0 sometimes succeeds + ! . when stdlib_${ri}$lahqr fails. ==== kbot = info if( n>=nl ) then ! ==== larger matrices have enough subdiagonal scratch - ! . space to call stdlib_qlaqr0 directly. ==== - call stdlib_qlaqr0( wantt, wantz, n, ilo, kbot, h, ldh, wr,wi, ilo, ihi, z,& + ! . space to call stdlib_${ri}$laqr0 directly. ==== + call stdlib_${ri}$laqr0( wantt, wantz, n, ilo, kbot, h, ldh, wr,wi, ilo, ihi, z,& ldz, work, lwork, info ) else ! ==== tiny matrices don't have enough subdiagonal - ! . scratch space to benefit from stdlib_qlaqr0. hence, + ! . scratch space to benefit from stdlib_${ri}$laqr0. hence, ! . tiny matrices must be copied into a larger - ! . array before calling stdlib_qlaqr0. ==== - call stdlib_qlacpy( 'A', n, n, h, ldh, hl, nl ) + ! . array before calling stdlib_${ri}$laqr0. ==== + call stdlib_${ri}$lacpy( 'A', n, n, h, ldh, hl, nl ) hl( n+1, n ) = zero - call stdlib_qlaset( 'A', nl, nl-n, zero, zero, hl( 1, n+1 ),nl ) - call stdlib_qlaqr0( wantt, wantz, nl, ilo, kbot, hl, nl, wr,wi, ilo, ihi, & + call stdlib_${ri}$laset( 'A', nl, nl-n, zero, zero, hl( 1, n+1 ),nl ) + call stdlib_${ri}$laqr0( wantt, wantz, nl, ilo, kbot, hl, nl, wr,wi, ilo, ihi, & z, ldz, workl, nl, info ) - if( wantt .or. info/=0 )call stdlib_qlacpy( 'A', n, n, hl, nl, h, ldh ) + if( wantt .or. info/=0 )call stdlib_${ri}$lacpy( 'A', n, n, hl, nl, h, ldh ) end if end if end if ! ==== clear out the trash, if necessary. ==== - if( ( wantt .or. info/=0 ) .and. n>2 )call stdlib_qlaset( 'L', n-2, n-2, zero, zero,& + if( ( wantt .or. info/=0 ) .and. n>2 )call stdlib_${ri}$laset( 'L', n-2, n-2, zero, zero,& h( 3, 1 ), ldh ) ! ==== ensure reported workspace size is backward-compatible with ! . previous lapack versions. ==== - work( 1 ) = max( real( max( 1, n ),KIND=qp), work( 1 ) ) + work( 1 ) = max( real( max( 1, n ),KIND=${rk}$), work( 1 ) ) end if - end subroutine stdlib_qhseqr + end subroutine stdlib_${ri}$hseqr - pure logical(lk) function stdlib_qisnan( din ) + pure logical(lk) function stdlib_${ri}$isnan( din ) !! DISNAN: returns .TRUE. if its argument is NaN, and .FALSE. !! otherwise. To be replaced by the Fortran 2003 intrinsic in the !! future. @@ -22948,15 +22949,15 @@ module stdlib_linalg_lapack_q ! -- lapack is a software package provided by univ. of tennessee, -- ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments - real(qp), intent(in) :: din + real(${rk}$), intent(in) :: din ! ===================================================================== ! Executable Statements - stdlib_qisnan = stdlib_qlaisnan(din,din) + stdlib_${ri}$isnan = stdlib_${ri}$laisnan(din,din) return - end function stdlib_qisnan + end function stdlib_${ri}$isnan - subroutine stdlib_qla_gbamv( trans, m, n, kl, ku, alpha, ab, ldab, x,incx, beta, y, incy ) + subroutine stdlib_${ri}$la_gbamv( trans, m, n, kl, ku, alpha, ab, ldab, x,incx, beta, y, incy ) !! DLA_GBAMV: performs one of the matrix-vector operations !! y := alpha*abs(A)*abs(x) + beta*abs(y), !! or y := alpha*abs(A)**T*abs(x) + beta*abs(y), @@ -22975,16 +22976,16 @@ module stdlib_linalg_lapack_q ! -- lapack is a software package provided by univ. of tennessee, -- ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments - real(qp), intent(in) :: alpha, beta + real(${rk}$), intent(in) :: alpha, beta integer(ilp), intent(in) :: incx, incy, ldab, m, n, kl, ku, trans ! Array Arguments - real(qp), intent(in) :: ab(ldab,*), x(*) - real(qp), intent(inout) :: y(*) + real(${rk}$), intent(in) :: ab(ldab,*), x(*) + real(${rk}$), intent(inout) :: y(*) ! ===================================================================== ! Local Scalars logical(lk) :: symb_wero - real(qp) :: temp, safe1 + real(${rk}$) :: temp, safe1 integer(ilp) :: i, info, iy, j, jx, kx, ky, lenx, leny, kd, ke ! Intrinsic Functions intrinsic :: max,abs,sign @@ -23036,7 +23037,7 @@ module stdlib_linalg_lapack_q end if ! set safe1 essentially to be the underflow threshold times the ! number of additions in each row. - safe1 = stdlib_qlamch( 'SAFE MINIMUM' ) + safe1 = stdlib_${ri}$lamch( 'SAFE MINIMUM' ) safe1 = (n+1)*safe1 ! form y := alpha*abs(a)*abs(x) + beta*abs(y). ! the o(m*n) symb_wero tests could be replaced by o(n) queries to @@ -23139,10 +23140,10 @@ module stdlib_linalg_lapack_q end if end if return - end subroutine stdlib_qla_gbamv + end subroutine stdlib_${ri}$la_gbamv - real(qp) function stdlib_qla_gbrcond( trans, n, kl, ku, ab, ldab,afb, ldafb, ipiv, cmode, c,& + real(${rk}$) function stdlib_${ri}$la_gbrcond( trans, n, kl, ku, ab, ldab,afb, ldafb, ipiv, cmode, c,& !! DLA_GBRCOND: Estimates the Skeel condition number of op(A) * op2(C) !! where op2 is determined by CMODE as follows !! CMODE = 1 op2(C) = C @@ -23163,19 +23164,19 @@ module stdlib_linalg_lapack_q ! Array Arguments integer(ilp), intent(out) :: iwork(*) integer(ilp), intent(in) :: ipiv(*) - real(qp), intent(in) :: ab(ldab,*), afb(ldafb,*), c(*) - real(qp), intent(out) :: work(*) + real(${rk}$), intent(in) :: ab(ldab,*), afb(ldafb,*), c(*) + real(${rk}$), intent(out) :: work(*) ! ===================================================================== ! Local Scalars logical(lk) :: notrans integer(ilp) :: kase, i, j, kd, ke - real(qp) :: ainvnm, tmp + real(${rk}$) :: ainvnm, tmp ! Local Arrays integer(ilp) :: isave(3) ! Intrinsic Functions intrinsic :: abs,max ! Executable Statements - stdlib_qla_gbrcond = zero + stdlib_${ri}$la_gbrcond = zero info = 0 notrans = stdlib_lsame( trans, 'N' ) if ( .not. notrans .and. .not. stdlib_lsame(trans, 'T').and. .not. stdlib_lsame(trans, & @@ -23197,7 +23198,7 @@ module stdlib_linalg_lapack_q return end if if( n==0 ) then - stdlib_qla_gbrcond = one + stdlib_${ri}$la_gbrcond = one return end if ! compute the equilibration matrix r such that @@ -23245,7 +23246,7 @@ module stdlib_linalg_lapack_q ainvnm = zero kase = 0 10 continue - call stdlib_qlacn2( n, work( n+1 ), work, iwork, ainvnm, kase, isave ) + call stdlib_${ri}$lacn2( n, work( n+1 ), work, iwork, ainvnm, kase, isave ) if( kase/=0 ) then if( kase==2 ) then ! multiply by r. @@ -23253,10 +23254,10 @@ module stdlib_linalg_lapack_q work( i ) = work( i ) * work( 2*n+i ) end do if ( notrans ) then - call stdlib_qgbtrs( 'NO TRANSPOSE', n, kl, ku, 1, afb, ldafb,ipiv, work, n, & + call stdlib_${ri}$gbtrs( 'NO TRANSPOSE', n, kl, ku, 1, afb, ldafb,ipiv, work, n, & info ) else - call stdlib_qgbtrs( 'TRANSPOSE', n, kl, ku, 1, afb, ldafb, ipiv,work, n, info & + call stdlib_${ri}$gbtrs( 'TRANSPOSE', n, kl, ku, 1, afb, ldafb, ipiv,work, n, info & ) end if ! multiply by inv(c). @@ -23281,10 +23282,10 @@ module stdlib_linalg_lapack_q end do end if if ( notrans ) then - call stdlib_qgbtrs( 'TRANSPOSE', n, kl, ku, 1, afb, ldafb, ipiv,work, n, info & + call stdlib_${ri}$gbtrs( 'TRANSPOSE', n, kl, ku, 1, afb, ldafb, ipiv,work, n, info & ) else - call stdlib_qgbtrs( 'NO TRANSPOSE', n, kl, ku, 1, afb, ldafb,ipiv, work, n, & + call stdlib_${ri}$gbtrs( 'NO TRANSPOSE', n, kl, ku, 1, afb, ldafb,ipiv, work, n, & info ) end if ! multiply by r. @@ -23295,12 +23296,12 @@ module stdlib_linalg_lapack_q go to 10 end if ! compute the estimate of the reciprocal condition number. - if( ainvnm /= zero )stdlib_qla_gbrcond = ( one / ainvnm ) + if( ainvnm /= zero )stdlib_${ri}$la_gbrcond = ( one / ainvnm ) return - end function stdlib_qla_gbrcond + end function stdlib_${ri}$la_gbrcond - pure real(qp) function stdlib_qla_gbrpvgrw( n, kl, ku, ncols, ab,ldab, afb, ldafb ) + pure real(${rk}$) function stdlib_${ri}$la_gbrpvgrw( n, kl, ku, ncols, ab,ldab, afb, ldafb ) !! DLA_GBRPVGRW: computes the reciprocal pivot growth factor !! norm(A)/norm(U). The "max absolute element" norm is used. If this is !! much less than 1, the stability of the LU factorization of the @@ -23313,11 +23314,11 @@ module stdlib_linalg_lapack_q ! Scalar Arguments integer(ilp), intent(in) :: n, kl, ku, ncols, ldab, ldafb ! Array Arguments - real(qp), intent(in) :: ab(ldab,*), afb(ldafb,*) + real(${rk}$), intent(in) :: ab(ldab,*), afb(ldafb,*) ! ===================================================================== ! Local Scalars integer(ilp) :: i, j, kd - real(qp) :: amax, umax, rpvgrw + real(${rk}$) :: amax, umax, rpvgrw ! Intrinsic Functions intrinsic :: abs,max,min ! Executable Statements @@ -23336,11 +23337,11 @@ module stdlib_linalg_lapack_q rpvgrw = min( amax / umax, rpvgrw ) end if end do - stdlib_qla_gbrpvgrw = rpvgrw - end function stdlib_qla_gbrpvgrw + stdlib_${ri}$la_gbrpvgrw = rpvgrw + end function stdlib_${ri}$la_gbrpvgrw - subroutine stdlib_qla_geamv ( trans, m, n, alpha, a, lda, x, incx, beta,y, incy ) + subroutine stdlib_${ri}$la_geamv ( trans, m, n, alpha, a, lda, x, incx, beta,y, incy ) !! DLA_GEAMV: performs one of the matrix-vector operations !! y := alpha*abs(A)*abs(x) + beta*abs(y), !! or y := alpha*abs(A)**T*abs(x) + beta*abs(y), @@ -23358,16 +23359,16 @@ module stdlib_linalg_lapack_q ! -- lapack is a software package provided by univ. of tennessee, -- ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments - real(qp), intent(in) :: alpha, beta + real(${rk}$), intent(in) :: alpha, beta integer(ilp), intent(in) :: incx, incy, lda, m, n, trans ! Array Arguments - real(qp), intent(in) :: a(lda,*), x(*) - real(qp), intent(inout) :: y(*) + real(${rk}$), intent(in) :: a(lda,*), x(*) + real(${rk}$), intent(inout) :: y(*) ! ===================================================================== ! Local Scalars logical(lk) :: symb_wero - real(qp) :: temp, safe1 + real(${rk}$) :: temp, safe1 integer(ilp) :: i, info, iy, j, jx, kx, ky, lenx, leny ! Intrinsic Functions intrinsic :: max,abs,sign @@ -23415,7 +23416,7 @@ module stdlib_linalg_lapack_q end if ! set safe1 essentially to be the underflow threshold times the ! number of additions in each row. - safe1 = stdlib_qlamch( 'SAFE MINIMUM' ) + safe1 = stdlib_${ri}$lamch( 'SAFE MINIMUM' ) safe1 = (n+1)*safe1 ! form y := alpha*abs(a)*abs(x) + beta*abs(y). ! the o(m*n) symb_wero tests could be replaced by o(n) queries to @@ -23516,10 +23517,10 @@ module stdlib_linalg_lapack_q end if end if return - end subroutine stdlib_qla_geamv + end subroutine stdlib_${ri}$la_geamv - real(qp) function stdlib_qla_gercond( trans, n, a, lda, af,ldaf, ipiv, cmode, c,info, work, & + real(${rk}$) function stdlib_${ri}$la_gercond( trans, n, a, lda, af,ldaf, ipiv, cmode, c,info, work, & !! DLA_GERCOND: estimates the Skeel condition number of op(A) * op2(C) !! where op2 is determined by CMODE as follows !! CMODE = 1 op2(C) = C @@ -23540,19 +23541,19 @@ module stdlib_linalg_lapack_q ! Array Arguments integer(ilp), intent(in) :: ipiv(*) integer(ilp), intent(out) :: iwork(*) - real(qp), intent(in) :: a(lda,*), af(ldaf,*), c(*) - real(qp), intent(out) :: work(*) + real(${rk}$), intent(in) :: a(lda,*), af(ldaf,*), c(*) + real(${rk}$), intent(out) :: work(*) ! ===================================================================== ! Local Scalars logical(lk) :: notrans integer(ilp) :: kase, i, j - real(qp) :: ainvnm, tmp + real(${rk}$) :: ainvnm, tmp ! Local Arrays integer(ilp) :: isave(3) ! Intrinsic Functions intrinsic :: abs,max ! Executable Statements - stdlib_qla_gercond = zero + stdlib_${ri}$la_gercond = zero info = 0 notrans = stdlib_lsame( trans, 'N' ) if ( .not. notrans .and. .not. stdlib_lsame(trans, 'T').and. .not. stdlib_lsame(trans, & @@ -23570,7 +23571,7 @@ module stdlib_linalg_lapack_q return end if if( n==0 ) then - stdlib_qla_gercond = one + stdlib_${ri}$la_gercond = one return end if ! compute the equilibration matrix r such that @@ -23616,7 +23617,7 @@ module stdlib_linalg_lapack_q ainvnm = zero kase = 0 10 continue - call stdlib_qlacn2( n, work( n+1 ), work, iwork, ainvnm, kase, isave ) + call stdlib_${ri}$lacn2( n, work( n+1 ), work, iwork, ainvnm, kase, isave ) if( kase/=0 ) then if( kase==2 ) then ! multiply by r. @@ -23624,10 +23625,10 @@ module stdlib_linalg_lapack_q work(i) = work(i) * work(2*n+i) end do if (notrans) then - call stdlib_qgetrs( 'NO TRANSPOSE', n, 1, af, ldaf, ipiv,work, n, info ) + call stdlib_${ri}$getrs( 'NO TRANSPOSE', n, 1, af, ldaf, ipiv,work, n, info ) else - call stdlib_qgetrs( 'TRANSPOSE', n, 1, af, ldaf, ipiv,work, n, info ) + call stdlib_${ri}$getrs( 'TRANSPOSE', n, 1, af, ldaf, ipiv,work, n, info ) end if ! multiply by inv(c). if ( cmode == 1 ) then @@ -23651,9 +23652,9 @@ module stdlib_linalg_lapack_q end do end if if (notrans) then - call stdlib_qgetrs( 'TRANSPOSE', n, 1, af, ldaf, ipiv,work, n, info ) + call stdlib_${ri}$getrs( 'TRANSPOSE', n, 1, af, ldaf, ipiv,work, n, info ) else - call stdlib_qgetrs( 'NO TRANSPOSE', n, 1, af, ldaf, ipiv,work, n, info ) + call stdlib_${ri}$getrs( 'NO TRANSPOSE', n, 1, af, ldaf, ipiv,work, n, info ) end if ! multiply by r. @@ -23664,12 +23665,12 @@ module stdlib_linalg_lapack_q go to 10 end if ! compute the estimate of the reciprocal condition number. - if( ainvnm /= zero )stdlib_qla_gercond = ( one / ainvnm ) + if( ainvnm /= zero )stdlib_${ri}$la_gercond = ( one / ainvnm ) return - end function stdlib_qla_gercond + end function stdlib_${ri}$la_gercond - pure real(qp) function stdlib_qla_gerpvgrw( n, ncols, a, lda, af,ldaf ) + pure real(${rk}$) function stdlib_${ri}$la_gerpvgrw( n, ncols, a, lda, af,ldaf ) !! DLA_GERPVGRW: computes the reciprocal pivot growth factor !! norm(A)/norm(U). The "max absolute element" norm is used. If this is !! much less than 1, the stability of the LU factorization of the @@ -23682,11 +23683,11 @@ module stdlib_linalg_lapack_q ! Scalar Arguments integer(ilp), intent(in) :: n, ncols, lda, ldaf ! Array Arguments - real(qp), intent(in) :: a(lda,*), af(ldaf,*) + real(${rk}$), intent(in) :: a(lda,*), af(ldaf,*) ! ===================================================================== ! Local Scalars integer(ilp) :: i, j - real(qp) :: amax, umax, rpvgrw + real(${rk}$) :: amax, umax, rpvgrw ! Intrinsic Functions intrinsic :: abs,max,min ! Executable Statements @@ -23704,11 +23705,11 @@ module stdlib_linalg_lapack_q rpvgrw = min( amax / umax, rpvgrw ) end if end do - stdlib_qla_gerpvgrw = rpvgrw - end function stdlib_qla_gerpvgrw + stdlib_${ri}$la_gerpvgrw = rpvgrw + end function stdlib_${ri}$la_gerpvgrw - pure subroutine stdlib_qla_lin_berr ( n, nz, nrhs, res, ayb, berr ) + pure subroutine stdlib_${ri}$la_lin_berr ( n, nz, nrhs, res, ayb, berr ) !! DLA_LIN_BERR: computes component-wise relative backward error from !! the formula !! max(i) ( abs(R(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) ) @@ -23720,12 +23721,12 @@ module stdlib_linalg_lapack_q ! Scalar Arguments integer(ilp), intent(in) :: n, nz, nrhs ! Array Arguments - real(qp), intent(in) :: ayb(n,nrhs) - real(qp), intent(out) :: berr(nrhs) - real(qp), intent(in) :: res(n,nrhs) + real(${rk}$), intent(in) :: ayb(n,nrhs) + real(${rk}$), intent(out) :: berr(nrhs) + real(${rk}$), intent(in) :: res(n,nrhs) ! ===================================================================== ! Local Scalars - real(qp) :: tmp,safe1 + real(${rk}$) :: tmp,safe1 integer(ilp) :: i, j ! Intrinsic Functions intrinsic :: abs,max @@ -23733,7 +23734,7 @@ module stdlib_linalg_lapack_q ! adding safe1 to the numerator guards against spuriously zero ! residuals. a similar safeguard is in the sla_yyamv routine used ! to compute ayb. - safe1 = stdlib_qlamch( 'SAFE MINIMUM' ) + safe1 = stdlib_${ri}$lamch( 'SAFE MINIMUM' ) safe1 = (nz+1)*safe1 do j = 1, nrhs berr(j) = zero @@ -23742,14 +23743,14 @@ module stdlib_linalg_lapack_q tmp = (safe1+abs(res(i,j)))/ayb(i,j) berr(j) = max( berr(j), tmp ) end if - ! if ayb is exactly 0.0_qp (and if computed by sla_yyamv), then we know + ! if ayb is exactly 0.0_${rk}$ (and if computed by sla_yyamv), then we know ! the true residual also must be exactly zero. end do end do - end subroutine stdlib_qla_lin_berr + end subroutine stdlib_${ri}$la_lin_berr - real(qp) function stdlib_qla_porcond( uplo, n, a, lda, af, ldaf,cmode, c, info, work,iwork ) + real(${rk}$) function stdlib_${ri}$la_porcond( uplo, n, a, lda, af, ldaf,cmode, c, info, work,iwork ) !! DLA_PORCOND: Estimates the Skeel condition number of op(A) * op2(C) !! where op2 is determined by CMODE as follows !! CMODE = 1 op2(C) = C @@ -23767,21 +23768,21 @@ module stdlib_linalg_lapack_q character, intent(in) :: uplo integer(ilp), intent(in) :: n, lda, ldaf, cmode integer(ilp), intent(out) :: info - real(qp), intent(in) :: a(lda,*), af(ldaf,*), c(*) - real(qp), intent(out) :: work(*) + real(${rk}$), intent(in) :: a(lda,*), af(ldaf,*), c(*) + real(${rk}$), intent(out) :: work(*) ! Array Arguments integer(ilp), intent(out) :: iwork(*) ! ===================================================================== ! Local Scalars integer(ilp) :: kase, i, j - real(qp) :: ainvnm, tmp + real(${rk}$) :: ainvnm, tmp logical(lk) :: up ! Array Arguments integer(ilp) :: isave(3) ! Intrinsic Functions intrinsic :: abs,max ! Executable Statements - stdlib_qla_porcond = zero + stdlib_${ri}$la_porcond = zero info = 0 if( n<0 ) then info = -2 @@ -23791,7 +23792,7 @@ module stdlib_linalg_lapack_q return end if if( n==0 ) then - stdlib_qla_porcond = one + stdlib_${ri}$la_porcond = one return end if up = .false. @@ -23857,7 +23858,7 @@ module stdlib_linalg_lapack_q ainvnm = zero kase = 0 10 continue - call stdlib_qlacn2( n, work( n+1 ), work, iwork, ainvnm, kase, isave ) + call stdlib_${ri}$lacn2( n, work( n+1 ), work, iwork, ainvnm, kase, isave ) if( kase/=0 ) then if( kase==2 ) then ! multiply by r. @@ -23865,9 +23866,9 @@ module stdlib_linalg_lapack_q work( i ) = work( i ) * work( 2*n+i ) end do if (up) then - call stdlib_qpotrs( 'UPPER', n, 1, af, ldaf, work, n, info ) + call stdlib_${ri}$potrs( 'UPPER', n, 1, af, ldaf, work, n, info ) else - call stdlib_qpotrs( 'LOWER', n, 1, af, ldaf, work, n, info ) + call stdlib_${ri}$potrs( 'LOWER', n, 1, af, ldaf, work, n, info ) endif ! multiply by inv(c). if ( cmode == 1 ) then @@ -23891,9 +23892,9 @@ module stdlib_linalg_lapack_q end do end if if ( up ) then - call stdlib_qpotrs( 'UPPER', n, 1, af, ldaf, work, n, info ) + call stdlib_${ri}$potrs( 'UPPER', n, 1, af, ldaf, work, n, info ) else - call stdlib_qpotrs( 'LOWER', n, 1, af, ldaf, work, n, info ) + call stdlib_${ri}$potrs( 'LOWER', n, 1, af, ldaf, work, n, info ) endif ! multiply by r. do i = 1, n @@ -23903,12 +23904,12 @@ module stdlib_linalg_lapack_q go to 10 end if ! compute the estimate of the reciprocal condition number. - if( ainvnm /= zero )stdlib_qla_porcond = ( one / ainvnm ) + if( ainvnm /= zero )stdlib_${ri}$la_porcond = ( one / ainvnm ) return - end function stdlib_qla_porcond + end function stdlib_${ri}$la_porcond - real(qp) function stdlib_qla_porpvgrw( uplo, ncols, a, lda, af,ldaf, work ) + real(${rk}$) function stdlib_${ri}$la_porpvgrw( uplo, ncols, a, lda, af,ldaf, work ) !! DLA_PORPVGRW: computes the reciprocal pivot growth factor !! norm(A)/norm(U). The "max absolute element" norm is used. If this is !! much less than 1, the stability of the LU factorization of the @@ -23922,18 +23923,18 @@ module stdlib_linalg_lapack_q character, intent(in) :: uplo integer(ilp), intent(in) :: ncols, lda, ldaf ! Array Arguments - real(qp), intent(in) :: a(lda,*), af(ldaf,*) - real(qp), intent(out) :: work(*) + real(${rk}$), intent(in) :: a(lda,*), af(ldaf,*) + real(${rk}$), intent(out) :: work(*) ! ===================================================================== ! Local Scalars integer(ilp) :: i, j - real(qp) :: amax, umax, rpvgrw + real(${rk}$) :: amax, umax, rpvgrw logical(lk) :: upper ! Intrinsic Functions intrinsic :: abs,max,min ! Executable Statements upper = stdlib_lsame( 'UPPER', uplo ) - ! stdlib_qpotrf will have factored only the ncolsxncols leading minor, so + ! stdlib_${ri}$potrf will have factored only the ncolsxncols leading minor, so ! we restrict the growth search to that minor and use only the first ! 2*ncols workspace entries. rpvgrw = one @@ -23992,11 +23993,11 @@ module stdlib_linalg_lapack_q end if end do end if - stdlib_qla_porpvgrw = rpvgrw - end function stdlib_qla_porpvgrw + stdlib_${ri}$la_porpvgrw = rpvgrw + end function stdlib_${ri}$la_porpvgrw - subroutine stdlib_qla_syamv( uplo, n, alpha, a, lda, x, incx, beta, y,incy ) + subroutine stdlib_${ri}$la_syamv( uplo, n, alpha, a, lda, x, incx, beta, y,incy ) !! DLA_SYAMV: performs the matrix-vector operation !! y := alpha*abs(A)*abs(x) + beta*abs(y), !! where alpha and beta are scalars, x and y are vectors and A is an @@ -24013,16 +24014,16 @@ module stdlib_linalg_lapack_q ! -- lapack is a software package provided by univ. of tennessee, -- ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments - real(qp), intent(in) :: alpha, beta + real(${rk}$), intent(in) :: alpha, beta integer(ilp), intent(in) :: incx, incy, lda, n, uplo ! Array Arguments - real(qp), intent(in) :: a(lda,*), x(*) - real(qp), intent(inout) :: y(*) + real(${rk}$), intent(in) :: a(lda,*), x(*) + real(${rk}$), intent(inout) :: y(*) ! ===================================================================== ! Local Scalars logical(lk) :: symb_wero - real(qp) :: temp, safe1 + real(${rk}$) :: temp, safe1 integer(ilp) :: i, info, iy, j, jx, kx, ky ! Intrinsic Functions intrinsic :: max,abs,sign @@ -24059,7 +24060,7 @@ module stdlib_linalg_lapack_q end if ! set safe1 essentially to be the underflow threshold times the ! number of additions in each row. - safe1 = stdlib_qlamch( 'SAFE MINIMUM' ) + safe1 = stdlib_${ri}$lamch( 'SAFE MINIMUM' ) safe1 = (n+1)*safe1 ! form y := alpha*abs(a)*abs(x) + beta*abs(y). ! the o(n^2) symb_wero tests could be replaced by o(n) queries to @@ -24182,10 +24183,10 @@ module stdlib_linalg_lapack_q end if end if return - end subroutine stdlib_qla_syamv + end subroutine stdlib_${ri}$la_syamv - real(qp) function stdlib_qla_syrcond( uplo, n, a, lda, af, ldaf,ipiv, cmode, c, info, work,& + real(${rk}$) function stdlib_${ri}$la_syrcond( uplo, n, a, lda, af, ldaf,ipiv, cmode, c, info, work,& !! DLA_SYRCOND: estimates the Skeel condition number of op(A) * op2(C) !! where op2 is determined by CMODE as follows !! CMODE = 1 op2(C) = C @@ -24206,20 +24207,20 @@ module stdlib_linalg_lapack_q ! Array Arguments integer(ilp), intent(out) :: iwork(*) integer(ilp), intent(in) :: ipiv(*) - real(qp), intent(in) :: a(lda,*), af(ldaf,*), c(*) - real(qp), intent(out) :: work(*) + real(${rk}$), intent(in) :: a(lda,*), af(ldaf,*), c(*) + real(${rk}$), intent(out) :: work(*) ! ===================================================================== ! Local Scalars character :: normin integer(ilp) :: kase, i, j - real(qp) :: ainvnm, smlnum, tmp + real(${rk}$) :: ainvnm, smlnum, tmp logical(lk) :: up ! Local Arrays integer(ilp) :: isave(3) ! Intrinsic Functions intrinsic :: abs,max ! Executable Statements - stdlib_qla_syrcond = zero + stdlib_${ri}$la_syrcond = zero info = 0 if( n<0 ) then info = -2 @@ -24233,7 +24234,7 @@ module stdlib_linalg_lapack_q return end if if( n==0 ) then - stdlib_qla_syrcond = one + stdlib_${ri}$la_syrcond = one return end if up = .false. @@ -24296,12 +24297,12 @@ module stdlib_linalg_lapack_q end do endif ! estimate the norm of inv(op(a)). - smlnum = stdlib_qlamch( 'SAFE MINIMUM' ) + smlnum = stdlib_${ri}$lamch( 'SAFE MINIMUM' ) ainvnm = zero normin = 'N' kase = 0 10 continue - call stdlib_qlacn2( n, work( n+1 ), work, iwork, ainvnm, kase, isave ) + call stdlib_${ri}$lacn2( n, work( n+1 ), work, iwork, ainvnm, kase, isave ) if( kase/=0 ) then if( kase==2 ) then ! multiply by r. @@ -24309,9 +24310,9 @@ module stdlib_linalg_lapack_q work( i ) = work( i ) * work( 2*n+i ) end do if ( up ) then - call stdlib_qsytrs( 'U', n, 1, af, ldaf, ipiv, work, n, info ) + call stdlib_${ri}$sytrs( 'U', n, 1, af, ldaf, ipiv, work, n, info ) else - call stdlib_qsytrs( 'L', n, 1, af, ldaf, ipiv, work, n, info ) + call stdlib_${ri}$sytrs( 'L', n, 1, af, ldaf, ipiv, work, n, info ) endif ! multiply by inv(c). if ( cmode == 1 ) then @@ -24335,9 +24336,9 @@ module stdlib_linalg_lapack_q end do end if if ( up ) then - call stdlib_qsytrs( 'U', n, 1, af, ldaf, ipiv, work, n, info ) + call stdlib_${ri}$sytrs( 'U', n, 1, af, ldaf, ipiv, work, n, info ) else - call stdlib_qsytrs( 'L', n, 1, af, ldaf, ipiv, work, n, info ) + call stdlib_${ri}$sytrs( 'L', n, 1, af, ldaf, ipiv, work, n, info ) endif ! multiply by r. do i = 1, n @@ -24347,12 +24348,12 @@ module stdlib_linalg_lapack_q go to 10 end if ! compute the estimate of the reciprocal condition number. - if( ainvnm /= zero )stdlib_qla_syrcond = ( one / ainvnm ) + if( ainvnm /= zero )stdlib_${ri}$la_syrcond = ( one / ainvnm ) return - end function stdlib_qla_syrcond + end function stdlib_${ri}$la_syrcond - real(qp) function stdlib_qla_syrpvgrw( uplo, n, info, a, lda, af,ldaf, ipiv, work ) + real(${rk}$) function stdlib_${ri}$la_syrpvgrw( uplo, n, info, a, lda, af,ldaf, ipiv, work ) !! DLA_SYRPVGRW: computes the reciprocal pivot growth factor !! norm(A)/norm(U). The "max absolute element" norm is used. If this is !! much less than 1, the stability of the LU factorization of the @@ -24367,12 +24368,12 @@ module stdlib_linalg_lapack_q integer(ilp), intent(in) :: n, info, lda, ldaf ! Array Arguments integer(ilp), intent(in) :: ipiv(*) - real(qp), intent(in) :: a(lda,*), af(ldaf,*) - real(qp), intent(out) :: work(*) + real(${rk}$), intent(in) :: a(lda,*), af(ldaf,*) + real(${rk}$), intent(out) :: work(*) ! ===================================================================== ! Local Scalars integer(ilp) :: ncols, i, j, k, kp - real(qp) :: amax, umax, rpvgrw, tmp + real(${rk}$) :: amax, umax, rpvgrw, tmp logical(lk) :: upper ! Intrinsic Functions intrinsic :: abs,max,min @@ -24412,7 +24413,7 @@ module stdlib_linalg_lapack_q ! now find the max magnitude entry of each column of u or l. also ! permute the magnitudes of a above so they're in the same order as ! the factor. - ! the iteration orders and permutations were copied from stdlib_qsytrs. + ! the iteration orders and permutations were copied from stdlib_${ri}$sytrs. ! calls to stdlib_dswap would be severe overkill. if ( upper ) then k = n @@ -24532,11 +24533,11 @@ module stdlib_linalg_lapack_q end if end do end if - stdlib_qla_syrpvgrw = rpvgrw - end function stdlib_qla_syrpvgrw + stdlib_${ri}$la_syrpvgrw = rpvgrw + end function stdlib_${ri}$la_syrpvgrw - pure subroutine stdlib_qla_wwaddw( n, x, y, w ) + pure subroutine stdlib_${ri}$la_wwaddw( n, x, y, w ) !! DLA_WWADDW: adds a vector W into a doubled-single vector (X, Y). !! This works for all extant IBM's hex and binary floating point !! arithmetic, but not for decimal. @@ -24546,11 +24547,11 @@ module stdlib_linalg_lapack_q ! Scalar Arguments integer(ilp), intent(in) :: n ! Array Arguments - real(qp), intent(inout) :: x(*), y(*) - real(qp), intent(in) :: w(*) + real(${rk}$), intent(inout) :: x(*), y(*) + real(${rk}$), intent(in) :: w(*) ! ===================================================================== ! Local Scalars - real(qp) :: s + real(${rk}$) :: s integer(ilp) :: i ! Executable Statements do 10 i = 1, n @@ -24560,10 +24561,10 @@ module stdlib_linalg_lapack_q x(i) = s 10 continue return - end subroutine stdlib_qla_wwaddw + end subroutine stdlib_${ri}$la_wwaddw - pure subroutine stdlib_qlabad( small, large ) + pure subroutine stdlib_${ri}$labad( small, large ) !! DLABAD: takes as input the values computed by DLAMCH for underflow and !! overflow, and returns the square root of each of these values if the !! log of LARGE is sufficiently large. This subroutine is intended to @@ -24576,22 +24577,22 @@ module stdlib_linalg_lapack_q ! -- lapack is a software package provided by univ. of tennessee, -- ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments - real(qp), intent(inout) :: large, small + real(${rk}$), intent(inout) :: large, small ! ===================================================================== ! Intrinsic Functions intrinsic :: log10,sqrt ! Executable Statements ! if it looks like we're on a cray, take the square root of ! small and large to avoid overflow and underflow problems. - if( log10( large )>2000._qp ) then + if( log10( large )>2000._${rk}$ ) then small = sqrt( small ) large = sqrt( large ) end if return - end subroutine stdlib_qlabad + end subroutine stdlib_${ri}$labad - pure subroutine stdlib_qlabrd( m, n, nb, a, lda, d, e, tauq, taup, x, ldx, y,ldy ) + pure subroutine stdlib_${ri}$labrd( m, n, nb, a, lda, d, e, tauq, taup, x, ldx, y,ldy ) !! DLABRD: reduces the first NB rows and columns of a real general !! m by n matrix A to upper or lower bidiagonal form by an orthogonal !! transformation Q**T * A * P, and returns the matrices X and Y which @@ -24605,8 +24606,8 @@ module stdlib_linalg_lapack_q ! Scalar Arguments integer(ilp), intent(in) :: lda, ldx, ldy, m, n, nb ! Array Arguments - real(qp), intent(inout) :: a(lda,*) - real(qp), intent(out) :: d(*), e(*), taup(*), tauq(*), x(ldx,*), y(ldy,*) + real(${rk}$), intent(inout) :: a(lda,*) + real(${rk}$), intent(out) :: d(*), e(*), taup(*), tauq(*), x(ldx,*), y(ldy,*) ! ===================================================================== ! Local Scalars @@ -24620,108 +24621,108 @@ module stdlib_linalg_lapack_q ! reduce to upper bidiagonal form loop_10: do i = 1, nb ! update a(i:m,i) - call stdlib_qgemv( 'NO TRANSPOSE', m-i+1, i-1, -one, a( i, 1 ),lda, y( i, 1 ), & + call stdlib_${ri}$gemv( 'NO TRANSPOSE', m-i+1, i-1, -one, a( i, 1 ),lda, y( i, 1 ), & ldy, one, a( i, i ), 1 ) - call stdlib_qgemv( 'NO TRANSPOSE', m-i+1, i-1, -one, x( i, 1 ),ldx, a( 1, i ), 1,& + call stdlib_${ri}$gemv( 'NO TRANSPOSE', m-i+1, i-1, -one, x( i, 1 ),ldx, a( 1, i ), 1,& one, a( i, i ), 1 ) ! generate reflection q(i) to annihilate a(i+1:m,i) - call stdlib_qlarfg( m-i+1, a( i, i ), a( min( i+1, m ), i ), 1,tauq( i ) ) + call stdlib_${ri}$larfg( m-i+1, a( i, i ), a( min( i+1, m ), i ), 1,tauq( i ) ) d( i ) = a( i, i ) if( i=zero ) then x(i) = one @@ -24780,7 +24781,7 @@ module stdlib_linalg_lapack_q ! ................ entry (isave( 1 ) = 2) ! first iteration. x has been overwritten by transpose(a)*x. 40 continue - isave( 2 ) = stdlib_iqamax( n, x, 1 ) + isave( 2 ) = stdlib_i${ri}$amax( n, x, 1 ) isave( 3 ) = 2 ! main loop - iterations 2,3,...,itmax. 50 continue @@ -24794,9 +24795,9 @@ module stdlib_linalg_lapack_q ! ................ entry (isave( 1 ) = 3) ! x has been overwritten by a*x. 70 continue - call stdlib_qcopy( n, x, 1, v, 1 ) + call stdlib_${ri}$copy( n, x, 1, v, 1 ) estold = est - est = stdlib_qasum( n, v, 1 ) + est = stdlib_${ri}$asum( n, v, 1 ) do i = 1, n if( x(i)>=zero ) then xs = one @@ -24825,7 +24826,7 @@ module stdlib_linalg_lapack_q ! x has been overwritten by transpose(a)*x. 110 continue jlast = isave( 2 ) - isave( 2 ) = stdlib_iqamax( n, x, 1 ) + isave( 2 ) = stdlib_i${ri}$amax( n, x, 1 ) if( ( x( jlast )/=abs( x( isave( 2 ) ) ) ) .and.( isave( 3 )est ) then - call stdlib_qcopy( n, x, 1, v, 1 ) + call stdlib_${ri}$copy( n, x, 1, v, 1 ) est = temp end if 150 continue kase = 0 return - end subroutine stdlib_qlacn2 + end subroutine stdlib_${ri}$lacn2 - subroutine stdlib_qlacon( n, v, x, isgn, est, kase ) + subroutine stdlib_${ri}$lacon( n, v, x, isgn, est, kase ) !! DLACON: estimates the 1-norm of a square, real matrix A. !! Reverse communication is used for evaluating matrix-vector products. ! -- lapack auxiliary routine -- @@ -24863,11 +24864,11 @@ module stdlib_linalg_lapack_q ! Scalar Arguments integer(ilp), intent(inout) :: kase integer(ilp), intent(in) :: n - real(qp), intent(inout) :: est + real(${rk}$), intent(inout) :: est ! Array Arguments integer(ilp), intent(out) :: isgn(*) - real(qp), intent(out) :: v(*) - real(qp), intent(inout) :: x(*) + real(${rk}$), intent(out) :: v(*) + real(${rk}$), intent(inout) :: x(*) ! ===================================================================== ! Parameters integer(ilp), parameter :: itmax = 5 @@ -24875,7 +24876,7 @@ module stdlib_linalg_lapack_q ! Local Scalars integer(ilp) :: i, iter, j, jlast, jump - real(qp) :: altsgn, estold, temp + real(${rk}$) :: altsgn, estold, temp ! Intrinsic Functions intrinsic :: abs,real,nint,sign ! Save Statement @@ -24883,7 +24884,7 @@ module stdlib_linalg_lapack_q ! Executable Statements if( kase==0 ) then do i = 1, n - x( i ) = one / real( n,KIND=qp) + x( i ) = one / real( n,KIND=${rk}$) end do kase = 1 jump = 1 @@ -24899,7 +24900,7 @@ module stdlib_linalg_lapack_q ! ... quit go to 150 end if - est = stdlib_qasum( n, x, 1 ) + est = stdlib_${ri}$asum( n, x, 1 ) do i = 1, n x( i ) = sign( one, x( i ) ) isgn( i ) = nint( x( i ),KIND=ilp) @@ -24910,7 +24911,7 @@ module stdlib_linalg_lapack_q ! ................ entry (jump = 2) ! first iteration. x has been overwritten by transpose(a)*x. 40 continue - j = stdlib_iqamax( n, x, 1 ) + j = stdlib_i${ri}$amax( n, x, 1 ) iter = 2 ! main loop - iterations 2,3,...,itmax. 50 continue @@ -24924,9 +24925,9 @@ module stdlib_linalg_lapack_q ! ................ entry (jump = 3) ! x has been overwritten by a*x. 70 continue - call stdlib_qcopy( n, x, 1, v, 1 ) + call stdlib_${ri}$copy( n, x, 1, v, 1 ) estold = est - est = stdlib_qasum( n, v, 1 ) + est = stdlib_${ri}$asum( n, v, 1 ) do i = 1, n if( nint( sign( one, x( i ) ),KIND=ilp)/=isgn( i ) )go to 90 end do @@ -24946,7 +24947,7 @@ module stdlib_linalg_lapack_q ! x has been overwritten by transpose(a)*x. 110 continue jlast = j - j = stdlib_iqamax( n, x, 1 ) + j = stdlib_i${ri}$amax( n, x, 1 ) if( ( x( jlast )/=abs( x( j ) ) ) .and. ( iterest ) then - call stdlib_qcopy( n, x, 1, v, 1 ) + call stdlib_${ri}$copy( n, x, 1, v, 1 ) est = temp end if 150 continue kase = 0 return - end subroutine stdlib_qlacon + end subroutine stdlib_${ri}$lacon - pure subroutine stdlib_qlacpy( uplo, m, n, a, lda, b, ldb ) + pure subroutine stdlib_${ri}$lacpy( uplo, m, n, a, lda, b, ldb ) !! DLACPY: copies all or part of a two-dimensional matrix A to another !! matrix B. ! -- lapack auxiliary routine -- @@ -24985,8 +24986,8 @@ module stdlib_linalg_lapack_q character, intent(in) :: uplo integer(ilp), intent(in) :: lda, ldb, m, n ! Array Arguments - real(qp), intent(in) :: a(lda,*) - real(qp), intent(out) :: b(ldb,*) + real(${rk}$), intent(in) :: a(lda,*) + real(${rk}$), intent(out) :: b(ldb,*) ! ===================================================================== ! Local Scalars integer(ilp) :: i, j @@ -25013,10 +25014,10 @@ module stdlib_linalg_lapack_q end do end if return - end subroutine stdlib_qlacpy + end subroutine stdlib_${ri}$lacpy - pure subroutine stdlib_qladiv( a, b, c, d, p, q ) + pure subroutine stdlib_${ri}$ladiv( a, b, c, d, p, q ) !! DLADIV: performs complex division in real arithmetic !! a + i*b !! p + i*q = --------- @@ -25028,16 +25029,16 @@ module stdlib_linalg_lapack_q ! -- lapack is a software package provided by univ. of tennessee, -- ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments - real(qp), intent(in) :: a, b, c, d - real(qp), intent(out) :: p, q + real(${rk}$), intent(in) :: a, b, c, d + real(${rk}$), intent(out) :: p, q ! ===================================================================== ! Parameters - real(qp), parameter :: bs = 2.0_qp + real(${rk}$), parameter :: bs = 2.0_${rk}$ ! Local Scalars - real(qp) :: aa, bb, cc, dd, ab, cd, s, ov, un, be, eps + real(${rk}$) :: aa, bb, cc, dd, ab, cd, s, ov, un, be, eps ! Intrinsic Functions intrinsic :: abs,max ! Executable Statements @@ -25048,9 +25049,9 @@ module stdlib_linalg_lapack_q ab = max( abs(a), abs(b) ) cd = max( abs(c), abs(d) ) s = one - ov = stdlib_qlamch( 'OVERFLOW THRESHOLD' ) - un = stdlib_qlamch( 'SAFE MINIMUM' ) - eps = stdlib_qlamch( 'EPSILON' ) + ov = stdlib_${ri}$lamch( 'OVERFLOW THRESHOLD' ) + un = stdlib_${ri}$lamch( 'SAFE MINIMUM' ) + eps = stdlib_${ri}$lamch( 'EPSILON' ) be = bs / (eps*eps) if( ab >= half*ov ) then aa = half * aa @@ -25073,65 +25074,65 @@ module stdlib_linalg_lapack_q s = s * be end if if( abs( d )<=abs( c ) ) then - call stdlib_qladiv1(aa, bb, cc, dd, p, q) + call stdlib_${ri}$ladiv1(aa, bb, cc, dd, p, q) else - call stdlib_qladiv1(bb, aa, dd, cc, p, q) + call stdlib_${ri}$ladiv1(bb, aa, dd, cc, p, q) q = -q end if p = p * s q = q * s return - end subroutine stdlib_qladiv + end subroutine stdlib_${ri}$ladiv - pure subroutine stdlib_qladiv1( a, b, c, d, p, q ) + pure subroutine stdlib_${ri}$ladiv1( a, b, c, d, p, q ) ! -- lapack auxiliary routine -- ! -- lapack is a software package provided by univ. of tennessee, -- ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments - real(qp), intent(inout) :: a - real(qp), intent(in) :: b, c, d - real(qp), intent(out) :: p, q + real(${rk}$), intent(inout) :: a + real(${rk}$), intent(in) :: b, c, d + real(${rk}$), intent(out) :: p, q ! ===================================================================== ! Local Scalars - real(qp) :: r, t + real(${rk}$) :: r, t ! Executable Statements r = d / c t = one / (c + d * r) - p = stdlib_qladiv2(a, b, c, d, r, t) + p = stdlib_${ri}$ladiv2(a, b, c, d, r, t) a = -a - q = stdlib_qladiv2(b, a, c, d, r, t) + q = stdlib_${ri}$ladiv2(b, a, c, d, r, t) return - end subroutine stdlib_qladiv1 + end subroutine stdlib_${ri}$ladiv1 - pure real(qp) function stdlib_qladiv2( a, b, c, d, r, t ) + pure real(${rk}$) function stdlib_${ri}$ladiv2( a, b, c, d, r, t ) ! -- lapack auxiliary routine -- ! -- lapack is a software package provided by univ. of tennessee, -- ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments - real(qp), intent(in) :: a, b, c, d, r, t + real(${rk}$), intent(in) :: a, b, c, d, r, t ! ===================================================================== ! Local Scalars - real(qp) :: br + real(${rk}$) :: br ! Executable Statements if( r/=zero ) then br = b * r if( br/=zero ) then - stdlib_qladiv2 = (a + br) * t + stdlib_${ri}$ladiv2 = (a + br) * t else - stdlib_qladiv2 = a * t + (b * t) * r + stdlib_${ri}$ladiv2 = a * t + (b * t) * r end if else - stdlib_qladiv2 = (a + d * (b / c)) * t + stdlib_${ri}$ladiv2 = (a + d * (b / c)) * t end if return - end function stdlib_qladiv2 + end function stdlib_${ri}$ladiv2 - pure subroutine stdlib_qlae2( a, b, c, rt1, rt2 ) + pure subroutine stdlib_${ri}$lae2( a, b, c, rt1, rt2 ) !! DLAE2: computes the eigenvalues of a 2-by-2 symmetric matrix !! [ A B ] !! [ B C ]. @@ -25141,15 +25142,15 @@ module stdlib_linalg_lapack_q ! -- lapack is a software package provided by univ. of tennessee, -- ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments - real(qp), intent(in) :: a, b, c - real(qp), intent(out) :: rt1, rt2 + real(${rk}$), intent(in) :: a, b, c + real(${rk}$), intent(out) :: rt1, rt2 ! ===================================================================== ! Local Scalars - real(qp) :: ab, acmn, acmx, adf, df, rt, sm, tb + real(${rk}$) :: ab, acmn, acmx, adf, df, rt, sm, tb ! Intrinsic Functions intrinsic :: abs,sqrt ! Executable Statements @@ -25192,10 +25193,10 @@ module stdlib_linalg_lapack_q rt2 = -half*rt end if return - end subroutine stdlib_qlae2 + end subroutine stdlib_${ri}$lae2 - pure subroutine stdlib_qlaebz( ijob, nitmax, n, mmax, minp, nbmin, abstol,reltol, pivmin, d, & + pure subroutine stdlib_${ri}$laebz( ijob, nitmax, n, mmax, minp, nbmin, abstol,reltol, pivmin, d, & !! DLAEBZ: contains the iteration loops which compute and use the !! function N(w), which is the count of eigenvalues of a symmetric !! tridiagonal matrix T less than or equal to its argument w. It @@ -25234,18 +25235,18 @@ module stdlib_linalg_lapack_q ! Scalar Arguments integer(ilp), intent(in) :: ijob, minp, mmax, n, nbmin, nitmax integer(ilp), intent(out) :: info, mout - real(qp), intent(in) :: abstol, pivmin, reltol + real(${rk}$), intent(in) :: abstol, pivmin, reltol ! Array Arguments integer(ilp), intent(out) :: iwork(*) integer(ilp), intent(inout) :: nab(mmax,*), nval(*) - real(qp), intent(inout) :: ab(mmax,*), c(*) - real(qp), intent(in) :: d(*), e(*), e2(*) - real(qp), intent(out) :: work(*) + real(${rk}$), intent(inout) :: ab(mmax,*), c(*) + real(${rk}$), intent(in) :: d(*), e(*), e2(*) + real(${rk}$), intent(out) :: work(*) ! ===================================================================== ! Local Scalars integer(ilp) :: itmp1, itmp2, j, ji, jit, jp, kf, kfnew, kl, klnew - real(qp) :: tmp1, tmp2 + real(${rk}$) :: tmp1, tmp2 ! Intrinsic Functions intrinsic :: abs,max,min ! Executable Statements @@ -25463,10 +25464,10 @@ module stdlib_linalg_lapack_q info = max( kl+1-kf, 0 ) mout = kl return - end subroutine stdlib_qlaebz + end subroutine stdlib_${ri}$laebz - pure subroutine stdlib_qlaed0( icompq, qsiz, n, d, e, q, ldq, qstore, ldqs,work, iwork, info & + pure subroutine stdlib_${ri}$laed0( icompq, qsiz, n, d, e, q, ldq, qstore, ldqs,work, iwork, info & !! DLAED0: computes all eigenvalues and corresponding eigenvectors of a !! symmetric tridiagonal matrix using the divide and conquer method. ) @@ -25478,15 +25479,15 @@ module stdlib_linalg_lapack_q integer(ilp), intent(out) :: info ! Array Arguments integer(ilp), intent(out) :: iwork(*) - real(qp), intent(inout) :: d(*), e(*), q(ldq,*) - real(qp), intent(out) :: qstore(ldqs,*), work(*) + real(${rk}$), intent(inout) :: d(*), e(*), q(ldq,*) + real(${rk}$), intent(out) :: qstore(ldqs,*), work(*) ! ===================================================================== ! Local Scalars integer(ilp) :: curlvl, curprb, curr, i, igivcl, igivnm, igivpt, indxq, iperm, iprmpt, & iq, iqptr, iwrem, j, k, lgn, matsiz, msd2, smlsiz, smm1, spm1, spm2, submat, subpbs, & tlvls - real(qp) :: temp + real(${rk}$) :: temp ! Intrinsic Functions intrinsic :: abs,real,int,log,max ! Executable Statements @@ -25541,7 +25542,7 @@ module stdlib_linalg_lapack_q if( icompq/=2 ) then ! set up workspaces for eigenvalues only/accumulate new vectors ! routine - temp = log( real( n,KIND=qp) ) / log( two ) + temp = log( real( n,KIND=${rk}$) ) / log( two ) lgn = int( temp,KIND=ilp) if( 2**lgn0 ) then - call stdlib_qgemv( 'T', bsiz1, bsiz1, one, q( qptr( curr ) ),bsiz1, ztemp( 1 ), & + call stdlib_${ri}$gemv( 'T', bsiz1, bsiz1, one, q( qptr( curr ) ),bsiz1, ztemp( 1 ), & 1, zero, z( zptr1 ), 1 ) end if - call stdlib_qcopy( psiz1-bsiz1, ztemp( bsiz1+1 ), 1, z( zptr1+bsiz1 ),1 ) + call stdlib_${ri}$copy( psiz1-bsiz1, ztemp( bsiz1+1 ), 1, z( zptr1+bsiz1 ),1 ) if( bsiz2>0 ) then - call stdlib_qgemv( 'T', bsiz2, bsiz2, one, q( qptr( curr+1 ) ),bsiz2, ztemp( & + call stdlib_${ri}$gemv( 'T', bsiz2, bsiz2, one, q( qptr( curr+1 ) ),bsiz2, ztemp( & psiz1+1 ), 1, zero, z( mid ), 1 ) end if - call stdlib_qcopy( psiz2-bsiz2, ztemp( psiz1+bsiz2+1 ), 1,z( mid+bsiz2 ), 1 ) + call stdlib_${ri}$copy( psiz2-bsiz2, ztemp( psiz1+bsiz2+1 ), 1,z( mid+bsiz2 ), 1 ) ptr = ptr + 2**( tlvls-k ) end do loop_70 return - end subroutine stdlib_qlaeda + end subroutine stdlib_${ri}$laeda - pure subroutine stdlib_qlaein( rightv, noinit, n, h, ldh, wr, wi, vr, vi, b,ldb, work, eps3, & + pure subroutine stdlib_${ri}$laein( rightv, noinit, n, h, ldh, wr, wi, vr, vi, b,ldb, work, eps3, & !! DLAEIN: uses inverse iteration to find a right or left eigenvector !! corresponding to the eigenvalue (WR,WI) of a real upper Hessenberg !! matrix H. @@ -27647,19 +27648,19 @@ module stdlib_linalg_lapack_q logical(lk), intent(in) :: noinit, rightv integer(ilp), intent(out) :: info integer(ilp), intent(in) :: ldb, ldh, n - real(qp), intent(in) :: bignum, eps3, smlnum, wi, wr + real(${rk}$), intent(in) :: bignum, eps3, smlnum, wi, wr ! Array Arguments - real(qp), intent(out) :: b(ldb,*), work(*) - real(qp), intent(in) :: h(ldh,*) - real(qp), intent(inout) :: vi(*), vr(*) + real(${rk}$), intent(out) :: b(ldb,*), work(*) + real(${rk}$), intent(in) :: h(ldh,*) + real(${rk}$), intent(inout) :: vi(*), vr(*) ! ===================================================================== ! Parameters - real(qp), parameter :: tenth = 1.0e-1_qp + real(${rk}$), parameter :: tenth = 1.0e-1_${rk}$ ! Local Scalars character :: normin, trans integer(ilp) :: i, i1, i2, i3, ierr, its, j - real(qp) :: absbii, absbjj, ei, ej, growto, norm, nrmsml, rec, rootn, scale, temp, & + real(${rk}$) :: absbii, absbjj, ei, ej, growto, norm, nrmsml, rec, rootn, scale, temp, & vcrit, vmax, vnorm, w, w1, x, xi, xr, y ! Intrinsic Functions intrinsic :: abs,real,max,sqrt @@ -27667,7 +27668,7 @@ module stdlib_linalg_lapack_q info = 0 ! growto is the threshold used in the acceptance test for an ! eigenvector. - rootn = sqrt( real( n,KIND=qp) ) + rootn = sqrt( real( n,KIND=${rk}$) ) growto = tenth / rootn nrmsml = max( one, eps3*rootn )*smlnum ! form b = h - (wr,wi)*i (except that the subdiagonal elements and @@ -27687,8 +27688,8 @@ module stdlib_linalg_lapack_q end do else ! scale supplied initial vector. - vnorm = stdlib_qnrm2( n, vr, 1 ) - call stdlib_qscal( n, ( eps3*rootn ) / max( vnorm, nrmsml ), vr,1 ) + vnorm = stdlib_${ri}$nrm2( n, vr, 1 ) + call stdlib_${ri}$scal( n, ( eps3*rootn ) / max( vnorm, nrmsml ), vr,1 ) end if if( rightv ) then ! lu decomposition with partial pivoting of b, replacing zero @@ -27750,11 +27751,11 @@ module stdlib_linalg_lapack_q ! solve u*x = scale*v for a right eigenvector ! or u**t*x = scale*v for a left eigenvector, ! overwriting x on v. - call stdlib_qlatrs( 'UPPER', trans, 'NONUNIT', normin, n, b, ldb,vr, scale, work,& + call stdlib_${ri}$latrs( 'UPPER', trans, 'NONUNIT', normin, n, b, ldb,vr, scale, work,& ierr ) normin = 'Y' ! test for sufficient growth in the norm of v. - vnorm = stdlib_qasum( n, vr, 1 ) + vnorm = stdlib_${ri}$asum( n, vr, 1 ) if( vnorm>=growto*scale )go to 120 ! choose new orthogonal starting vector and try again. temp = eps3 / ( rootn+one ) @@ -27768,8 +27769,8 @@ module stdlib_linalg_lapack_q info = 1 120 continue ! normalize eigenvector. - i = stdlib_iqamax( n, vr, 1 ) - call stdlib_qscal( n, one / abs( vr( i ) ), vr, 1 ) + i = stdlib_i${ri}$amax( n, vr, 1 ) + call stdlib_${ri}$scal( n, one / abs( vr( i ) ), vr, 1 ) else ! complex eigenvalue. if( noinit ) then @@ -27780,11 +27781,11 @@ module stdlib_linalg_lapack_q end do else ! scale supplied initial vector. - norm = stdlib_qlapy2( stdlib_qnrm2( n, vr, 1 ), stdlib_qnrm2( n, vi, 1 ) ) + norm = stdlib_${ri}$lapy2( stdlib_${ri}$nrm2( n, vr, 1 ), stdlib_${ri}$nrm2( n, vi, 1 ) ) rec = ( eps3*rootn ) / max( norm, nrmsml ) - call stdlib_qscal( n, rec, vr, 1 ) - call stdlib_qscal( n, rec, vi, 1 ) + call stdlib_${ri}$scal( n, rec, vr, 1 ) + call stdlib_${ri}$scal( n, rec, vi, 1 ) end if if( rightv ) then ! lu decomposition with partial pivoting of b, replacing zero @@ -27796,7 +27797,7 @@ module stdlib_linalg_lapack_q b( i+1, 1 ) = zero end do loop_170: do i = 1, n - 1 - absbii = stdlib_qlapy2( b( i, i ), b( i+1, i ) ) + absbii = stdlib_${ri}$lapy2( b( i, i ), b( i+1, i ) ) ei = h( i+1, i ) if( absbiivcrit ) then rec = one / vmax - call stdlib_qscal( n, rec, vr, 1 ) - call stdlib_qscal( n, rec, vi, 1 ) + call stdlib_${ri}$scal( n, rec, vr, 1 ) + call stdlib_${ri}$scal( n, rec, vi, 1 ) scale = scale*rec vmax = one vcrit = bignum @@ -27928,8 +27929,8 @@ module stdlib_linalg_lapack_q w1 = abs( xr ) + abs( xi ) if( w1>w*bignum ) then rec = one / w1 - call stdlib_qscal( n, rec, vr, 1 ) - call stdlib_qscal( n, rec, vi, 1 ) + call stdlib_${ri}$scal( n, rec, vr, 1 ) + call stdlib_${ri}$scal( n, rec, vi, 1 ) xr = vr( i ) xi = vi( i ) scale = scale*rec @@ -27937,7 +27938,7 @@ module stdlib_linalg_lapack_q end if end if ! divide by diagonal element of b. - call stdlib_qladiv( xr, xi, b( i, i ), b( i+1, i ), vr( i ),vi( i ) ) + call stdlib_${ri}$ladiv( xr, xi, b( i, i ), b( i+1, i ), vr( i ),vi( i ) ) vmax = max( abs( vr( i ) )+abs( vi( i ) ), vmax ) vcrit = bignum / vmax @@ -27954,7 +27955,7 @@ module stdlib_linalg_lapack_q end if end do loop_250 ! test for sufficient growth in the norm of (vr,vi). - vnorm = stdlib_qasum( n, vr, 1 ) + stdlib_qasum( n, vi, 1 ) + vnorm = stdlib_${ri}$asum( n, vr, 1 ) + stdlib_${ri}$asum( n, vi, 1 ) if( vnorm>=growto*scale )go to 280 ! choose a new orthogonal starting vector and try again. y = eps3 / ( rootn+one ) @@ -27974,14 +27975,14 @@ module stdlib_linalg_lapack_q do i = 1, n vnorm = max( vnorm, abs( vr( i ) )+abs( vi( i ) ) ) end do - call stdlib_qscal( n, one / vnorm, vr, 1 ) - call stdlib_qscal( n, one / vnorm, vi, 1 ) + call stdlib_${ri}$scal( n, one / vnorm, vr, 1 ) + call stdlib_${ri}$scal( n, one / vnorm, vi, 1 ) end if return - end subroutine stdlib_qlaein + end subroutine stdlib_${ri}$laein - pure subroutine stdlib_qlaev2( a, b, c, rt1, rt2, cs1, sn1 ) + pure subroutine stdlib_${ri}$laev2( a, b, c, rt1, rt2, cs1, sn1 ) !! DLAEV2: computes the eigendecomposition of a 2-by-2 symmetric matrix !! [ A B ] !! [ B C ]. @@ -27994,8 +27995,8 @@ module stdlib_linalg_lapack_q ! -- lapack is a software package provided by univ. of tennessee, -- ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments - real(qp), intent(in) :: a, b, c - real(qp), intent(out) :: cs1, rt1, rt2, sn1 + real(${rk}$), intent(in) :: a, b, c + real(${rk}$), intent(out) :: cs1, rt1, rt2, sn1 ! ===================================================================== @@ -28003,7 +28004,7 @@ module stdlib_linalg_lapack_q ! Local Scalars integer(ilp) :: sgn1, sgn2 - real(qp) :: ab, acmn, acmx, acs, adf, cs, ct, df, rt, sm, tb, tn + real(${rk}$) :: ab, acmn, acmx, acs, adf, cs, ct, df, rt, sm, tb, tn ! Intrinsic Functions intrinsic :: abs,sqrt ! Executable Statements @@ -28077,10 +28078,10 @@ module stdlib_linalg_lapack_q sn1 = tn end if return - end subroutine stdlib_qlaev2 + end subroutine stdlib_${ri}$laev2 - subroutine stdlib_qlaexc( wantq, n, t, ldt, q, ldq, j1, n1, n2, work,info ) + subroutine stdlib_${ri}$laexc( wantq, n, t, ldt, q, ldq, j1, n1, n2, work,info ) !! DLAEXC: swaps adjacent diagonal blocks T11 and T22 of order 1 or 2 in !! an upper quasi-triangular matrix T by an orthogonal similarity !! transformation. @@ -28096,8 +28097,8 @@ module stdlib_linalg_lapack_q integer(ilp), intent(out) :: info integer(ilp), intent(in) :: j1, ldq, ldt, n, n1, n2 ! Array Arguments - real(qp), intent(inout) :: q(ldq,*), t(ldt,*) - real(qp), intent(out) :: work(*) + real(${rk}$), intent(inout) :: q(ldq,*), t(ldt,*) + real(${rk}$), intent(out) :: work(*) ! ===================================================================== ! Parameters integer(ilp), parameter :: ldd = 4 @@ -28107,10 +28108,10 @@ module stdlib_linalg_lapack_q ! Local Scalars integer(ilp) :: ierr, j2, j3, j4, k, nd - real(qp) :: cs, dnorm, eps, scale, smlnum, sn, t11, t22, t33, tau, tau1, tau2, temp, & + real(${rk}$) :: cs, dnorm, eps, scale, smlnum, sn, t11, t22, t33, tau, tau1, tau2, temp, & thresh, wi1, wi2, wr1, wr2, xnorm ! Local Arrays - real(qp) :: d(ldd,4), u(3), u1(3), u2(3), x(ldx,2) + real(${rk}$) :: d(ldd,4), u(3), u1(3), u2(3), x(ldx,2) ! Intrinsic Functions intrinsic :: abs,max ! Executable Statements @@ -28126,31 +28127,31 @@ module stdlib_linalg_lapack_q t11 = t( j1, j1 ) t22 = t( j2, j2 ) ! determine the transformation to perform the interchange. - call stdlib_qlartg( t( j1, j2 ), t22-t11, cs, sn, temp ) + call stdlib_${ri}$lartg( t( j1, j2 ), t22-t11, cs, sn, temp ) ! apply transformation to the matrix t. - if( j3<=n )call stdlib_qrot( n-j1-1, t( j1, j3 ), ldt, t( j2, j3 ), ldt, cs,sn ) + if( j3<=n )call stdlib_${ri}$rot( n-j1-1, t( j1, j3 ), ldt, t( j2, j3 ), ldt, cs,sn ) - call stdlib_qrot( j1-1, t( 1, j1 ), 1, t( 1, j2 ), 1, cs, sn ) + call stdlib_${ri}$rot( j1-1, t( 1, j1 ), 1, t( 1, j2 ), 1, cs, sn ) t( j1, j1 ) = t22 t( j2, j2 ) = t11 if( wantq ) then ! accumulate transformation in the matrix q. - call stdlib_qrot( n, q( 1, j1 ), 1, q( 1, j2 ), 1, cs, sn ) + call stdlib_${ri}$rot( n, q( 1, j1 ), 1, q( 1, j2 ), 1, cs, sn ) end if else ! swapping involves at least one 2-by-2 block. ! copy the diagonal block of order n1+n2 to the local array d ! and compute its norm. nd = n1 + n2 - call stdlib_qlacpy( 'FULL', nd, nd, t( j1, j1 ), ldt, d, ldd ) - dnorm = stdlib_qlange( 'MAX', nd, nd, d, ldd, work ) + call stdlib_${ri}$lacpy( 'FULL', nd, nd, t( j1, j1 ), ldt, d, ldd ) + dnorm = stdlib_${ri}$lange( 'MAX', nd, nd, d, ldd, work ) ! compute machine-dependent threshold for test for accepting ! swap. - eps = stdlib_qlamch( 'P' ) - smlnum = stdlib_qlamch( 'S' ) / eps + eps = stdlib_${ri}$lamch( 'P' ) + smlnum = stdlib_${ri}$lamch( 'S' ) / eps thresh = max( ten*eps*dnorm, smlnum ) ! solve t11*x - x*t22 = scale*t12 for x. - call stdlib_qlasy2( .false., .false., -1, n1, n2, d, ldd,d( n1+1, n1+1 ), ldd, d( 1,& + call stdlib_${ri}$lasy2( .false., .false., -1, n1, n2, d, ldd,d( n1+1, n1+1 ), ldd, d( 1,& n1+1 ), ldd, scale, x,ldx, xnorm, ierr ) ! swap the adjacent diagonal blocks. k = n1 + n1 + n2 - 3 @@ -28161,24 +28162,24 @@ module stdlib_linalg_lapack_q u( 1 ) = scale u( 2 ) = x( 1, 1 ) u( 3 ) = x( 1, 2 ) - call stdlib_qlarfg( 3, u( 3 ), u, 1, tau ) + call stdlib_${ri}$larfg( 3, u( 3 ), u, 1, tau ) u( 3 ) = one t11 = t( j1, j1 ) ! perform swap provisionally on diagonal block in d. - call stdlib_qlarfx( 'L', 3, 3, u, tau, d, ldd, work ) - call stdlib_qlarfx( 'R', 3, 3, u, tau, d, ldd, work ) + call stdlib_${ri}$larfx( 'L', 3, 3, u, tau, d, ldd, work ) + call stdlib_${ri}$larfx( 'R', 3, 3, u, tau, d, ldd, work ) ! test whether to reject swap. if( max( abs( d( 3, 1 ) ), abs( d( 3, 2 ) ), abs( d( 3,3 )-t11 ) )>thresh )go to & 50 ! accept swap: apply transformation to the entire matrix t. - call stdlib_qlarfx( 'L', 3, n-j1+1, u, tau, t( j1, j1 ), ldt, work ) - call stdlib_qlarfx( 'R', j2, 3, u, tau, t( 1, j1 ), ldt, work ) + call stdlib_${ri}$larfx( 'L', 3, n-j1+1, u, tau, t( j1, j1 ), ldt, work ) + call stdlib_${ri}$larfx( 'R', j2, 3, u, tau, t( 1, j1 ), ldt, work ) t( j3, j1 ) = zero t( j3, j2 ) = zero t( j3, j3 ) = t11 if( wantq ) then ! accumulate transformation in the matrix q. - call stdlib_qlarfx( 'R', n, 3, u, tau, q( 1, j1 ), ldq, work ) + call stdlib_${ri}$larfx( 'R', n, 3, u, tau, q( 1, j1 ), ldq, work ) end if go to 40 20 continue @@ -28189,24 +28190,24 @@ module stdlib_linalg_lapack_q u( 1 ) = -x( 1, 1 ) u( 2 ) = -x( 2, 1 ) u( 3 ) = scale - call stdlib_qlarfg( 3, u( 1 ), u( 2 ), 1, tau ) + call stdlib_${ri}$larfg( 3, u( 1 ), u( 2 ), 1, tau ) u( 1 ) = one t33 = t( j3, j3 ) ! perform swap provisionally on diagonal block in d. - call stdlib_qlarfx( 'L', 3, 3, u, tau, d, ldd, work ) - call stdlib_qlarfx( 'R', 3, 3, u, tau, d, ldd, work ) + call stdlib_${ri}$larfx( 'L', 3, 3, u, tau, d, ldd, work ) + call stdlib_${ri}$larfx( 'R', 3, 3, u, tau, d, ldd, work ) ! test whether to reject swap. if( max( abs( d( 2, 1 ) ), abs( d( 3, 1 ) ), abs( d( 1,1 )-t33 ) )>thresh )go to & 50 ! accept swap: apply transformation to the entire matrix t. - call stdlib_qlarfx( 'R', j3, 3, u, tau, t( 1, j1 ), ldt, work ) - call stdlib_qlarfx( 'L', 3, n-j1, u, tau, t( j1, j2 ), ldt, work ) + call stdlib_${ri}$larfx( 'R', j3, 3, u, tau, t( 1, j1 ), ldt, work ) + call stdlib_${ri}$larfx( 'L', 3, n-j1, u, tau, t( j1, j2 ), ldt, work ) t( j1, j1 ) = t33 t( j2, j1 ) = zero t( j3, j1 ) = zero if( wantq ) then ! accumulate transformation in the matrix q. - call stdlib_qlarfx( 'R', n, 3, u, tau, q( 1, j1 ), ldq, work ) + call stdlib_${ri}$larfx( 'R', n, 3, u, tau, q( 1, j1 ), ldq, work ) end if go to 40 30 continue @@ -28219,55 +28220,55 @@ module stdlib_linalg_lapack_q u1( 1 ) = -x( 1, 1 ) u1( 2 ) = -x( 2, 1 ) u1( 3 ) = scale - call stdlib_qlarfg( 3, u1( 1 ), u1( 2 ), 1, tau1 ) + call stdlib_${ri}$larfg( 3, u1( 1 ), u1( 2 ), 1, tau1 ) u1( 1 ) = one temp = -tau1*( x( 1, 2 )+u1( 2 )*x( 2, 2 ) ) u2( 1 ) = -temp*u1( 2 ) - x( 2, 2 ) u2( 2 ) = -temp*u1( 3 ) u2( 3 ) = scale - call stdlib_qlarfg( 3, u2( 1 ), u2( 2 ), 1, tau2 ) + call stdlib_${ri}$larfg( 3, u2( 1 ), u2( 2 ), 1, tau2 ) u2( 1 ) = one ! perform swap provisionally on diagonal block in d. - call stdlib_qlarfx( 'L', 3, 4, u1, tau1, d, ldd, work ) - call stdlib_qlarfx( 'R', 4, 3, u1, tau1, d, ldd, work ) - call stdlib_qlarfx( 'L', 3, 4, u2, tau2, d( 2, 1 ), ldd, work ) - call stdlib_qlarfx( 'R', 4, 3, u2, tau2, d( 1, 2 ), ldd, work ) + call stdlib_${ri}$larfx( 'L', 3, 4, u1, tau1, d, ldd, work ) + call stdlib_${ri}$larfx( 'R', 4, 3, u1, tau1, d, ldd, work ) + call stdlib_${ri}$larfx( 'L', 3, 4, u2, tau2, d( 2, 1 ), ldd, work ) + call stdlib_${ri}$larfx( 'R', 4, 3, u2, tau2, d( 1, 2 ), ldd, work ) ! test whether to reject swap. if( max( abs( d( 3, 1 ) ), abs( d( 3, 2 ) ), abs( d( 4, 1 ) ),abs( d( 4, 2 ) ) )& >thresh )go to 50 ! accept swap: apply transformation to the entire matrix t. - call stdlib_qlarfx( 'L', 3, n-j1+1, u1, tau1, t( j1, j1 ), ldt, work ) - call stdlib_qlarfx( 'R', j4, 3, u1, tau1, t( 1, j1 ), ldt, work ) - call stdlib_qlarfx( 'L', 3, n-j1+1, u2, tau2, t( j2, j1 ), ldt, work ) - call stdlib_qlarfx( 'R', j4, 3, u2, tau2, t( 1, j2 ), ldt, work ) + call stdlib_${ri}$larfx( 'L', 3, n-j1+1, u1, tau1, t( j1, j1 ), ldt, work ) + call stdlib_${ri}$larfx( 'R', j4, 3, u1, tau1, t( 1, j1 ), ldt, work ) + call stdlib_${ri}$larfx( 'L', 3, n-j1+1, u2, tau2, t( j2, j1 ), ldt, work ) + call stdlib_${ri}$larfx( 'R', j4, 3, u2, tau2, t( 1, j2 ), ldt, work ) t( j3, j1 ) = zero t( j3, j2 ) = zero t( j4, j1 ) = zero t( j4, j2 ) = zero if( wantq ) then ! accumulate transformation in the matrix q. - call stdlib_qlarfx( 'R', n, 3, u1, tau1, q( 1, j1 ), ldq, work ) - call stdlib_qlarfx( 'R', n, 3, u2, tau2, q( 1, j2 ), ldq, work ) + call stdlib_${ri}$larfx( 'R', n, 3, u1, tau1, q( 1, j1 ), ldq, work ) + call stdlib_${ri}$larfx( 'R', n, 3, u2, tau2, q( 1, j2 ), ldq, work ) end if 40 continue if( n2==2 ) then ! standardize new 2-by-2 block t11 - call stdlib_qlanv2( t( j1, j1 ), t( j1, j2 ), t( j2, j1 ),t( j2, j2 ), wr1, wi1, & + call stdlib_${ri}$lanv2( t( j1, j1 ), t( j1, j2 ), t( j2, j1 ),t( j2, j2 ), wr1, wi1, & wr2, wi2, cs, sn ) - call stdlib_qrot( n-j1-1, t( j1, j1+2 ), ldt, t( j2, j1+2 ), ldt,cs, sn ) - call stdlib_qrot( j1-1, t( 1, j1 ), 1, t( 1, j2 ), 1, cs, sn ) - if( wantq )call stdlib_qrot( n, q( 1, j1 ), 1, q( 1, j2 ), 1, cs, sn ) + call stdlib_${ri}$rot( n-j1-1, t( j1, j1+2 ), ldt, t( j2, j1+2 ), ldt,cs, sn ) + call stdlib_${ri}$rot( j1-1, t( 1, j1 ), 1, t( 1, j2 ), 1, cs, sn ) + if( wantq )call stdlib_${ri}$rot( n, q( 1, j1 ), 1, q( 1, j2 ), 1, cs, sn ) end if if( n1==2 ) then ! standardize new 2-by-2 block t22 j3 = j1 + n2 j4 = j3 + 1 - call stdlib_qlanv2( t( j3, j3 ), t( j3, j4 ), t( j4, j3 ),t( j4, j4 ), wr1, wi1, & + call stdlib_${ri}$lanv2( t( j3, j3 ), t( j3, j4 ), t( j4, j3 ),t( j4, j4 ), wr1, wi1, & wr2, wi2, cs, sn ) - if( j3+2<=n )call stdlib_qrot( n-j3-1, t( j3, j3+2 ), ldt, t( j4, j3+2 ),ldt, cs,& + if( j3+2<=n )call stdlib_${ri}$rot( n-j3-1, t( j3, j3+2 ), ldt, t( j4, j3+2 ),ldt, cs,& sn ) - call stdlib_qrot( j3-1, t( 1, j3 ), 1, t( 1, j4 ), 1, cs, sn ) - if( wantq )call stdlib_qrot( n, q( 1, j3 ), 1, q( 1, j4 ), 1, cs, sn ) + call stdlib_${ri}$rot( j3-1, t( 1, j3 ), 1, t( 1, j4 ), 1, cs, sn ) + if( wantq )call stdlib_${ri}$rot( n, q( 1, j3 ), 1, q( 1, j4 ), 1, cs, sn ) end if end if return @@ -28275,10 +28276,10 @@ module stdlib_linalg_lapack_q 50 continue info = 1 return - end subroutine stdlib_qlaexc + end subroutine stdlib_${ri}$laexc - pure subroutine stdlib_qlag2( a, lda, b, ldb, safmin, scale1, scale2, wr1,wr2, wi ) + pure subroutine stdlib_${ri}$lag2( a, lda, b, ldb, safmin, scale1, scale2, wr1,wr2, wi ) !! DLAG2: computes the eigenvalues of a 2 x 2 generalized eigenvalue !! problem A - w B, with scaling as necessary to avoid over-/underflow. !! The scaling factor "s" results in a modified eigenvalue equation @@ -28290,18 +28291,18 @@ module stdlib_linalg_lapack_q ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments integer(ilp), intent(in) :: lda, ldb - real(qp), intent(in) :: safmin - real(qp), intent(out) :: scale1, scale2, wi, wr1, wr2 + real(${rk}$), intent(in) :: safmin + real(${rk}$), intent(out) :: scale1, scale2, wi, wr1, wr2 ! Array Arguments - real(qp), intent(in) :: a(lda,*), b(ldb,*) + real(${rk}$), intent(in) :: a(lda,*), b(ldb,*) ! ===================================================================== ! Parameters - real(qp), parameter :: fuzzy1 = one+1.0e-5_qp + real(${rk}$), parameter :: fuzzy1 = one+1.0e-5_${rk}$ ! Local Scalars - real(qp) :: a11, a12, a21, a22, abi22, anorm, as11, as12, as22, ascale, b11, b12, b22, & + real(${rk}$) :: a11, a12, a21, a22, abi22, anorm, as11, as12, as22, ascale, b11, b12, b22, & binv11, binv22, bmin, bnorm, bscale, bsize, c1, c2, c3, c4, c5, diff, discr, pp, qq, r,& rtmax, rtmin, s1, s2, safmax, shift, ss, sum, wabs, wbig, wdet, wscale, wsize, & wsmall @@ -28459,10 +28460,10 @@ module stdlib_linalg_lapack_q end if end if return - end subroutine stdlib_qlag2 + end subroutine stdlib_${ri}$lag2 - pure subroutine stdlib_qlag2s( m, n, a, lda, sa, ldsa, info ) + pure subroutine stdlib_${ri}$lag2s( m, n, a, lda, sa, ldsa, info ) !! DLAG2S: converts a DOUBLE PRECISION matrix, SA, to a SINGLE !! PRECISION matrix, A. !! RMAX is the overflow for the SINGLE PRECISION arithmetic @@ -28477,11 +28478,11 @@ module stdlib_linalg_lapack_q integer(ilp), intent(in) :: lda, ldsa, m, n ! Array Arguments real(dp), intent(out) :: sa(ldsa,*) - real(qp), intent(in) :: a(lda,*) + real(${rk}$), intent(in) :: a(lda,*) ! ===================================================================== ! Local Scalars integer(ilp) :: i, j - real(qp) :: rmax + real(${rk}$) :: rmax ! Executable Statements rmax = stdlib_dlamch( 'O' ) do j = 1, n @@ -28496,10 +28497,10 @@ module stdlib_linalg_lapack_q info = 0 30 continue return - end subroutine stdlib_qlag2s + end subroutine stdlib_${ri}$lag2s - pure subroutine stdlib_qlags2( upper, a1, a2, a3, b1, b2, b3, csu, snu, csv,snv, csq, snq ) + pure subroutine stdlib_${ri}$lags2( upper, a1, a2, a3, b1, b2, b3, csu, snu, csv,snv, csq, snq ) !! DLAGS2: computes 2-by-2 orthogonal matrices U, V and Q, such !! that if ( UPPER ) then !! U**T *A*Q = U**T *( A1 A2 )*Q = ( x 0 ) @@ -28523,12 +28524,12 @@ module stdlib_linalg_lapack_q ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments logical(lk), intent(in) :: upper - real(qp), intent(in) :: a1, a2, a3, b1, b2, b3 - real(qp), intent(out) :: csq, csu, csv, snq, snu, snv + real(${rk}$), intent(in) :: a1, a2, a3, b1, b2, b3 + real(${rk}$), intent(out) :: csq, csu, csv, snq, snu, snv ! ===================================================================== ! Local Scalars - real(qp) :: a, aua11, aua12, aua21, aua22, avb11, avb12, avb21, avb22, b, c, csl, csr, & + real(${rk}$) :: a, aua11, aua12, aua21, aua22, avb11, avb12, avb21, avb22, b, c, csl, csr, & d, r, s1, s2, snl, snr, ua11, ua11r, ua12, ua21, ua22, ua22r, vb11, vb11r, vb12, vb21, & vb22, vb22r ! Intrinsic Functions @@ -28544,7 +28545,7 @@ module stdlib_linalg_lapack_q ! the svd of real 2-by-2 triangular c ! ( csl -snl )*( a b )*( csr snr ) = ( r 0 ) ! ( snl csl ) ( 0 d ) ( -snr csr ) ( 0 t ) - call stdlib_qlasv2( a, b, d, s1, s2, snr, csr, snl, csl ) + call stdlib_${ri}$lasv2( a, b, d, s1, s2, snr, csr, snl, csl ) if( abs( csl )>=abs( snl ) .or. abs( csr )>=abs( snr ) )then ! compute the (1,1) and (1,2) elements of u**t *a and v**t *b, ! and (1,2) element of |u|**t *|a| and |v|**t *|b|. @@ -28558,12 +28559,12 @@ module stdlib_linalg_lapack_q if( ( abs( ua11r )+abs( ua12 ) )/=zero ) then if( aua12 / ( abs( ua11r )+abs( ua12 ) )<=avb12 /( abs( vb11r )+abs( vb12 ) ) & ) then - call stdlib_qlartg( -ua11r, ua12, csq, snq, r ) + call stdlib_${ri}$lartg( -ua11r, ua12, csq, snq, r ) else - call stdlib_qlartg( -vb11r, vb12, csq, snq, r ) + call stdlib_${ri}$lartg( -vb11r, vb12, csq, snq, r ) end if else - call stdlib_qlartg( -vb11r, vb12, csq, snq, r ) + call stdlib_${ri}$lartg( -vb11r, vb12, csq, snq, r ) end if csu = csl snu = -snl @@ -28582,12 +28583,12 @@ module stdlib_linalg_lapack_q if( ( abs( ua21 )+abs( ua22 ) )/=zero ) then if( aua22 / ( abs( ua21 )+abs( ua22 ) )<=avb22 /( abs( vb21 )+abs( vb22 ) ) ) & then - call stdlib_qlartg( -ua21, ua22, csq, snq, r ) + call stdlib_${ri}$lartg( -ua21, ua22, csq, snq, r ) else - call stdlib_qlartg( -vb21, vb22, csq, snq, r ) + call stdlib_${ri}$lartg( -vb21, vb22, csq, snq, r ) end if else - call stdlib_qlartg( -vb21, vb22, csq, snq, r ) + call stdlib_${ri}$lartg( -vb21, vb22, csq, snq, r ) end if csu = snl snu = csl @@ -28604,7 +28605,7 @@ module stdlib_linalg_lapack_q ! the svd of real 2-by-2 triangular c ! ( csl -snl )*( a 0 )*( csr snr ) = ( r 0 ) ! ( snl csl ) ( c d ) ( -snr csr ) ( 0 t ) - call stdlib_qlasv2( a, c, d, s1, s2, snr, csr, snl, csl ) + call stdlib_${ri}$lasv2( a, c, d, s1, s2, snr, csr, snl, csl ) if( abs( csr )>=abs( snr ) .or. abs( csl )>=abs( snl ) )then ! compute the (2,1) and (2,2) elements of u**t *a and v**t *b, ! and (2,1) element of |u|**t *|a| and |v|**t *|b|. @@ -28618,12 +28619,12 @@ module stdlib_linalg_lapack_q if( ( abs( ua21 )+abs( ua22r ) )/=zero ) then if( aua21 / ( abs( ua21 )+abs( ua22r ) )<=avb21 /( abs( vb21 )+abs( vb22r ) ) & ) then - call stdlib_qlartg( ua22r, ua21, csq, snq, r ) + call stdlib_${ri}$lartg( ua22r, ua21, csq, snq, r ) else - call stdlib_qlartg( vb22r, vb21, csq, snq, r ) + call stdlib_${ri}$lartg( vb22r, vb21, csq, snq, r ) end if else - call stdlib_qlartg( vb22r, vb21, csq, snq, r ) + call stdlib_${ri}$lartg( vb22r, vb21, csq, snq, r ) end if csu = csr snu = -snr @@ -28642,12 +28643,12 @@ module stdlib_linalg_lapack_q if( ( abs( ua11 )+abs( ua12 ) )/=zero ) then if( aua11 / ( abs( ua11 )+abs( ua12 ) )<=avb11 /( abs( vb11 )+abs( vb12 ) ) ) & then - call stdlib_qlartg( ua12, ua11, csq, snq, r ) + call stdlib_${ri}$lartg( ua12, ua11, csq, snq, r ) else - call stdlib_qlartg( vb12, vb11, csq, snq, r ) + call stdlib_${ri}$lartg( vb12, vb11, csq, snq, r ) end if else - call stdlib_qlartg( vb12, vb11, csq, snq, r ) + call stdlib_${ri}$lartg( vb12, vb11, csq, snq, r ) end if csu = snr snu = csr @@ -28656,10 +28657,10 @@ module stdlib_linalg_lapack_q end if end if return - end subroutine stdlib_qlags2 + end subroutine stdlib_${ri}$lags2 - pure subroutine stdlib_qlagtf( n, a, lambda, b, c, tol, d, in, info ) + pure subroutine stdlib_${ri}$lagtf( n, a, lambda, b, c, tol, d, in, info ) !! DLAGTF: factorizes the matrix (T - lambda*I), where T is an n by n !! tridiagonal matrix and lambda is a scalar, as !! T - lambda*I = PLU, @@ -28678,16 +28679,16 @@ module stdlib_linalg_lapack_q ! Scalar Arguments integer(ilp), intent(out) :: info integer(ilp), intent(in) :: n - real(qp), intent(in) :: lambda, tol + real(${rk}$), intent(in) :: lambda, tol ! Array Arguments integer(ilp), intent(out) :: in(*) - real(qp), intent(inout) :: a(*), b(*), c(*) - real(qp), intent(out) :: d(*) + real(${rk}$), intent(inout) :: a(*), b(*), c(*) + real(${rk}$), intent(out) :: d(*) ! ===================================================================== ! Local Scalars integer(ilp) :: k - real(qp) :: eps, mult, piv1, piv2, scale1, scale2, temp, tl + real(${rk}$) :: eps, mult, piv1, piv2, scale1, scale2, temp, tl ! Intrinsic Functions intrinsic :: abs,max ! Executable Statements @@ -28704,7 +28705,7 @@ module stdlib_linalg_lapack_q if( a( 1 )==zero )in( 1 ) = 1 return end if - eps = stdlib_qlamch( 'EPSILON' ) + eps = stdlib_${ri}$lamch( 'EPSILON' ) tl = max( tol, eps ) scale1 = abs( a( 1 ) ) + abs( b( 1 ) ) loop_10: do k = 1, n - 1 @@ -28747,10 +28748,10 @@ module stdlib_linalg_lapack_q end do loop_10 if( ( abs( a( n ) )<=scale1*tl ) .and. ( in( n )==0 ) )in( n ) = n return - end subroutine stdlib_qlagtf + end subroutine stdlib_${ri}$lagtf - pure subroutine stdlib_qlagtm( trans, n, nrhs, alpha, dl, d, du, x, ldx, beta,b, ldb ) + pure subroutine stdlib_${ri}$lagtm( trans, n, nrhs, alpha, dl, d, du, x, ldx, beta,b, ldb ) !! DLAGTM: performs a matrix-vector product of the form !! B := alpha * A * X + beta * B !! where A is a tridiagonal matrix of order N, B and X are N by NRHS @@ -28763,10 +28764,10 @@ module stdlib_linalg_lapack_q ! Scalar Arguments character, intent(in) :: trans integer(ilp), intent(in) :: ldb, ldx, n, nrhs - real(qp), intent(in) :: alpha, beta + real(${rk}$), intent(in) :: alpha, beta ! Array Arguments - real(qp), intent(inout) :: b(ldb,*) - real(qp), intent(in) :: d(*), dl(*), du(*), x(ldx,*) + real(${rk}$), intent(inout) :: b(ldb,*) + real(${rk}$), intent(in) :: d(*), dl(*), du(*), x(ldx,*) ! ===================================================================== ! Local Scalars @@ -28849,10 +28850,10 @@ module stdlib_linalg_lapack_q end if end if return - end subroutine stdlib_qlagtm + end subroutine stdlib_${ri}$lagtm - pure subroutine stdlib_qlagts( job, n, a, b, c, d, in, y, tol, info ) + pure subroutine stdlib_${ri}$lagts( job, n, a, b, c, d, in, y, tol, info ) !! DLAGTS: may be used to solve one of the systems of equations !! (T - lambda*I)*x = y or (T - lambda*I)**T*x = y, !! where T is an n by n tridiagonal matrix, for x, following the @@ -28868,16 +28869,16 @@ module stdlib_linalg_lapack_q ! Scalar Arguments integer(ilp), intent(out) :: info integer(ilp), intent(in) :: job, n - real(qp), intent(inout) :: tol + real(${rk}$), intent(inout) :: tol ! Array Arguments integer(ilp), intent(in) :: in(*) - real(qp), intent(in) :: a(*), b(*), c(*), d(*) - real(qp), intent(inout) :: y(*) + real(${rk}$), intent(in) :: a(*), b(*), c(*), d(*) + real(${rk}$), intent(inout) :: y(*) ! ===================================================================== ! Local Scalars integer(ilp) :: k - real(qp) :: absak, ak, bignum, eps, pert, sfmin, temp + real(${rk}$) :: absak, ak, bignum, eps, pert, sfmin, temp ! Intrinsic Functions intrinsic :: abs,max,sign ! Executable Statements @@ -28892,8 +28893,8 @@ module stdlib_linalg_lapack_q return end if if( n==0 )return - eps = stdlib_qlamch( 'EPSILON' ) - sfmin = stdlib_qlamch( 'SAFE MINIMUM' ) + eps = stdlib_${ri}$lamch( 'EPSILON' ) + sfmin = stdlib_${ri}$lamch( 'SAFE MINIMUM' ) bignum = one / sfmin if( job<0 ) then if( tol<=zero ) then @@ -29046,10 +29047,10 @@ module stdlib_linalg_lapack_q end if end do end if - end subroutine stdlib_qlagts + end subroutine stdlib_${ri}$lagts - pure subroutine stdlib_qlagv2( a, lda, b, ldb, alphar, alphai, beta, csl, snl,csr, snr ) + pure subroutine stdlib_${ri}$lagv2( a, lda, b, ldb, alphar, alphai, beta, csl, snl,csr, snr ) !! DLAGV2: computes the Generalized Schur factorization of a real 2-by-2 !! matrix pencil (A,B) where B is upper triangular. This routine !! computes orthogonal (rotation) matrices given by CSL, SNL and CSR, @@ -29073,20 +29074,20 @@ module stdlib_linalg_lapack_q ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments integer(ilp), intent(in) :: lda, ldb - real(qp), intent(out) :: csl, csr, snl, snr + real(${rk}$), intent(out) :: csl, csr, snl, snr ! Array Arguments - real(qp), intent(inout) :: a(lda,*), b(ldb,*) - real(qp), intent(out) :: alphai(2), alphar(2), beta(2) + real(${rk}$), intent(inout) :: a(lda,*), b(ldb,*) + real(${rk}$), intent(out) :: alphai(2), alphar(2), beta(2) ! ===================================================================== ! Local Scalars - real(qp) :: anorm, ascale, bnorm, bscale, h1, h2, h3, qq, r, rr, safmin, scale1, & + real(${rk}$) :: anorm, ascale, bnorm, bscale, h1, h2, h3, qq, r, rr, safmin, scale1, & scale2, t, ulp, wi, wr1, wr2 ! Intrinsic Functions intrinsic :: abs,max ! Executable Statements - safmin = stdlib_qlamch( 'S' ) - ulp = stdlib_qlamch( 'P' ) + safmin = stdlib_${ri}$lamch( 'S' ) + ulp = stdlib_${ri}$lamch( 'P' ) ! scale a anorm = max( abs( a( 1, 1 ) )+abs( a( 2, 1 ) ),abs( a( 1, 2 ) )+abs( a( 2, 2 ) ), & safmin ) @@ -29112,20 +29113,20 @@ module stdlib_linalg_lapack_q wi = zero ! check if b is singular else if( abs( b( 1, 1 ) )<=ulp ) then - call stdlib_qlartg( a( 1, 1 ), a( 2, 1 ), csl, snl, r ) + call stdlib_${ri}$lartg( a( 1, 1 ), a( 2, 1 ), csl, snl, r ) csr = one snr = zero - call stdlib_qrot( 2, a( 1, 1 ), lda, a( 2, 1 ), lda, csl, snl ) - call stdlib_qrot( 2, b( 1, 1 ), ldb, b( 2, 1 ), ldb, csl, snl ) + call stdlib_${ri}$rot( 2, a( 1, 1 ), lda, a( 2, 1 ), lda, csl, snl ) + call stdlib_${ri}$rot( 2, b( 1, 1 ), ldb, b( 2, 1 ), ldb, csl, snl ) a( 2, 1 ) = zero b( 1, 1 ) = zero b( 2, 1 ) = zero wi = zero else if( abs( b( 2, 2 ) )<=ulp ) then - call stdlib_qlartg( a( 2, 2 ), a( 2, 1 ), csr, snr, t ) + call stdlib_${ri}$lartg( a( 2, 2 ), a( 2, 1 ), csr, snr, t ) snr = -snr - call stdlib_qrot( 2, a( 1, 1 ), 1, a( 1, 2 ), 1, csr, snr ) - call stdlib_qrot( 2, b( 1, 1 ), 1, b( 1, 2 ), 1, csr, snr ) + call stdlib_${ri}$rot( 2, a( 1, 1 ), 1, a( 1, 2 ), 1, csr, snr ) + call stdlib_${ri}$rot( 2, b( 1, 1 ), 1, b( 1, 2 ), 1, csr, snr ) csl = one snl = zero a( 2, 1 ) = zero @@ -29134,26 +29135,26 @@ module stdlib_linalg_lapack_q wi = zero else ! b is nonsingular, first compute the eigenvalues of (a,b) - call stdlib_qlag2( a, lda, b, ldb, safmin, scale1, scale2, wr1, wr2,wi ) + call stdlib_${ri}$lag2( a, lda, b, ldb, safmin, scale1, scale2, wr1, wr2,wi ) if( wi==zero ) then ! two real eigenvalues, compute s*a-w*b h1 = scale1*a( 1, 1 ) - wr1*b( 1, 1 ) h2 = scale1*a( 1, 2 ) - wr1*b( 1, 2 ) h3 = scale1*a( 2, 2 ) - wr1*b( 2, 2 ) - rr = stdlib_qlapy2( h1, h2 ) - qq = stdlib_qlapy2( scale1*a( 2, 1 ), h3 ) + rr = stdlib_${ri}$lapy2( h1, h2 ) + qq = stdlib_${ri}$lapy2( scale1*a( 2, 1 ), h3 ) if( rr>qq ) then ! find right rotation matrix to zero 1,1 element of ! (sa - wb) - call stdlib_qlartg( h2, h1, csr, snr, t ) + call stdlib_${ri}$lartg( h2, h1, csr, snr, t ) else ! find right rotation matrix to zero 2,1 element of ! (sa - wb) - call stdlib_qlartg( h3, scale1*a( 2, 1 ), csr, snr, t ) + call stdlib_${ri}$lartg( h3, scale1*a( 2, 1 ), csr, snr, t ) end if snr = -snr - call stdlib_qrot( 2, a( 1, 1 ), 1, a( 1, 2 ), 1, csr, snr ) - call stdlib_qrot( 2, b( 1, 1 ), 1, b( 1, 2 ), 1, csr, snr ) + call stdlib_${ri}$rot( 2, a( 1, 1 ), 1, a( 1, 2 ), 1, csr, snr ) + call stdlib_${ri}$rot( 2, b( 1, 1 ), 1, b( 1, 2 ), 1, csr, snr ) ! compute inf norms of a and b h1 = max( abs( a( 1, 1 ) )+abs( a( 1, 2 ) ),abs( a( 2, 1 ) )+abs( a( 2, 2 ) ) ) @@ -29161,26 +29162,26 @@ module stdlib_linalg_lapack_q if( ( scale1*h1 )>=abs( wr1 )*h2 ) then ! find left rotation matrix q to zero out b(2,1) - call stdlib_qlartg( b( 1, 1 ), b( 2, 1 ), csl, snl, r ) + call stdlib_${ri}$lartg( b( 1, 1 ), b( 2, 1 ), csl, snl, r ) else ! find left rotation matrix q to zero out a(2,1) - call stdlib_qlartg( a( 1, 1 ), a( 2, 1 ), csl, snl, r ) + call stdlib_${ri}$lartg( a( 1, 1 ), a( 2, 1 ), csl, snl, r ) end if - call stdlib_qrot( 2, a( 1, 1 ), lda, a( 2, 1 ), lda, csl, snl ) - call stdlib_qrot( 2, b( 1, 1 ), ldb, b( 2, 1 ), ldb, csl, snl ) + call stdlib_${ri}$rot( 2, a( 1, 1 ), lda, a( 2, 1 ), lda, csl, snl ) + call stdlib_${ri}$rot( 2, b( 1, 1 ), ldb, b( 2, 1 ), ldb, csl, snl ) a( 2, 1 ) = zero b( 2, 1 ) = zero else ! a pair of complex conjugate eigenvalues ! first compute the svd of the matrix b - call stdlib_qlasv2( b( 1, 1 ), b( 1, 2 ), b( 2, 2 ), r, t, snr,csr, snl, csl ) + call stdlib_${ri}$lasv2( b( 1, 1 ), b( 1, 2 ), b( 2, 2 ), r, t, snr,csr, snl, csl ) ! form (a,b) := q(a,b)z**t where q is left rotation matrix and - ! z is right rotation matrix computed from stdlib_qlasv2 - call stdlib_qrot( 2, a( 1, 1 ), lda, a( 2, 1 ), lda, csl, snl ) - call stdlib_qrot( 2, b( 1, 1 ), ldb, b( 2, 1 ), ldb, csl, snl ) - call stdlib_qrot( 2, a( 1, 1 ), 1, a( 1, 2 ), 1, csr, snr ) - call stdlib_qrot( 2, b( 1, 1 ), 1, b( 1, 2 ), 1, csr, snr ) + ! z is right rotation matrix computed from stdlib_${ri}$lasv2 + call stdlib_${ri}$rot( 2, a( 1, 1 ), lda, a( 2, 1 ), lda, csl, snl ) + call stdlib_${ri}$rot( 2, b( 1, 1 ), ldb, b( 2, 1 ), ldb, csl, snl ) + call stdlib_${ri}$rot( 2, a( 1, 1 ), 1, a( 1, 2 ), 1, csr, snr ) + call stdlib_${ri}$rot( 2, b( 1, 1 ), 1, b( 1, 2 ), 1, csr, snr ) b( 2, 1 ) = zero b( 1, 2 ) = zero end if @@ -29210,10 +29211,10 @@ module stdlib_linalg_lapack_q beta( 2 ) = one end if return - end subroutine stdlib_qlagv2 + end subroutine stdlib_${ri}$lagv2 - pure subroutine stdlib_qlahqr( wantt, wantz, n, ilo, ihi, h, ldh, wr, wi,iloz, ihiz, z, ldz, & + pure subroutine stdlib_${ri}$lahqr( wantt, wantz, n, ilo, ihi, h, ldh, wr, wi,iloz, ihiz, z, ldz, & !! DLAHQR: is an auxiliary routine called by DHSEQR to update the !! eigenvalues and Schur decomposition already computed by DHSEQR, by !! dealing with the Hessenberg submatrix in rows and columns ILO to @@ -29227,22 +29228,22 @@ module stdlib_linalg_lapack_q integer(ilp), intent(out) :: info logical(lk), intent(in) :: wantt, wantz ! Array Arguments - real(qp), intent(inout) :: h(ldh,*), z(ldz,*) - real(qp), intent(out) :: wi(*), wr(*) + real(${rk}$), intent(inout) :: h(ldh,*), z(ldz,*) + real(${rk}$), intent(out) :: wi(*), wr(*) ! ========================================================= ! Parameters - real(qp), parameter :: dat1 = 3.0_qp/4.0_qp - real(qp), parameter :: dat2 = -0.4375_qp + real(${rk}$), parameter :: dat1 = 3.0_${rk}$/4.0_${rk}$ + real(${rk}$), parameter :: dat2 = -0.4375_${rk}$ integer(ilp), parameter :: kexsh = 10 ! Local Scalars - real(qp) :: aa, ab, ba, bb, cs, det, h11, h12, h21, h21s, h22, rt1i, rt1r, rt2i, rt2r, & + real(${rk}$) :: aa, ab, ba, bb, cs, det, h11, h12, h21, h21s, h22, rt1i, rt1r, rt2i, rt2r, & rtdisc, s, safmax, safmin, smlnum, sn, sum, t1, t2, t3, tr, tst, ulp, v2, v3 integer(ilp) :: i, i1, i2, its, itmax, j, k, l, m, nh, nr, nz, kdefl ! Local Arrays - real(qp) :: v(3) + real(${rk}$) :: v(3) ! Intrinsic Functions intrinsic :: abs,real,max,min,sqrt ! Executable Statements @@ -29263,11 +29264,11 @@ module stdlib_linalg_lapack_q nh = ihi - ilo + 1 nz = ihiz - iloz + 1 ! set machine-dependent constants for the stopping criterion. - safmin = stdlib_qlamch( 'SAFE MINIMUM' ) + safmin = stdlib_${ri}$lamch( 'SAFE MINIMUM' ) safmax = one / safmin - call stdlib_qlabad( safmin, safmax ) - ulp = stdlib_qlamch( 'PRECISION' ) - smlnum = safmin*( real( nh,KIND=qp) / ulp ) + call stdlib_${ri}$labad( safmin, safmax ) + ulp = stdlib_${ri}$lamch( 'PRECISION' ) + smlnum = safmin*( real( nh,KIND=${rk}$) / ulp ) ! i1 and i2 are the indices of the first row and last column of h ! to which transformations must be applied. if eigenvalues only are ! being computed, i1 and i2 are set inside the main loop. @@ -29372,7 +29373,7 @@ module stdlib_linalg_lapack_q rt1i = rtdisc*s rt2i = -rt1i else - ! ==== realshifts (use only one of them,KIND=qp) ==== + ! ==== realshifts (use only one of them,KIND=${rk}$) ==== rt1r = tr + rtdisc rt2r = tr - rtdisc if( abs( rt1r-h22 )<=abs( rt2r-h22 ) ) then @@ -29418,8 +29419,8 @@ module stdlib_linalg_lapack_q ! chases the bulge one step toward the bottom of the active ! submatrix. nr is the order of g. nr = min( 3, i-k+1 ) - if( k>m )call stdlib_qcopy( nr, h( k, k-1 ), 1, v, 1 ) - call stdlib_qlarfg( nr, v( 1 ), v( 2 ), 1, t1 ) + if( k>m )call stdlib_${ri}$copy( nr, h( k, k-1 ), 1, v, 1 ) + call stdlib_${ri}$larfg( nr, v( 1 ), v( 2 ), 1, t1 ) if( k>m ) then h( k, k-1 ) = v( 1 ) h( k+1, k-1 ) = zero @@ -29499,17 +29500,17 @@ module stdlib_linalg_lapack_q ! h(i-1,i-2) is negligible: a pair of eigenvalues have converged. ! transform the 2-by-2 submatrix to standard schur form, ! and compute and store the eigenvalues. - call stdlib_qlanv2( h( i-1, i-1 ), h( i-1, i ), h( i, i-1 ),h( i, i ), wr( i-1 ), & + call stdlib_${ri}$lanv2( h( i-1, i-1 ), h( i-1, i ), h( i, i-1 ),h( i, i ), wr( i-1 ), & wi( i-1 ), wr( i ), wi( i ),cs, sn ) if( wantt ) then ! apply the transformation to the rest of h. - if( i2>i )call stdlib_qrot( i2-i, h( i-1, i+1 ), ldh, h( i, i+1 ), ldh,cs, sn ) + if( i2>i )call stdlib_${ri}$rot( i2-i, h( i-1, i+1 ), ldh, h( i, i+1 ), ldh,cs, sn ) - call stdlib_qrot( i-i1-1, h( i1, i-1 ), 1, h( i1, i ), 1, cs, sn ) + call stdlib_${ri}$rot( i-i1-1, h( i1, i-1 ), 1, h( i1, i ), 1, cs, sn ) end if if( wantz ) then ! apply the transformation to z. - call stdlib_qrot( nz, z( iloz, i-1 ), 1, z( iloz, i ), 1, cs, sn ) + call stdlib_${ri}$rot( nz, z( iloz, i-1 ), 1, z( iloz, i ), 1, cs, sn ) end if end if ! reset deflation counter @@ -29519,10 +29520,10 @@ module stdlib_linalg_lapack_q go to 20 160 continue return - end subroutine stdlib_qlahqr + end subroutine stdlib_${ri}$lahqr - pure subroutine stdlib_qlahr2( n, k, nb, a, lda, tau, t, ldt, y, ldy ) + pure subroutine stdlib_${ri}$lahr2( n, k, nb, a, lda, tau, t, ldt, y, ldy ) !! DLAHR2: reduces the first NB columns of A real general n-BY-(n-k+1) !! matrix A so that elements below the k-th subdiagonal are zero. The !! reduction is performed by an orthogonal similarity transformation @@ -29535,13 +29536,13 @@ module stdlib_linalg_lapack_q ! Scalar Arguments integer(ilp), intent(in) :: k, lda, ldt, ldy, n, nb ! Array Arguments - real(qp), intent(inout) :: a(lda,*) - real(qp), intent(out) :: t(ldt,nb), tau(nb), y(ldy,nb) + real(${rk}$), intent(inout) :: a(lda,*) + real(${rk}$), intent(out) :: t(ldt,nb), tau(nb), y(ldy,nb) ! ===================================================================== ! Local Scalars integer(ilp) :: i - real(qp) :: ei + real(${rk}$) :: ei ! Intrinsic Functions intrinsic :: min ! Executable Statements @@ -29551,7 +29552,7 @@ module stdlib_linalg_lapack_q if( i>1 ) then ! update a(k+1:n,i) ! update i-th column of a - y * v**t - call stdlib_qgemv( 'NO TRANSPOSE', n-k, i-1, -one, y(k+1,1), ldy,a( k+i-1, 1 ), & + call stdlib_${ri}$gemv( 'NO TRANSPOSE', n-k, i-1, -one, y(k+1,1), ldy,a( k+i-1, 1 ), & lda, one, a( k+1, i ), 1 ) ! apply i - v * t**t * v**t to this column (call it b) from the ! left, using the last column of t as workspace @@ -29559,58 +29560,58 @@ module stdlib_linalg_lapack_q ! ( v2 ) ( b2 ) ! where v1 is unit lower triangular ! w := v1**t * b1 - call stdlib_qcopy( i-1, a( k+1, i ), 1, t( 1, nb ), 1 ) - call stdlib_qtrmv( 'LOWER', 'TRANSPOSE', 'UNIT',i-1, a( k+1, 1 ),lda, t( 1, nb ),& + call stdlib_${ri}$copy( i-1, a( k+1, i ), 1, t( 1, nb ), 1 ) + call stdlib_${ri}$trmv( 'LOWER', 'TRANSPOSE', 'UNIT',i-1, a( k+1, 1 ),lda, t( 1, nb ),& 1 ) ! w := w + v2**t * b2 - call stdlib_qgemv( 'TRANSPOSE', n-k-i+1, i-1,one, a( k+i, 1 ),lda, a( k+i, i ), & + call stdlib_${ri}$gemv( 'TRANSPOSE', n-k-i+1, i-1,one, a( k+i, 1 ),lda, a( k+i, i ), & 1, one, t( 1, nb ), 1 ) ! w := t**t * w - call stdlib_qtrmv( 'UPPER', 'TRANSPOSE', 'NON-UNIT',i-1, t, ldt,t( 1, nb ), 1 ) + call stdlib_${ri}$trmv( 'UPPER', 'TRANSPOSE', 'NON-UNIT',i-1, t, ldt,t( 1, nb ), 1 ) ! b2 := b2 - v2*w - call stdlib_qgemv( 'NO TRANSPOSE', n-k-i+1, i-1, -one,a( k+i, 1 ),lda, t( 1, nb )& + call stdlib_${ri}$gemv( 'NO TRANSPOSE', n-k-i+1, i-1, -one,a( k+i, 1 ),lda, t( 1, nb )& , 1, one, a( k+i, i ), 1 ) ! b1 := b1 - v1*w - call stdlib_qtrmv( 'LOWER', 'NO TRANSPOSE','UNIT', i-1,a( k+1, 1 ), lda, t( 1, & + call stdlib_${ri}$trmv( 'LOWER', 'NO TRANSPOSE','UNIT', i-1,a( k+1, 1 ), lda, t( 1, & nb ), 1 ) - call stdlib_qaxpy( i-1, -one, t( 1, nb ), 1, a( k+1, i ), 1 ) + call stdlib_${ri}$axpy( i-1, -one, t( 1, nb ), 1, a( k+1, i ), 1 ) a( k+i-1, i-1 ) = ei end if ! generate the elementary reflector h(i) to annihilate ! a(k+i+1:n,i) - call stdlib_qlarfg( n-k-i+1, a( k+i, i ), a( min( k+i+1, n ), i ), 1,tau( i ) ) + call stdlib_${ri}$larfg( n-k-i+1, a( k+i, i ), a( min( k+i+1, n ), i ), 1,tau( i ) ) ei = a( k+i, i ) a( k+i, i ) = one ! compute y(k+1:n,i) - call stdlib_qgemv( 'NO TRANSPOSE', n-k, n-k-i+1,one, a( k+1, i+1 ),lda, a( k+i, i ),& + call stdlib_${ri}$gemv( 'NO TRANSPOSE', n-k, n-k-i+1,one, a( k+1, i+1 ),lda, a( k+i, i ),& 1, zero, y( k+1, i ), 1 ) - call stdlib_qgemv( 'TRANSPOSE', n-k-i+1, i-1,one, a( k+i, 1 ), lda,a( k+i, i ), 1, & + call stdlib_${ri}$gemv( 'TRANSPOSE', n-k-i+1, i-1,one, a( k+i, 1 ), lda,a( k+i, i ), 1, & zero, t( 1, i ), 1 ) - call stdlib_qgemv( 'NO TRANSPOSE', n-k, i-1, -one,y( k+1, 1 ), ldy,t( 1, i ), 1, & + call stdlib_${ri}$gemv( 'NO TRANSPOSE', n-k, i-1, -one,y( k+1, 1 ), ldy,t( 1, i ), 1, & one, y( k+1, i ), 1 ) - call stdlib_qscal( n-k, tau( i ), y( k+1, i ), 1 ) + call stdlib_${ri}$scal( n-k, tau( i ), y( k+1, i ), 1 ) ! compute t(1:i,i) - call stdlib_qscal( i-1, -tau( i ), t( 1, i ), 1 ) - call stdlib_qtrmv( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT',i-1, t, ldt,t( 1, i ), 1 ) + call stdlib_${ri}$scal( i-1, -tau( i ), t( 1, i ), 1 ) + call stdlib_${ri}$trmv( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT',i-1, t, ldt,t( 1, i ), 1 ) t( i, i ) = tau( i ) end do loop_10 a( k+nb, nb ) = ei ! compute y(1:k,1:nb) - call stdlib_qlacpy( 'ALL', k, nb, a( 1, 2 ), lda, y, ldy ) - call stdlib_qtrmm( 'RIGHT', 'LOWER', 'NO TRANSPOSE','UNIT', k, nb,one, a( k+1, 1 ), & + call stdlib_${ri}$lacpy( 'ALL', k, nb, a( 1, 2 ), lda, y, ldy ) + call stdlib_${ri}$trmm( 'RIGHT', 'LOWER', 'NO TRANSPOSE','UNIT', k, nb,one, a( k+1, 1 ), & lda, y, ldy ) - if( n>k+nb )call stdlib_qgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', k,nb, n-k-nb, one,a( 1, & + if( n>k+nb )call stdlib_${ri}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', k,nb, n-k-nb, one,a( 1, & 2+nb ), lda, a( k+1+nb, 1 ), lda, one, y,ldy ) - call stdlib_qtrmm( 'RIGHT', 'UPPER', 'NO TRANSPOSE','NON-UNIT', k, nb,one, t, ldt, y, & + call stdlib_${ri}$trmm( 'RIGHT', 'UPPER', 'NO TRANSPOSE','NON-UNIT', k, nb,one, t, ldt, y, & ldy ) return - end subroutine stdlib_qlahr2 + end subroutine stdlib_${ri}$lahr2 - pure subroutine stdlib_qlaic1( job, j, x, sest, w, gamma, sestpr, s, c ) + pure subroutine stdlib_${ri}$laic1( job, j, x, sest, w, gamma, sestpr, s, c ) !! DLAIC1: applies one step of incremental condition estimation in !! its simplest version: !! Let x, twonorm(x) = 1, be an approximate singular vector of an j-by-j @@ -29636,21 +29637,21 @@ module stdlib_linalg_lapack_q ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments integer(ilp), intent(in) :: j, job - real(qp), intent(out) :: c, s, sestpr - real(qp), intent(in) :: gamma, sest + real(${rk}$), intent(out) :: c, s, sestpr + real(${rk}$), intent(in) :: gamma, sest ! Array Arguments - real(qp), intent(in) :: w(j), x(j) + real(${rk}$), intent(in) :: w(j), x(j) ! ===================================================================== ! Local Scalars - real(qp) :: absalp, absest, absgam, alpha, b, cosine, eps, norma, s1, s2, sine, t, & + real(${rk}$) :: absalp, absest, absgam, alpha, b, cosine, eps, norma, s1, s2, sine, t, & test, tmp, zeta1, zeta2 ! Intrinsic Functions intrinsic :: abs,max,sign,sqrt ! Executable Statements - eps = stdlib_qlamch( 'EPSILON' ) - alpha = stdlib_qdot( j, x, 1, w, 1 ) + eps = stdlib_${ri}$lamch( 'EPSILON' ) + alpha = stdlib_${ri}$dot( j, x, 1, w, 1 ) absalp = abs( alpha ) absgam = abs( gamma ) absest = abs( sest ) @@ -29819,10 +29820,10 @@ module stdlib_linalg_lapack_q end if end if return - end subroutine stdlib_qlaic1 + end subroutine stdlib_${ri}$laic1 - pure logical(lk) function stdlib_qlaisnan( din1, din2 ) + pure logical(lk) function stdlib_${ri}$laisnan( din1, din2 ) !! This routine is not for general use. It exists solely to avoid !! over-optimization in DISNAN. !! DLAISNAN: checks for NaNs by comparing its two arguments for @@ -29838,15 +29839,15 @@ module stdlib_linalg_lapack_q ! -- lapack is a software package provided by univ. of tennessee, -- ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments - real(qp), intent(in) :: din1, din2 + real(${rk}$), intent(in) :: din1, din2 ! ===================================================================== ! Executable Statements - stdlib_qlaisnan = (din1/=din2) + stdlib_${ri}$laisnan = (din1/=din2) return - end function stdlib_qlaisnan + end function stdlib_${ri}$laisnan - pure subroutine stdlib_qlaln2( ltrans, na, nw, smin, ca, a, lda, d1, d2, b,ldb, wr, wi, x, & + pure subroutine stdlib_${ri}$laln2( ltrans, na, nw, smin, ca, a, lda, d1, d2, b,ldb, wr, wi, x, & !! DLALN2: solves a system of the form (ca A - w D ) X = s B !! or (ca A**T - w D) X = s B with possible scaling ("s") and !! perturbation of A. (A**T means A-transpose.) @@ -29880,23 +29881,23 @@ module stdlib_linalg_lapack_q logical(lk), intent(in) :: ltrans integer(ilp), intent(out) :: info integer(ilp), intent(in) :: lda, ldb, ldx, na, nw - real(qp), intent(in) :: ca, d1, d2, smin, wi, wr - real(qp), intent(out) :: scale, xnorm + real(${rk}$), intent(in) :: ca, d1, d2, smin, wi, wr + real(${rk}$), intent(out) :: scale, xnorm ! Array Arguments - real(qp), intent(in) :: a(lda,*), b(ldb,*) - real(qp), intent(out) :: x(ldx,*) + real(${rk}$), intent(in) :: a(lda,*), b(ldb,*) + real(${rk}$), intent(out) :: x(ldx,*) ! ===================================================================== ! Local Scalars integer(ilp) :: icmax, j - real(qp) :: bbnd, bi1, bi2, bignum, bnorm, br1, br2, ci21, ci22, cmax, cnorm, cr21, & + real(${rk}$) :: bbnd, bi1, bi2, bignum, bnorm, br1, br2, ci21, ci22, cmax, cnorm, cr21, & cr22, csi, csr, li21, lr21, smini, smlnum, temp, u22abs, ui11, ui11r, ui12, ui12s, & ui22, ur11, ur11r, ur12, ur12s, ur22, xi1, xi2, xr1, xr2 ! Local Arrays logical(lk) :: rswap(4), zswap(4) integer(ilp) :: ipivot(4,4) - real(qp) :: ci(2,2), civ(4), cr(2,2), crv(4) + real(${rk}$) :: ci(2,2), civ(4), cr(2,2), crv(4) ! Intrinsic Functions intrinsic :: abs,max ! Equivalences @@ -29907,7 +29908,7 @@ module stdlib_linalg_lapack_q ipivot = reshape([1,2,3,4,2,1,4,3,3,4,1,2,4,3,2,1],[4,4]) ! Executable Statements ! compute bignum - smlnum = two*stdlib_qlamch( 'SAFE MINIMUM' ) + smlnum = two*stdlib_${ri}$lamch( 'SAFE MINIMUM' ) bignum = one / smlnum smini = max( smin, smlnum ) ! don't check for input errors @@ -29954,13 +29955,13 @@ module stdlib_linalg_lapack_q if( bnorm>bignum*cnorm )scale = one / bnorm end if ! compute x - call stdlib_qladiv( scale*b( 1, 1 ), scale*b( 1, 2 ), csr, csi,x( 1, 1 ), x( 1, & + call stdlib_${ri}$ladiv( scale*b( 1, 1 ), scale*b( 1, 2 ), csr, csi,x( 1, 1 ), x( 1, & 2 ) ) xnorm = abs( x( 1, 1 ) ) + abs( x( 1, 2 ) ) end if else ! 2x2 system - ! compute the realpart of c = ca a - w d (or ca a**t - w d,KIND=qp) + ! compute the realpart of c = ca a - w d (or ca a**t - w d,KIND=${rk}$) cr( 1, 1 ) = ca*a( 1, 1 ) - wr*d1 cr( 2, 2 ) = ca*a( 2, 2 ) - wr*d2 if( ltrans ) then @@ -29971,7 +29972,7 @@ module stdlib_linalg_lapack_q cr( 1, 2 ) = ca*a( 1, 2 ) end if if( nw==1 ) then - ! real2x2 system (w is real,KIND=qp) + ! real2x2 system (w is real,KIND=${rk}$) ! find the largest element in c cmax = zero icmax = 0 @@ -30138,7 +30139,7 @@ module stdlib_linalg_lapack_q bi2 = scale*bi2 end if end if - call stdlib_qladiv( br2, bi2, ur22, ui22, xr2, xi2 ) + call stdlib_${ri}$ladiv( br2, bi2, ur22, ui22, xr2, xi2 ) xr1 = ur11r*br1 - ui11r*bi1 - ur12s*xr2 + ui12s*xi2 xi1 = ui11r*br1 + ur11r*bi1 - ui12s*xr2 - ur12s*xi2 if( zswap( icmax ) ) then @@ -30168,10 +30169,10 @@ module stdlib_linalg_lapack_q end if end if return - end subroutine stdlib_qlaln2 + end subroutine stdlib_${ri}$laln2 - pure subroutine stdlib_qlals0( icompq, nl, nr, sqre, nrhs, b, ldb, bx, ldbx,perm, givptr, & + pure subroutine stdlib_${ri}$lals0( icompq, nl, nr, sqre, nrhs, b, ldb, bx, ldbx,perm, givptr, & !! DLALS0: applies back the multiplying factors of either the left or the !! right singular vector matrix of a diagonal matrix appended by a row !! to the right hand side matrix B in solving the least squares problem @@ -30200,18 +30201,18 @@ module stdlib_linalg_lapack_q integer(ilp), intent(in) :: givptr, icompq, k, ldb, ldbx, ldgcol, ldgnum, nl, nr, nrhs,& sqre integer(ilp), intent(out) :: info - real(qp), intent(in) :: c, s + real(${rk}$), intent(in) :: c, s ! Array Arguments integer(ilp), intent(in) :: givcol(ldgcol,*), perm(*) - real(qp), intent(inout) :: b(ldb,*) - real(qp), intent(out) :: bx(ldbx,*), work(*) - real(qp), intent(in) :: difl(*), difr(ldgnum,*), givnum(ldgnum,*), poles(ldgnum,*), z(& + real(${rk}$), intent(inout) :: b(ldb,*) + real(${rk}$), intent(out) :: bx(ldbx,*), work(*) + real(${rk}$), intent(in) :: difl(*), difr(ldgnum,*), givnum(ldgnum,*), poles(ldgnum,*), z(& *) ! ===================================================================== ! Local Scalars integer(ilp) :: i, j, m, n, nlp1 - real(qp) :: diflj, difrj, dj, dsigj, dsigjp, temp + real(${rk}$) :: diflj, difrj, dj, dsigj, dsigjp, temp ! Intrinsic Functions intrinsic :: max ! Executable Statements @@ -30251,20 +30252,20 @@ module stdlib_linalg_lapack_q ! apply back orthogonal transformations from the left. ! step (1l): apply back the givens rotations performed. do i = 1, givptr - call stdlib_qrot( nrhs, b( givcol( i, 2 ), 1 ), ldb,b( givcol( i, 1 ), 1 ), ldb, & + call stdlib_${ri}$rot( nrhs, b( givcol( i, 2 ), 1 ), ldb,b( givcol( i, 1 ), 1 ), ldb, & givnum( i, 2 ),givnum( i, 1 ) ) end do ! step (2l): permute rows of b. - call stdlib_qcopy( nrhs, b( nlp1, 1 ), ldb, bx( 1, 1 ), ldbx ) + call stdlib_${ri}$copy( nrhs, b( nlp1, 1 ), ldb, bx( 1, 1 ), ldbx ) do i = 2, n - call stdlib_qcopy( nrhs, b( perm( i ), 1 ), ldb, bx( i, 1 ), ldbx ) + call stdlib_${ri}$copy( nrhs, b( perm( i ), 1 ), ldb, bx( i, 1 ), ldbx ) end do ! step (3l): apply the inverse of the left singular vector ! matrix to bx. if( k==1 ) then - call stdlib_qcopy( nrhs, bx, ldbx, b, ldb ) + call stdlib_${ri}$copy( nrhs, bx, ldbx, b, ldb ) if( z( 1 )=one ) ) then rcnd = eps @@ -30616,10 +30617,10 @@ module stdlib_linalg_lapack_q return else if( n==1 ) then if( d( 1 )==zero ) then - call stdlib_qlaset( 'A', 1, nrhs, zero, zero, b, ldb ) + call stdlib_${ri}$laset( 'A', 1, nrhs, zero, zero, b, ldb ) else rank = 1 - call stdlib_qlascl( 'G', 0, 0, d( 1 ), one, 1, nrhs, b, ldb, info ) + call stdlib_${ri}$lascl( 'G', 0, 0, d( 1 ), one, 1, nrhs, b, ldb, info ) d( 1 ) = abs( d( 1 ) ) end if return @@ -30627,12 +30628,12 @@ module stdlib_linalg_lapack_q ! rotate the matrix if it is lower bidiagonal. if( uplo=='L' ) then do i = 1, n - 1 - call stdlib_qlartg( d( i ), e( i ), cs, sn, r ) + call stdlib_${ri}$lartg( d( i ), e( i ), cs, sn, r ) d( i ) = r e( i ) = sn*d( i+1 ) d( i+1 ) = cs*d( i+1 ) if( nrhs==1 ) then - call stdlib_qrot( 1, b( i, 1 ), 1, b( i+1, 1 ), 1, cs, sn ) + call stdlib_${ri}$rot( 1, b( i, 1 ), 1, b( i+1, 1 ), 1, cs, sn ) else work( i*2-1 ) = cs work( i*2 ) = sn @@ -30643,51 +30644,51 @@ module stdlib_linalg_lapack_q do j = 1, n - 1 cs = work( j*2-1 ) sn = work( j*2 ) - call stdlib_qrot( 1, b( j, i ), 1, b( j+1, i ), 1, cs, sn ) + call stdlib_${ri}$rot( 1, b( j, i ), 1, b( j+1, i ), 1, cs, sn ) end do end do end if end if ! scale. nm1 = n - 1 - orgnrm = stdlib_qlanst( 'M', n, d, e ) + orgnrm = stdlib_${ri}$lanst( 'M', n, d, e ) if( orgnrm==zero ) then - call stdlib_qlaset( 'A', n, nrhs, zero, zero, b, ldb ) + call stdlib_${ri}$laset( 'A', n, nrhs, zero, zero, b, ldb ) return end if - call stdlib_qlascl( 'G', 0, 0, orgnrm, one, n, 1, d, n, info ) - call stdlib_qlascl( 'G', 0, 0, orgnrm, one, nm1, 1, e, nm1, info ) + call stdlib_${ri}$lascl( 'G', 0, 0, orgnrm, one, n, 1, d, n, info ) + call stdlib_${ri}$lascl( 'G', 0, 0, orgnrm, one, nm1, 1, e, nm1, info ) ! if n is smaller than the minimum divide size smlsiz, then solve ! the problem with another solver. if( n<=smlsiz ) then nwork = 1 + n*n - call stdlib_qlaset( 'A', n, n, zero, one, work, n ) - call stdlib_qlasdq( 'U', 0, n, n, 0, nrhs, d, e, work, n, work, n, b,ldb, work( & + call stdlib_${ri}$laset( 'A', n, n, zero, one, work, n ) + call stdlib_${ri}$lasdq( 'U', 0, n, n, 0, nrhs, d, e, work, n, work, n, b,ldb, work( & nwork ), info ) if( info/=0 ) then return end if - tol = rcnd*abs( d( stdlib_iqamax( n, d, 1 ) ) ) + tol = rcnd*abs( d( stdlib_i${ri}$amax( n, d, 1 ) ) ) do i = 1, n if( d( i )<=tol ) then - call stdlib_qlaset( 'A', 1, nrhs, zero, zero, b( i, 1 ), ldb ) + call stdlib_${ri}$laset( 'A', 1, nrhs, zero, zero, b( i, 1 ), ldb ) else - call stdlib_qlascl( 'G', 0, 0, d( i ), one, 1, nrhs, b( i, 1 ),ldb, info ) + call stdlib_${ri}$lascl( 'G', 0, 0, d( i ), one, 1, nrhs, b( i, 1 ),ldb, info ) rank = rank + 1 end if end do - call stdlib_qgemm( 'T', 'N', n, nrhs, n, one, work, n, b, ldb, zero,work( nwork ), & + call stdlib_${ri}$gemm( 'T', 'N', n, nrhs, n, one, work, n, b, ldb, zero,work( nwork ), & n ) - call stdlib_qlacpy( 'A', n, nrhs, work( nwork ), n, b, ldb ) + call stdlib_${ri}$lacpy( 'A', n, nrhs, work( nwork ), n, b, ldb ) ! unscale. - call stdlib_qlascl( 'G', 0, 0, one, orgnrm, n, 1, d, n, info ) - call stdlib_qlasrt( 'D', n, d, info ) - call stdlib_qlascl( 'G', 0, 0, orgnrm, one, n, nrhs, b, ldb, info ) + call stdlib_${ri}$lascl( 'G', 0, 0, one, orgnrm, n, 1, d, n, info ) + call stdlib_${ri}$lasrt( 'D', n, d, info ) + call stdlib_${ri}$lascl( 'G', 0, 0, orgnrm, one, n, nrhs, b, ldb, info ) return end if ! book-keeping and setting up some constants. - nlvl = int( log( real( n,KIND=qp) / real( smlsiz+1,KIND=qp) ) / log( two ),KIND=ilp) + & + nlvl = int( log( real( n,KIND=${rk}$) / real( smlsiz+1,KIND=${rk}$) ) / log( two ),KIND=ilp) + & 1 smlszp = smlsiz + 1 u = 1 @@ -30740,26 +30741,26 @@ module stdlib_linalg_lapack_q nsub = nsub + 1 iwork( nsub ) = n iwork( sizei+nsub-1 ) = 1 - call stdlib_qcopy( nrhs, b( n, 1 ), ldb, work( bx+nm1 ), n ) + call stdlib_${ri}$copy( nrhs, b( n, 1 ), ldb, work( bx+nm1 ), n ) end if st1 = st - 1 if( nsize==1 ) then ! this is a 1-by-1 subproblem and is not solved ! explicitly. - call stdlib_qcopy( nrhs, b( st, 1 ), ldb, work( bx+st1 ), n ) + call stdlib_${ri}$copy( nrhs, b( st, 1 ), ldb, work( bx+st1 ), n ) else if( nsize<=smlsiz ) then - ! this is a small subproblem and is solved by stdlib_qlasdq. - call stdlib_qlaset( 'A', nsize, nsize, zero, one,work( vt+st1 ), n ) - call stdlib_qlasdq( 'U', 0, nsize, nsize, 0, nrhs, d( st ),e( st ), work( vt+& + ! this is a small subproblem and is solved by stdlib_${ri}$lasdq. + call stdlib_${ri}$laset( 'A', nsize, nsize, zero, one,work( vt+st1 ), n ) + call stdlib_${ri}$lasdq( 'U', 0, nsize, nsize, 0, nrhs, d( st ),e( st ), work( vt+& st1 ), n, work( nwork ),n, b( st, 1 ), ldb, work( nwork ), info ) if( info/=0 ) then return end if - call stdlib_qlacpy( 'A', nsize, nrhs, b( st, 1 ), ldb,work( bx+st1 ), n ) + call stdlib_${ri}$lacpy( 'A', nsize, nrhs, b( st, 1 ), ldb,work( bx+st1 ), n ) else ! a large problem. solve it using divide and conquer. - call stdlib_qlasda( icmpq1, smlsiz, nsize, sqre, d( st ),e( st ), work( u+st1 & + call stdlib_${ri}$lasda( icmpq1, smlsiz, nsize, sqre, d( st ),e( st ), work( u+st1 & ), n, work( vt+st1 ),iwork( k+st1 ), work( difl+st1 ),work( difr+st1 ), work( & z+st1 ),work( poles+st1 ), iwork( givptr+st1 ),iwork( givcol+st1 ), n, iwork( & perm+st1 ),work( givnum+st1 ), work( c+st1 ),work( s+st1 ), work( nwork ), & @@ -30768,7 +30769,7 @@ module stdlib_linalg_lapack_q return end if bxst = bx + st1 - call stdlib_qlalsa( icmpq2, smlsiz, nsize, nrhs, b( st, 1 ),ldb, work( bxst ),& + call stdlib_${ri}$lalsa( icmpq2, smlsiz, nsize, nrhs, b( st, 1 ),ldb, work( bxst ),& n, work( u+st1 ), n,work( vt+st1 ), iwork( k+st1 ),work( difl+st1 ), work( & difr+st1 ),work( z+st1 ), work( poles+st1 ),iwork( givptr+st1 ), iwork( & givcol+st1 ), n,iwork( perm+st1 ), work( givnum+st1 ),work( c+st1 ), work( s+& @@ -30781,15 +30782,15 @@ module stdlib_linalg_lapack_q end if end do loop_60 ! apply the singular values and treat the tiny ones as zero. - tol = rcnd*abs( d( stdlib_iqamax( n, d, 1 ) ) ) + tol = rcnd*abs( d( stdlib_i${ri}$amax( n, d, 1 ) ) ) do i = 1, n ! some of the elements in d can be negative because 1-by-1 ! subproblems were not solved explicitly. if( abs( d( i ) )<=tol ) then - call stdlib_qlaset( 'A', 1, nrhs, zero, zero, work( bx+i-1 ), n ) + call stdlib_${ri}$laset( 'A', 1, nrhs, zero, zero, work( bx+i-1 ), n ) else rank = rank + 1 - call stdlib_qlascl( 'G', 0, 0, d( i ), one, 1, nrhs,work( bx+i-1 ), n, info ) + call stdlib_${ri}$lascl( 'G', 0, 0, d( i ), one, 1, nrhs,work( bx+i-1 ), n, info ) end if d( i ) = abs( d( i ) ) @@ -30802,12 +30803,12 @@ module stdlib_linalg_lapack_q nsize = iwork( sizei+i-1 ) bxst = bx + st1 if( nsize==1 ) then - call stdlib_qcopy( nrhs, work( bxst ), n, b( st, 1 ), ldb ) + call stdlib_${ri}$copy( nrhs, work( bxst ), n, b( st, 1 ), ldb ) else if( nsize<=smlsiz ) then - call stdlib_qgemm( 'T', 'N', nsize, nrhs, nsize, one,work( vt+st1 ), n, work( & + call stdlib_${ri}$gemm( 'T', 'N', nsize, nrhs, nsize, one,work( vt+st1 ), n, work( & bxst ), n, zero,b( st, 1 ), ldb ) else - call stdlib_qlalsa( icmpq2, smlsiz, nsize, nrhs, work( bxst ), n,b( st, 1 ), ldb,& + call stdlib_${ri}$lalsa( icmpq2, smlsiz, nsize, nrhs, work( bxst ), n,b( st, 1 ), ldb,& work( u+st1 ), n,work( vt+st1 ), iwork( k+st1 ),work( difl+st1 ), work( difr+& st1 ),work( z+st1 ), work( poles+st1 ),iwork( givptr+st1 ), iwork( givcol+st1 ),& n,iwork( perm+st1 ), work( givnum+st1 ),work( c+st1 ), work( s+st1 ), work( & @@ -30818,14 +30819,14 @@ module stdlib_linalg_lapack_q end if end do ! unscale and sort the singular values. - call stdlib_qlascl( 'G', 0, 0, one, orgnrm, n, 1, d, n, info ) - call stdlib_qlasrt( 'D', n, d, info ) - call stdlib_qlascl( 'G', 0, 0, orgnrm, one, n, nrhs, b, ldb, info ) + call stdlib_${ri}$lascl( 'G', 0, 0, one, orgnrm, n, 1, d, n, info ) + call stdlib_${ri}$lasrt( 'D', n, d, info ) + call stdlib_${ri}$lascl( 'G', 0, 0, orgnrm, one, n, nrhs, b, ldb, info ) return - end subroutine stdlib_qlalsd + end subroutine stdlib_${ri}$lalsd - pure real(qp) function stdlib_qlamch( cmach ) + pure real(${rk}$) function stdlib_${ri}$lamch( cmach ) !! DLAMCH: determines quad precision machine parameters. ! -- lapack auxiliary routine -- ! -- lapack is a software package provided by univ. of tennessee, -- @@ -30835,7 +30836,7 @@ module stdlib_linalg_lapack_q ! ===================================================================== ! Local Scalars - real(qp) :: rnd, eps, sfmin, small, rmach + real(${rk}$) :: rnd, eps, sfmin, small, rmach ! Intrinsic Functions intrinsic :: digits,epsilon,huge,maxexponent,minexponent,radix,tiny ! Executable Statements @@ -30876,24 +30877,24 @@ module stdlib_linalg_lapack_q else rmach = zero end if - stdlib_qlamch = rmach + stdlib_${ri}$lamch = rmach return - end function stdlib_qlamch + end function stdlib_${ri}$lamch - pure real(qp) function stdlib_qlamc3( a, b ) + pure real(${rk}$) function stdlib_${ri}$lamc3( a, b ) ! -- lapack auxiliary routine -- ! univ. of tennessee, univ. of california berkeley and nag ltd.. ! Scalar Arguments - real(qp), intent(in) :: a, b + real(${rk}$), intent(in) :: a, b ! ===================================================================== ! Executable Statements - stdlib_qlamc3 = a + b + stdlib_${ri}$lamc3 = a + b return - end function stdlib_qlamc3 + end function stdlib_${ri}$lamc3 - pure subroutine stdlib_qlamrg( n1, n2, a, dtrd1, dtrd2, index ) + pure subroutine stdlib_${ri}$lamrg( n1, n2, a, dtrd1, dtrd2, index ) !! DLAMRG: will create a permutation list which will merge the elements !! of A (which is composed of two independently sorted sets) into a !! single set which is sorted in ascending order. @@ -30904,7 +30905,7 @@ module stdlib_linalg_lapack_q integer(ilp), intent(in) :: dtrd1, dtrd2, n1, n2 ! Array Arguments integer(ilp), intent(out) :: index(*) - real(qp), intent(in) :: a(*) + real(${rk}$), intent(in) :: a(*) ! ===================================================================== ! Local Scalars integer(ilp) :: i, ind1, ind2, n1sv, n2sv @@ -30954,10 +30955,10 @@ module stdlib_linalg_lapack_q end do end if return - end subroutine stdlib_qlamrg + end subroutine stdlib_${ri}$lamrg - pure subroutine stdlib_qlamswlq( side, trans, m, n, k, mb, nb, a, lda, t,ldt, c, ldc, work, & + pure subroutine stdlib_${ri}$lamswlq( side, trans, m, n, k, mb, nb, a, lda, t,ldt, c, ldc, work, & !! DLAMSWLQ: overwrites the general real M-by-N matrix C with !! SIDE = 'L' SIDE = 'R' !! TRANS = 'N': Q * C C * Q @@ -30974,9 +30975,9 @@ module stdlib_linalg_lapack_q integer(ilp), intent(out) :: info integer(ilp), intent(in) :: lda, m, n, k, mb, nb, ldt, lwork, ldc ! Array Arguments - real(qp), intent(in) :: a(lda,*), t(ldt,*) - real(qp), intent(out) :: work(*) - real(qp), intent(inout) :: c(ldc,*) + real(${rk}$), intent(in) :: a(lda,*), t(ldt,*) + real(${rk}$), intent(out) :: work(*) + real(${rk}$), intent(inout) :: c(ldc,*) ! ===================================================================== ! Local Scalars logical(lk) :: left, right, tran, notran, lquery @@ -31029,7 +31030,7 @@ module stdlib_linalg_lapack_q return end if if((nb<=k).or.(nb>=max(m,n,k))) then - call stdlib_qgemlqt( side, trans, m, n, k, mb, a, lda,t, ldt, c, ldc, work, info) + call stdlib_${ri}$gemlqt( side, trans, m, n, k, mb, a, lda,t, ldt, c, ldc, work, info) return end if @@ -31039,7 +31040,7 @@ module stdlib_linalg_lapack_q ctr = (m-k)/(nb-k) if (kk>0) then ii=m-kk+1 - call stdlib_qtpmlqt('L','T',kk , n, k, 0, mb, a(1,ii), lda,t(1,ctr*k+1), ldt, c(& + call stdlib_${ri}$tpmlqt('L','T',kk , n, k, 0, mb, a(1,ii), lda,t(1,ctr*k+1), ldt, c(& 1,1), ldc,c(ii,1), ldc, work, info ) else ii=m+1 @@ -31047,28 +31048,28 @@ module stdlib_linalg_lapack_q do i=ii-(nb-k),nb+1,-(nb-k) ! multiply q to the current block of c (1:m,i:i+nb) ctr = ctr - 1 - call stdlib_qtpmlqt('L','T',nb-k , n, k, 0,mb, a(1,i), lda,t(1, ctr*k+1),ldt, c(& + call stdlib_${ri}$tpmlqt('L','T',nb-k , n, k, 0,mb, a(1,i), lda,t(1, ctr*k+1),ldt, c(& 1,1), ldc,c(i,1), ldc, work, info ) end do ! multiply q to the first block of c (1:m,1:nb) - call stdlib_qgemlqt('L','T',nb , n, k, mb, a(1,1), lda, t,ldt ,c(1,1), ldc, work, & + call stdlib_${ri}$gemlqt('L','T',nb , n, k, mb, a(1,1), lda, t,ldt ,c(1,1), ldc, work, & info ) else if (left.and.notran) then ! multiply q to the first block of c kk = mod((m-k),(nb-k)) ii=m-kk+1 ctr = 1 - call stdlib_qgemlqt('L','N',nb , n, k, mb, a(1,1), lda, t,ldt ,c(1,1), ldc, work, & + call stdlib_${ri}$gemlqt('L','N',nb , n, k, mb, a(1,1), lda, t,ldt ,c(1,1), ldc, work, & info ) do i=nb+1,ii-nb+k,(nb-k) ! multiply q to the current block of c (i:i+nb,1:n) - call stdlib_qtpmlqt('L','N',nb-k , n, k, 0,mb, a(1,i), lda,t(1,ctr*k+1), ldt, c(1,& + call stdlib_${ri}$tpmlqt('L','N',nb-k , n, k, 0,mb, a(1,i), lda,t(1,ctr*k+1), ldt, c(1,& 1), ldc,c(i,1), ldc, work, info ) ctr = ctr + 1 end do if(ii<=m) then ! multiply q to the last block of c - call stdlib_qtpmlqt('L','N',kk , n, k, 0, mb, a(1,ii), lda,t(1,ctr*k+1), ldt, c(1,& + call stdlib_${ri}$tpmlqt('L','N',kk , n, k, 0, mb, a(1,ii), lda,t(1,ctr*k+1), ldt, c(1,& 1), ldc,c(ii,1), ldc, work, info ) end if else if(right.and.notran) then @@ -31077,7 +31078,7 @@ module stdlib_linalg_lapack_q ctr = (n-k)/(nb-k) if (kk>0) then ii=n-kk+1 - call stdlib_qtpmlqt('R','N',m , kk, k, 0, mb, a(1, ii), lda,t(1,ctr *k+1), ldt, & + call stdlib_${ri}$tpmlqt('R','N',m , kk, k, 0, mb, a(1, ii), lda,t(1,ctr *k+1), ldt, & c(1,1), ldc,c(1,ii), ldc, work, info ) else ii=n+1 @@ -31085,37 +31086,37 @@ module stdlib_linalg_lapack_q do i=ii-(nb-k),nb+1,-(nb-k) ! multiply q to the current block of c (1:m,i:i+mb) ctr = ctr - 1 - call stdlib_qtpmlqt('R','N', m, nb-k, k, 0, mb, a(1, i), lda,t(1,ctr*k+1), ldt, & + call stdlib_${ri}$tpmlqt('R','N', m, nb-k, k, 0, mb, a(1, i), lda,t(1,ctr*k+1), ldt, & c(1,1), ldc,c(1,i), ldc, work, info ) end do ! multiply q to the first block of c (1:m,1:mb) - call stdlib_qgemlqt('R','N',m , nb, k, mb, a(1,1), lda, t,ldt ,c(1,1), ldc, work, & + call stdlib_${ri}$gemlqt('R','N',m , nb, k, mb, a(1,1), lda, t,ldt ,c(1,1), ldc, work, & info ) else if (right.and.tran) then ! multiply q to the first block of c kk = mod((n-k),(nb-k)) ctr = 1 ii=n-kk+1 - call stdlib_qgemlqt('R','T',m , nb, k, mb, a(1,1), lda, t,ldt ,c(1,1), ldc, work, & + call stdlib_${ri}$gemlqt('R','T',m , nb, k, mb, a(1,1), lda, t,ldt ,c(1,1), ldc, work, & info ) do i=nb+1,ii-nb+k,(nb-k) ! multiply q to the current block of c (1:m,i:i+mb) - call stdlib_qtpmlqt('R','T',m , nb-k, k, 0,mb, a(1,i), lda,t(1,ctr*k+1), ldt, c(1,& + call stdlib_${ri}$tpmlqt('R','T',m , nb-k, k, 0,mb, a(1,i), lda,t(1,ctr*k+1), ldt, c(1,& 1), ldc,c(1,i), ldc, work, info ) ctr = ctr + 1 end do if(ii<=n) then ! multiply q to the last block of c - call stdlib_qtpmlqt('R','T',m , kk, k, 0,mb, a(1,ii), lda,t(1,ctr*k+1),ldt, c(1,1),& + call stdlib_${ri}$tpmlqt('R','T',m , kk, k, 0,mb, a(1,ii), lda,t(1,ctr*k+1),ldt, c(1,1),& ldc,c(1,ii), ldc, work, info ) end if end if work(1) = lw return - end subroutine stdlib_qlamswlq + end subroutine stdlib_${ri}$lamswlq - pure subroutine stdlib_qlamtsqr( side, trans, m, n, k, mb, nb, a, lda, t,ldt, c, ldc, work, & + pure subroutine stdlib_${ri}$lamtsqr( side, trans, m, n, k, mb, nb, a, lda, t,ldt, c, ldc, work, & !! DLAMTSQR: overwrites the general real M-by-N matrix C with !! SIDE = 'L' SIDE = 'R' !! TRANS = 'N': Q * C C * Q @@ -31132,9 +31133,9 @@ module stdlib_linalg_lapack_q integer(ilp), intent(out) :: info integer(ilp), intent(in) :: lda, m, n, k, mb, nb, ldt, lwork, ldc ! Array Arguments - real(qp), intent(in) :: a(lda,*), t(ldt,*) - real(qp), intent(out) :: work(*) - real(qp), intent(inout) :: c(ldc,*) + real(${rk}$), intent(in) :: a(lda,*), t(ldt,*) + real(${rk}$), intent(out) :: work(*) + real(${rk}$), intent(inout) :: c(ldc,*) ! ===================================================================== ! Local Scalars logical(lk) :: left, right, tran, notran, lquery @@ -31191,7 +31192,7 @@ module stdlib_linalg_lapack_q return end if if((mb<=k).or.(mb>=max(m,n,k))) then - call stdlib_qgemqrt( side, trans, m, n, k, nb, a, lda,t, ldt, c, ldc, work, info) + call stdlib_${ri}$gemqrt( side, trans, m, n, k, nb, a, lda,t, ldt, c, ldc, work, info) return end if @@ -31201,7 +31202,7 @@ module stdlib_linalg_lapack_q ctr = (m-k)/(mb-k) if (kk>0) then ii=m-kk+1 - call stdlib_qtpmqrt('L','N',kk , n, k, 0, nb, a(ii,1), lda,t(1,ctr*k+1),ldt , c(1,& + call stdlib_${ri}$tpmqrt('L','N',kk , n, k, 0, nb, a(ii,1), lda,t(1,ctr*k+1),ldt , c(1,& 1), ldc,c(ii,1), ldc, work, info ) else ii=m+1 @@ -31209,28 +31210,28 @@ module stdlib_linalg_lapack_q do i=ii-(mb-k),mb+1,-(mb-k) ! multiply q to the current block of c (i:i+mb,1:n) ctr = ctr - 1 - call stdlib_qtpmqrt('L','N',mb-k , n, k, 0,nb, a(i,1), lda,t(1,ctr*k+1),ldt, c(1,& + call stdlib_${ri}$tpmqrt('L','N',mb-k , n, k, 0,nb, a(i,1), lda,t(1,ctr*k+1),ldt, c(1,& 1), ldc,c(i,1), ldc, work, info ) end do ! multiply q to the first block of c (1:mb,1:n) - call stdlib_qgemqrt('L','N',mb , n, k, nb, a(1,1), lda, t,ldt ,c(1,1), ldc, work, & + call stdlib_${ri}$gemqrt('L','N',mb , n, k, nb, a(1,1), lda, t,ldt ,c(1,1), ldc, work, & info ) else if (left.and.tran) then ! multiply q to the first block of c kk = mod((m-k),(mb-k)) ii=m-kk+1 ctr = 1 - call stdlib_qgemqrt('L','T',mb , n, k, nb, a(1,1), lda, t,ldt ,c(1,1), ldc, work, & + call stdlib_${ri}$gemqrt('L','T',mb , n, k, nb, a(1,1), lda, t,ldt ,c(1,1), ldc, work, & info ) do i=mb+1,ii-mb+k,(mb-k) ! multiply q to the current block of c (i:i+mb,1:n) - call stdlib_qtpmqrt('L','T',mb-k , n, k, 0,nb, a(i,1), lda,t(1,ctr * k + 1),ldt, c(& + call stdlib_${ri}$tpmqrt('L','T',mb-k , n, k, 0,nb, a(i,1), lda,t(1,ctr * k + 1),ldt, c(& 1,1), ldc,c(i,1), ldc, work, info ) ctr = ctr + 1 end do if(ii<=m) then ! multiply q to the last block of c - call stdlib_qtpmqrt('L','T',kk , n, k, 0,nb, a(ii,1), lda,t(1,ctr * k + 1), ldt, c(& + call stdlib_${ri}$tpmqrt('L','T',kk , n, k, 0,nb, a(ii,1), lda,t(1,ctr * k + 1), ldt, c(& 1,1), ldc,c(ii,1), ldc, work, info ) end if else if(right.and.tran) then @@ -31239,7 +31240,7 @@ module stdlib_linalg_lapack_q ctr = (n-k)/(mb-k) if (kk>0) then ii=n-kk+1 - call stdlib_qtpmqrt('R','T',m , kk, k, 0, nb, a(ii,1), lda,t(1,ctr*k+1), ldt, c(& + call stdlib_${ri}$tpmqrt('R','T',m , kk, k, 0, nb, a(ii,1), lda,t(1,ctr*k+1), ldt, c(& 1,1), ldc,c(1,ii), ldc, work, info ) else ii=n+1 @@ -31247,37 +31248,37 @@ module stdlib_linalg_lapack_q do i=ii-(mb-k),mb+1,-(mb-k) ! multiply q to the current block of c (1:m,i:i+mb) ctr = ctr - 1 - call stdlib_qtpmqrt('R','T',m , mb-k, k, 0,nb, a(i,1), lda,t(1,ctr*k+1), ldt, c(& + call stdlib_${ri}$tpmqrt('R','T',m , mb-k, k, 0,nb, a(i,1), lda,t(1,ctr*k+1), ldt, c(& 1,1), ldc,c(1,i), ldc, work, info ) end do ! multiply q to the first block of c (1:m,1:mb) - call stdlib_qgemqrt('R','T',m , mb, k, nb, a(1,1), lda, t,ldt ,c(1,1), ldc, work, & + call stdlib_${ri}$gemqrt('R','T',m , mb, k, nb, a(1,1), lda, t,ldt ,c(1,1), ldc, work, & info ) else if (right.and.notran) then ! multiply q to the first block of c kk = mod((n-k),(mb-k)) ii=n-kk+1 ctr = 1 - call stdlib_qgemqrt('R','N', m, mb , k, nb, a(1,1), lda, t,ldt ,c(1,1), ldc, work, & + call stdlib_${ri}$gemqrt('R','N', m, mb , k, nb, a(1,1), lda, t,ldt ,c(1,1), ldc, work, & info ) do i=mb+1,ii-mb+k,(mb-k) ! multiply q to the current block of c (1:m,i:i+mb) - call stdlib_qtpmqrt('R','N', m, mb-k, k, 0,nb, a(i,1), lda,t(1, ctr * k + 1),ldt, & + call stdlib_${ri}$tpmqrt('R','N', m, mb-k, k, 0,nb, a(i,1), lda,t(1, ctr * k + 1),ldt, & c(1,1), ldc,c(1,i), ldc, work, info ) ctr = ctr + 1 end do if(ii<=n) then ! multiply q to the last block of c - call stdlib_qtpmqrt('R','N', m, kk , k, 0,nb, a(ii,1), lda,t(1, ctr * k + 1),ldt, & + call stdlib_${ri}$tpmqrt('R','N', m, kk , k, 0,nb, a(ii,1), lda,t(1, ctr * k + 1),ldt, & c(1,1), ldc,c(1,ii), ldc, work, info ) end if end if work(1) = lw return - end subroutine stdlib_qlamtsqr + end subroutine stdlib_${ri}$lamtsqr - pure integer(ilp) function stdlib_qlaneg( n, d, lld, sigma, pivmin, r ) + pure integer(ilp) function stdlib_${ri}$laneg( n, d, lld, sigma, pivmin, r ) !! DLANEG: computes the Sturm count, the number of negative pivots !! encountered while factoring tridiagonal T - sigma I = L D L^T. !! This implementation works directly on the factors without forming @@ -31298,9 +31299,9 @@ module stdlib_linalg_lapack_q ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments integer(ilp), intent(in) :: n, r - real(qp), intent(in) :: pivmin, sigma + real(${rk}$), intent(in) :: pivmin, sigma ! Array Arguments - real(qp), intent(in) :: d(*), lld(*) + real(${rk}$), intent(in) :: d(*), lld(*) ! ===================================================================== ! Parameters integer(ilp), parameter :: blklen = 128 @@ -31313,7 +31314,7 @@ module stdlib_linalg_lapack_q ! Local Scalars integer(ilp) :: bj, j, neg1, neg2, negcnt - real(qp) :: bsav, dminus, dplus, gamma, p, t, tmp + real(${rk}$) :: bsav, dminus, dplus, gamma, p, t, tmp logical(lk) :: sawnan ! Intrinsic Functions intrinsic :: min,max @@ -31330,7 +31331,7 @@ module stdlib_linalg_lapack_q tmp = t / dplus t = tmp * lld( j ) - sigma end do - sawnan = stdlib_qisnan( t ) + sawnan = stdlib_${ri}$isnan( t ) ! run a slower version of the above loop if a nan is detected. ! a nan should occur only with a zero pivot after an infinite ! pivot. in that case, substituting 1 for t/dplus is the @@ -31342,7 +31343,7 @@ module stdlib_linalg_lapack_q dplus = d( j ) + t if( dplus1 ) then - call stdlib_qlassq( n-1, dl, 1, scale, sum ) - call stdlib_qlassq( n-1, du, 1, scale, sum ) + call stdlib_${ri}$lassq( n-1, dl, 1, scale, sum ) + call stdlib_${ri}$lassq( n-1, du, 1, scale, sum ) end if anorm = scale*sqrt( sum ) end if - stdlib_qlangt = anorm + stdlib_${ri}$langt = anorm return - end function stdlib_qlangt + end function stdlib_${ri}$langt - real(qp) function stdlib_qlanhs( norm, n, a, lda, work ) + real(${rk}$) function stdlib_${ri}$lanhs( norm, n, a, lda, work ) !! DLANHS: returns the value of the one norm, or the Frobenius norm, or !! the infinity norm, or the element of largest absolute value of a !! Hessenberg matrix A. @@ -31616,13 +31617,13 @@ module stdlib_linalg_lapack_q character, intent(in) :: norm integer(ilp), intent(in) :: lda, n ! Array Arguments - real(qp), intent(in) :: a(lda,*) - real(qp), intent(out) :: work(*) + real(${rk}$), intent(in) :: a(lda,*) + real(${rk}$), intent(out) :: work(*) ! ===================================================================== ! Local Scalars integer(ilp) :: i, j - real(qp) :: scale, sum, value + real(${rk}$) :: scale, sum, value ! Intrinsic Functions intrinsic :: abs,min,sqrt ! Executable Statements @@ -31634,7 +31635,7 @@ module stdlib_linalg_lapack_q do j = 1, n do i = 1, min( n, j+1 ) sum = abs( a( i, j ) ) - if( value < sum .or. stdlib_qisnan( sum ) ) value = sum + if( value < sum .or. stdlib_${ri}$isnan( sum ) ) value = sum end do end do else if( ( stdlib_lsame( norm, 'O' ) ) .or. ( norm=='1' ) ) then @@ -31645,7 +31646,7 @@ module stdlib_linalg_lapack_q do i = 1, min( n, j+1 ) sum = sum + abs( a( i, j ) ) end do - if( value < sum .or. stdlib_qisnan( sum ) ) value = sum + if( value < sum .or. stdlib_${ri}$isnan( sum ) ) value = sum end do else if( stdlib_lsame( norm, 'I' ) ) then ! find normi(a). @@ -31660,7 +31661,7 @@ module stdlib_linalg_lapack_q value = zero do i = 1, n sum = work( i ) - if( value < sum .or. stdlib_qisnan( sum ) ) value = sum + if( value < sum .or. stdlib_${ri}$isnan( sum ) ) value = sum end do else if( ( stdlib_lsame( norm, 'F' ) ) .or. ( stdlib_lsame( norm, 'E' ) ) ) & then @@ -31668,16 +31669,16 @@ module stdlib_linalg_lapack_q scale = zero sum = one do j = 1, n - call stdlib_qlassq( min( n, j+1 ), a( 1, j ), 1, scale, sum ) + call stdlib_${ri}$lassq( min( n, j+1 ), a( 1, j ), 1, scale, sum ) end do value = scale*sqrt( sum ) end if - stdlib_qlanhs = value + stdlib_${ri}$lanhs = value return - end function stdlib_qlanhs + end function stdlib_${ri}$lanhs - real(qp) function stdlib_qlansb( norm, uplo, n, k, ab, ldab,work ) + real(${rk}$) function stdlib_${ri}$lansb( norm, uplo, n, k, ab, ldab,work ) !! DLANSB: returns the value of the one norm, or the Frobenius norm, or !! the infinity norm, or the element of largest absolute value of an !! n by n symmetric band matrix A, with k super-diagonals. @@ -31688,13 +31689,13 @@ module stdlib_linalg_lapack_q character, intent(in) :: norm, uplo integer(ilp), intent(in) :: k, ldab, n ! Array Arguments - real(qp), intent(in) :: ab(ldab,*) - real(qp), intent(out) :: work(*) + real(${rk}$), intent(in) :: ab(ldab,*) + real(${rk}$), intent(out) :: work(*) ! ===================================================================== ! Local Scalars integer(ilp) :: i, j, l - real(qp) :: absa, scale, sum, value + real(${rk}$) :: absa, scale, sum, value ! Intrinsic Functions intrinsic :: abs,max,min,sqrt ! Executable Statements @@ -31707,14 +31708,14 @@ module stdlib_linalg_lapack_q do j = 1, n do i = max( k+2-j, 1 ), k + 1 sum = abs( ab( i, j ) ) - if( value < sum .or. stdlib_qisnan( sum ) ) value = sum + if( value < sum .or. stdlib_${ri}$isnan( sum ) ) value = sum end do end do else do j = 1, n do i = 1, min( n+1-j, k+1 ) sum = abs( ab( i, j ) ) - if( value < sum .or. stdlib_qisnan( sum ) ) value = sum + if( value < sum .or. stdlib_${ri}$isnan( sum ) ) value = sum end do end do end if @@ -31735,7 +31736,7 @@ module stdlib_linalg_lapack_q end do do i = 1, n sum = work( i ) - if( value < sum .or. stdlib_qisnan( sum ) ) value = sum + if( value < sum .or. stdlib_${ri}$isnan( sum ) ) value = sum end do else do i = 1, n @@ -31749,7 +31750,7 @@ module stdlib_linalg_lapack_q sum = sum + absa work( i ) = work( i ) + absa end do - if( value < sum .or. stdlib_qisnan( sum ) ) value = sum + if( value < sum .or. stdlib_${ri}$isnan( sum ) ) value = sum end do end if else if( ( stdlib_lsame( norm, 'F' ) ) .or. ( stdlib_lsame( norm, 'E' ) ) ) & @@ -31760,13 +31761,13 @@ module stdlib_linalg_lapack_q if( k>0 ) then if( stdlib_lsame( uplo, 'U' ) ) then do j = 2, n - call stdlib_qlassq( min( j-1, k ), ab( max( k+2-j, 1 ), j ),1, scale, sum ) + call stdlib_${ri}$lassq( min( j-1, k ), ab( max( k+2-j, 1 ), j ),1, scale, sum ) end do l = k + 1 else do j = 1, n - 1 - call stdlib_qlassq( min( n-j, k ), ab( 2, j ), 1, scale,sum ) + call stdlib_${ri}$lassq( min( n-j, k ), ab( 2, j ), 1, scale,sum ) end do l = 1 end if @@ -31774,15 +31775,15 @@ module stdlib_linalg_lapack_q else l = 1 end if - call stdlib_qlassq( n, ab( l, 1 ), ldab, scale, sum ) + call stdlib_${ri}$lassq( n, ab( l, 1 ), ldab, scale, sum ) value = scale*sqrt( sum ) end if - stdlib_qlansb = value + stdlib_${ri}$lansb = value return - end function stdlib_qlansb + end function stdlib_${ri}$lansb - real(qp) function stdlib_qlansf( norm, transr, uplo, n, a, work ) + real(${rk}$) function stdlib_${ri}$lansf( norm, transr, uplo, n, a, work ) !! DLANSF: returns the value of the one norm, or the Frobenius norm, or !! the infinity norm, or the element of largest absolute value of a !! real symmetric matrix A in RFP format. @@ -31793,21 +31794,21 @@ module stdlib_linalg_lapack_q character, intent(in) :: norm, transr, uplo integer(ilp), intent(in) :: n ! Array Arguments - real(qp), intent(in) :: a(0:*) - real(qp), intent(out) :: work(0:*) + real(${rk}$), intent(in) :: a(0:*) + real(${rk}$), intent(out) :: work(0:*) ! ===================================================================== ! Local Scalars integer(ilp) :: i, j, ifm, ilu, noe, n1, k, l, lda - real(qp) :: scale, s, value, aa, temp + real(${rk}$) :: scale, s, value, aa, temp ! Intrinsic Functions intrinsic :: abs,max,sqrt ! Executable Statements if( n==0 ) then - stdlib_qlansf = zero + stdlib_${ri}$lansf = zero return else if( n==1 ) then - stdlib_qlansf = abs( a(0) ) + stdlib_${ri}$lansf = abs( a(0) ) return end if ! set noe = 1 if n is odd. if n is even set noe=0 @@ -31844,7 +31845,7 @@ module stdlib_linalg_lapack_q do j = 0, k - 1 do i = 0, n - 1 temp = abs( a( i+j*lda ) ) - if( value < temp .or. stdlib_qisnan( temp ) )value = temp + if( value < temp .or. stdlib_${ri}$isnan( temp ) )value = temp end do end do else @@ -31852,7 +31853,7 @@ module stdlib_linalg_lapack_q do j = 0, n - 1 do i = 0, k - 1 temp = abs( a( i+j*lda ) ) - if( value < temp .or. stdlib_qisnan( temp ) )value = temp + if( value < temp .or. stdlib_${ri}$isnan( temp ) )value = temp end do end do end if @@ -31863,7 +31864,7 @@ module stdlib_linalg_lapack_q do j = 0, k - 1 do i = 0, n temp = abs( a( i+j*lda ) ) - if( value < temp .or. stdlib_qisnan( temp ) )value = temp + if( value < temp .or. stdlib_${ri}$isnan( temp ) )value = temp end do end do else @@ -31871,7 +31872,7 @@ module stdlib_linalg_lapack_q do j = 0, n do i = 0, k - 1 temp = abs( a( i+j*lda ) ) - if( value < temp .or. stdlib_qisnan( temp ) )value = temp + if( value < temp .or. stdlib_${ri}$isnan( temp ) )value = temp end do end do end if @@ -31917,7 +31918,7 @@ module stdlib_linalg_lapack_q value = work( 0 ) do i = 1, n-1 temp = work( i ) - if( value < temp .or. stdlib_qisnan( temp ) )value = temp + if( value < temp .or. stdlib_${ri}$isnan( temp ) )value = temp end do else ! ilu = 1 @@ -31958,7 +31959,7 @@ module stdlib_linalg_lapack_q value = work( 0 ) do i = 1, n-1 temp = work( i ) - if( value < temp .or. stdlib_qisnan( temp ) )value = temp + if( value < temp .or. stdlib_${ri}$isnan( temp ) )value = temp end do end if else @@ -31995,7 +31996,7 @@ module stdlib_linalg_lapack_q value = work( 0 ) do i = 1, n-1 temp = work( i ) - if( value < temp .or. stdlib_qisnan( temp ) )value = temp + if( value < temp .or. stdlib_${ri}$isnan( temp ) )value = temp end do else ! ilu = 1 @@ -32032,7 +32033,7 @@ module stdlib_linalg_lapack_q value = work( 0 ) do i = 1, n-1 temp = work( i ) - if( value < temp .or. stdlib_qisnan( temp ) )value = temp + if( value < temp .or. stdlib_${ri}$isnan( temp ) )value = temp end do end if end if @@ -32097,7 +32098,7 @@ module stdlib_linalg_lapack_q value = work( 0 ) do i = 1, n-1 temp = work( i ) - if( value < temp .or. stdlib_qisnan( temp ) )value = temp + if( value < temp .or. stdlib_${ri}$isnan( temp ) )value = temp end do else ! ilu=1 @@ -32161,7 +32162,7 @@ module stdlib_linalg_lapack_q value = work( 0 ) do i = 1, n-1 temp = work( i ) - if( value < temp .or. stdlib_qisnan( temp ) )value = temp + if( value < temp .or. stdlib_${ri}$isnan( temp ) )value = temp end do end if else @@ -32233,7 +32234,7 @@ module stdlib_linalg_lapack_q value = work( 0 ) do i = 1, n-1 temp = work( i ) - if( value < temp .or. stdlib_qisnan( temp ) )value = temp + if( value < temp .or. stdlib_${ri}$isnan( temp ) )value = temp end do else ! ilu=1 @@ -32305,7 +32306,7 @@ module stdlib_linalg_lapack_q value = work( 0 ) do i = 1, n-1 temp = work( i ) - if( value < temp .or. stdlib_qisnan( temp ) )value = temp + if( value < temp .or. stdlib_${ri}$isnan( temp ) )value = temp end do end if end if @@ -32323,34 +32324,34 @@ module stdlib_linalg_lapack_q if( ilu==0 ) then ! a is upper do j = 0, k - 3 - call stdlib_qlassq( k-j-2, a( k+j+1+j*lda ), 1, scale, s ) + call stdlib_${ri}$lassq( k-j-2, a( k+j+1+j*lda ), 1, scale, s ) ! l at a(k,0) end do do j = 0, k - 1 - call stdlib_qlassq( k+j-1, a( 0+j*lda ), 1, scale, s ) + call stdlib_${ri}$lassq( k+j-1, a( 0+j*lda ), 1, scale, s ) ! trap u at a(0,0) end do s = s + s ! double s for the off diagonal elements - call stdlib_qlassq( k-1, a( k ), lda+1, scale, s ) + call stdlib_${ri}$lassq( k-1, a( k ), lda+1, scale, s ) ! tri l at a(k,0) - call stdlib_qlassq( k, a( k-1 ), lda+1, scale, s ) + call stdlib_${ri}$lassq( k, a( k-1 ), lda+1, scale, s ) ! tri u at a(k-1,0) else ! ilu=1 do j = 0, k - 1 - call stdlib_qlassq( n-j-1, a( j+1+j*lda ), 1, scale, s ) + call stdlib_${ri}$lassq( n-j-1, a( j+1+j*lda ), 1, scale, s ) ! trap l at a(0,0) end do do j = 0, k - 2 - call stdlib_qlassq( j, a( 0+( 1+j )*lda ), 1, scale, s ) + call stdlib_${ri}$lassq( j, a( 0+( 1+j )*lda ), 1, scale, s ) ! u at a(0,1) end do s = s + s ! double s for the off diagonal elements - call stdlib_qlassq( k, a( 0 ), lda+1, scale, s ) + call stdlib_${ri}$lassq( k, a( 0 ), lda+1, scale, s ) ! tri l at a(0,0) - call stdlib_qlassq( k-1, a( 0+lda ), lda+1, scale, s ) + call stdlib_${ri}$lassq( k-1, a( 0+lda ), lda+1, scale, s ) ! tri u at a(0,1) end if else @@ -32358,42 +32359,42 @@ module stdlib_linalg_lapack_q if( ilu==0 ) then ! a**t is upper do j = 1, k - 2 - call stdlib_qlassq( j, a( 0+( k+j )*lda ), 1, scale, s ) + call stdlib_${ri}$lassq( j, a( 0+( k+j )*lda ), 1, scale, s ) ! u at a(0,k) end do do j = 0, k - 2 - call stdlib_qlassq( k, a( 0+j*lda ), 1, scale, s ) + call stdlib_${ri}$lassq( k, a( 0+j*lda ), 1, scale, s ) ! k by k-1 rect. at a(0,0) end do do j = 0, k - 2 - call stdlib_qlassq( k-j-1, a( j+1+( j+k-1 )*lda ), 1,scale, s ) + call stdlib_${ri}$lassq( k-j-1, a( j+1+( j+k-1 )*lda ), 1,scale, s ) ! l at a(0,k-1) end do s = s + s ! double s for the off diagonal elements - call stdlib_qlassq( k-1, a( 0+k*lda ), lda+1, scale, s ) + call stdlib_${ri}$lassq( k-1, a( 0+k*lda ), lda+1, scale, s ) ! tri u at a(0,k) - call stdlib_qlassq( k, a( 0+( k-1 )*lda ), lda+1, scale, s ) + call stdlib_${ri}$lassq( k, a( 0+( k-1 )*lda ), lda+1, scale, s ) ! tri l at a(0,k-1) else ! a**t is lower do j = 1, k - 1 - call stdlib_qlassq( j, a( 0+j*lda ), 1, scale, s ) + call stdlib_${ri}$lassq( j, a( 0+j*lda ), 1, scale, s ) ! u at a(0,0) end do do j = k, n - 1 - call stdlib_qlassq( k, a( 0+j*lda ), 1, scale, s ) + call stdlib_${ri}$lassq( k, a( 0+j*lda ), 1, scale, s ) ! k by k-1 rect. at a(0,k) end do do j = 0, k - 3 - call stdlib_qlassq( k-j-2, a( j+2+j*lda ), 1, scale, s ) + call stdlib_${ri}$lassq( k-j-2, a( j+2+j*lda ), 1, scale, s ) ! l at a(1,0) end do s = s + s ! double s for the off diagonal elements - call stdlib_qlassq( k, a( 0 ), lda+1, scale, s ) + call stdlib_${ri}$lassq( k, a( 0 ), lda+1, scale, s ) ! tri u at a(0,0) - call stdlib_qlassq( k-1, a( 1 ), lda+1, scale, s ) + call stdlib_${ri}$lassq( k-1, a( 1 ), lda+1, scale, s ) ! tri l at a(1,0) end if end if @@ -32404,34 +32405,34 @@ module stdlib_linalg_lapack_q if( ilu==0 ) then ! a is upper do j = 0, k - 2 - call stdlib_qlassq( k-j-1, a( k+j+2+j*lda ), 1, scale, s ) + call stdlib_${ri}$lassq( k-j-1, a( k+j+2+j*lda ), 1, scale, s ) ! l at a(k+1,0) end do do j = 0, k - 1 - call stdlib_qlassq( k+j, a( 0+j*lda ), 1, scale, s ) + call stdlib_${ri}$lassq( k+j, a( 0+j*lda ), 1, scale, s ) ! trap u at a(0,0) end do s = s + s ! double s for the off diagonal elements - call stdlib_qlassq( k, a( k+1 ), lda+1, scale, s ) + call stdlib_${ri}$lassq( k, a( k+1 ), lda+1, scale, s ) ! tri l at a(k+1,0) - call stdlib_qlassq( k, a( k ), lda+1, scale, s ) + call stdlib_${ri}$lassq( k, a( k ), lda+1, scale, s ) ! tri u at a(k,0) else ! ilu=1 do j = 0, k - 1 - call stdlib_qlassq( n-j-1, a( j+2+j*lda ), 1, scale, s ) + call stdlib_${ri}$lassq( n-j-1, a( j+2+j*lda ), 1, scale, s ) ! trap l at a(1,0) end do do j = 1, k - 1 - call stdlib_qlassq( j, a( 0+j*lda ), 1, scale, s ) + call stdlib_${ri}$lassq( j, a( 0+j*lda ), 1, scale, s ) ! u at a(0,0) end do s = s + s ! double s for the off diagonal elements - call stdlib_qlassq( k, a( 1 ), lda+1, scale, s ) + call stdlib_${ri}$lassq( k, a( 1 ), lda+1, scale, s ) ! tri l at a(1,0) - call stdlib_qlassq( k, a( 0 ), lda+1, scale, s ) + call stdlib_${ri}$lassq( k, a( 0 ), lda+1, scale, s ) ! tri u at a(0,0) end if else @@ -32439,54 +32440,54 @@ module stdlib_linalg_lapack_q if( ilu==0 ) then ! a**t is upper do j = 1, k - 1 - call stdlib_qlassq( j, a( 0+( k+1+j )*lda ), 1, scale, s ) + call stdlib_${ri}$lassq( j, a( 0+( k+1+j )*lda ), 1, scale, s ) ! u at a(0,k+1) end do do j = 0, k - 1 - call stdlib_qlassq( k, a( 0+j*lda ), 1, scale, s ) + call stdlib_${ri}$lassq( k, a( 0+j*lda ), 1, scale, s ) ! k by k rect. at a(0,0) end do do j = 0, k - 2 - call stdlib_qlassq( k-j-1, a( j+1+( j+k )*lda ), 1, scale,s ) + call stdlib_${ri}$lassq( k-j-1, a( j+1+( j+k )*lda ), 1, scale,s ) ! l at a(0,k) end do s = s + s ! double s for the off diagonal elements - call stdlib_qlassq( k, a( 0+( k+1 )*lda ), lda+1, scale, s ) + call stdlib_${ri}$lassq( k, a( 0+( k+1 )*lda ), lda+1, scale, s ) ! tri u at a(0,k+1) - call stdlib_qlassq( k, a( 0+k*lda ), lda+1, scale, s ) + call stdlib_${ri}$lassq( k, a( 0+k*lda ), lda+1, scale, s ) ! tri l at a(0,k) else ! a**t is lower do j = 1, k - 1 - call stdlib_qlassq( j, a( 0+( j+1 )*lda ), 1, scale, s ) + call stdlib_${ri}$lassq( j, a( 0+( j+1 )*lda ), 1, scale, s ) ! u at a(0,1) end do do j = k + 1, n - call stdlib_qlassq( k, a( 0+j*lda ), 1, scale, s ) + call stdlib_${ri}$lassq( k, a( 0+j*lda ), 1, scale, s ) ! k by k rect. at a(0,k+1) end do do j = 0, k - 2 - call stdlib_qlassq( k-j-1, a( j+1+j*lda ), 1, scale, s ) + call stdlib_${ri}$lassq( k-j-1, a( j+1+j*lda ), 1, scale, s ) ! l at a(0,0) end do s = s + s ! double s for the off diagonal elements - call stdlib_qlassq( k, a( lda ), lda+1, scale, s ) + call stdlib_${ri}$lassq( k, a( lda ), lda+1, scale, s ) ! tri l at a(0,1) - call stdlib_qlassq( k, a( 0 ), lda+1, scale, s ) + call stdlib_${ri}$lassq( k, a( 0 ), lda+1, scale, s ) ! tri u at a(0,0) end if end if end if value = scale*sqrt( s ) end if - stdlib_qlansf = value + stdlib_${ri}$lansf = value return - end function stdlib_qlansf + end function stdlib_${ri}$lansf - real(qp) function stdlib_qlansp( norm, uplo, n, ap, work ) + real(${rk}$) function stdlib_${ri}$lansp( norm, uplo, n, ap, work ) !! DLANSP: returns the value of the one norm, or the Frobenius norm, or !! the infinity norm, or the element of largest absolute value of a !! real symmetric matrix A, supplied in packed form. @@ -32497,13 +32498,13 @@ module stdlib_linalg_lapack_q character, intent(in) :: norm, uplo integer(ilp), intent(in) :: n ! Array Arguments - real(qp), intent(in) :: ap(*) - real(qp), intent(out) :: work(*) + real(${rk}$), intent(in) :: ap(*) + real(${rk}$), intent(out) :: work(*) ! ===================================================================== ! Local Scalars integer(ilp) :: i, j, k - real(qp) :: absa, scale, sum, value + real(${rk}$) :: absa, scale, sum, value ! Intrinsic Functions intrinsic :: abs,sqrt ! Executable Statements @@ -32517,7 +32518,7 @@ module stdlib_linalg_lapack_q do j = 1, n do i = k, k + j - 1 sum = abs( ap( i ) ) - if( value < sum .or. stdlib_qisnan( sum ) ) value = sum + if( value < sum .or. stdlib_${ri}$isnan( sum ) ) value = sum end do k = k + j end do @@ -32526,7 +32527,7 @@ module stdlib_linalg_lapack_q do j = 1, n do i = k, k + n - j sum = abs( ap( i ) ) - if( value < sum .or. stdlib_qisnan( sum ) ) value = sum + if( value < sum .or. stdlib_${ri}$isnan( sum ) ) value = sum end do k = k + n - j + 1 end do @@ -32550,7 +32551,7 @@ module stdlib_linalg_lapack_q end do do i = 1, n sum = work( i ) - if( value < sum .or. stdlib_qisnan( sum ) ) value = sum + if( value < sum .or. stdlib_${ri}$isnan( sum ) ) value = sum end do else do i = 1, n @@ -32565,7 +32566,7 @@ module stdlib_linalg_lapack_q work( i ) = work( i ) + absa k = k + 1 end do - if( value < sum .or. stdlib_qisnan( sum ) ) value = sum + if( value < sum .or. stdlib_${ri}$isnan( sum ) ) value = sum end do end if else if( ( stdlib_lsame( norm, 'F' ) ) .or. ( stdlib_lsame( norm, 'E' ) ) ) & @@ -32576,12 +32577,12 @@ module stdlib_linalg_lapack_q k = 2 if( stdlib_lsame( uplo, 'U' ) ) then do j = 2, n - call stdlib_qlassq( j-1, ap( k ), 1, scale, sum ) + call stdlib_${ri}$lassq( j-1, ap( k ), 1, scale, sum ) k = k + j end do else do j = 1, n - 1 - call stdlib_qlassq( n-j, ap( k ), 1, scale, sum ) + call stdlib_${ri}$lassq( n-j, ap( k ), 1, scale, sum ) k = k + n - j + 1 end do end if @@ -32605,12 +32606,12 @@ module stdlib_linalg_lapack_q end do value = scale*sqrt( sum ) end if - stdlib_qlansp = value + stdlib_${ri}$lansp = value return - end function stdlib_qlansp + end function stdlib_${ri}$lansp - pure real(qp) function stdlib_qlanst( norm, n, d, e ) + pure real(${rk}$) function stdlib_${ri}$lanst( norm, n, d, e ) !! DLANST: returns the value of the one norm, or the Frobenius norm, or !! the infinity norm, or the element of largest absolute value of a !! real symmetric tridiagonal matrix A. @@ -32621,12 +32622,12 @@ module stdlib_linalg_lapack_q character, intent(in) :: norm integer(ilp), intent(in) :: n ! Array Arguments - real(qp), intent(in) :: d(*), e(*) + real(${rk}$), intent(in) :: d(*), e(*) ! ===================================================================== ! Local Scalars integer(ilp) :: i - real(qp) :: anorm, scale, sum + real(${rk}$) :: anorm, scale, sum ! Intrinsic Functions intrinsic :: abs,sqrt ! Executable Statements @@ -32637,9 +32638,9 @@ module stdlib_linalg_lapack_q anorm = abs( d( n ) ) do i = 1, n - 1 sum = abs( d( i ) ) - if( anorm < sum .or. stdlib_qisnan( sum ) ) anorm = sum + if( anorm < sum .or. stdlib_${ri}$isnan( sum ) ) anorm = sum sum = abs( e( i ) ) - if( anorm < sum .or. stdlib_qisnan( sum ) ) anorm = sum + if( anorm < sum .or. stdlib_${ri}$isnan( sum ) ) anorm = sum end do else if( stdlib_lsame( norm, 'O' ) .or. norm=='1' .or.stdlib_lsame( norm, 'I' ) ) & then @@ -32649,10 +32650,10 @@ module stdlib_linalg_lapack_q else anorm = abs( d( 1 ) )+abs( e( 1 ) ) sum = abs( e( n-1 ) )+abs( d( n ) ) - if( anorm < sum .or. stdlib_qisnan( sum ) ) anorm = sum + if( anorm < sum .or. stdlib_${ri}$isnan( sum ) ) anorm = sum do i = 2, n - 1 sum = abs( d( i ) )+abs( e( i ) )+abs( e( i-1 ) ) - if( anorm < sum .or. stdlib_qisnan( sum ) ) anorm = sum + if( anorm < sum .or. stdlib_${ri}$isnan( sum ) ) anorm = sum end do end if else if( ( stdlib_lsame( norm, 'F' ) ) .or. ( stdlib_lsame( norm, 'E' ) ) ) & @@ -32661,18 +32662,18 @@ module stdlib_linalg_lapack_q scale = zero sum = one if( n>1 ) then - call stdlib_qlassq( n-1, e, 1, scale, sum ) + call stdlib_${ri}$lassq( n-1, e, 1, scale, sum ) sum = 2*sum end if - call stdlib_qlassq( n, d, 1, scale, sum ) + call stdlib_${ri}$lassq( n, d, 1, scale, sum ) anorm = scale*sqrt( sum ) end if - stdlib_qlanst = anorm + stdlib_${ri}$lanst = anorm return - end function stdlib_qlanst + end function stdlib_${ri}$lanst - real(qp) function stdlib_qlansy( norm, uplo, n, a, lda, work ) + real(${rk}$) function stdlib_${ri}$lansy( norm, uplo, n, a, lda, work ) !! DLANSY: returns the value of the one norm, or the Frobenius norm, or !! the infinity norm, or the element of largest absolute value of a !! real symmetric matrix A. @@ -32683,13 +32684,13 @@ module stdlib_linalg_lapack_q character, intent(in) :: norm, uplo integer(ilp), intent(in) :: lda, n ! Array Arguments - real(qp), intent(in) :: a(lda,*) - real(qp), intent(out) :: work(*) + real(${rk}$), intent(in) :: a(lda,*) + real(${rk}$), intent(out) :: work(*) ! ===================================================================== ! Local Scalars integer(ilp) :: i, j - real(qp) :: absa, scale, sum, value + real(${rk}$) :: absa, scale, sum, value ! Intrinsic Functions intrinsic :: abs,sqrt ! Executable Statements @@ -32702,14 +32703,14 @@ module stdlib_linalg_lapack_q do j = 1, n do i = 1, j sum = abs( a( i, j ) ) - if( value < sum .or. stdlib_qisnan( sum ) ) value = sum + if( value < sum .or. stdlib_${ri}$isnan( sum ) ) value = sum end do end do else do j = 1, n do i = j, n sum = abs( a( i, j ) ) - if( value < sum .or. stdlib_qisnan( sum ) ) value = sum + if( value < sum .or. stdlib_${ri}$isnan( sum ) ) value = sum end do end do end if @@ -32729,7 +32730,7 @@ module stdlib_linalg_lapack_q end do do i = 1, n sum = work( i ) - if( value < sum .or. stdlib_qisnan( sum ) ) value = sum + if( value < sum .or. stdlib_${ri}$isnan( sum ) ) value = sum end do else do i = 1, n @@ -32742,7 +32743,7 @@ module stdlib_linalg_lapack_q sum = sum + absa work( i ) = work( i ) + absa end do - if( value < sum .or. stdlib_qisnan( sum ) ) value = sum + if( value < sum .or. stdlib_${ri}$isnan( sum ) ) value = sum end do end if else if( ( stdlib_lsame( norm, 'F' ) ) .or. ( stdlib_lsame( norm, 'E' ) ) ) & @@ -32752,23 +32753,23 @@ module stdlib_linalg_lapack_q sum = one if( stdlib_lsame( uplo, 'U' ) ) then do j = 2, n - call stdlib_qlassq( j-1, a( 1, j ), 1, scale, sum ) + call stdlib_${ri}$lassq( j-1, a( 1, j ), 1, scale, sum ) end do else do j = 1, n - 1 - call stdlib_qlassq( n-j, a( j+1, j ), 1, scale, sum ) + call stdlib_${ri}$lassq( n-j, a( j+1, j ), 1, scale, sum ) end do end if sum = 2*sum - call stdlib_qlassq( n, a, lda+1, scale, sum ) + call stdlib_${ri}$lassq( n, a, lda+1, scale, sum ) value = scale*sqrt( sum ) end if - stdlib_qlansy = value + stdlib_${ri}$lansy = value return - end function stdlib_qlansy + end function stdlib_${ri}$lansy - real(qp) function stdlib_qlantb( norm, uplo, diag, n, k, ab,ldab, work ) + real(${rk}$) function stdlib_${ri}$lantb( norm, uplo, diag, n, k, ab,ldab, work ) !! DLANTB: returns the value of the one norm, or the Frobenius norm, or !! the infinity norm, or the element of largest absolute value of an !! n by n triangular band matrix A, with ( k + 1 ) diagonals. @@ -32779,14 +32780,14 @@ module stdlib_linalg_lapack_q character, intent(in) :: diag, norm, uplo integer(ilp), intent(in) :: k, ldab, n ! Array Arguments - real(qp), intent(in) :: ab(ldab,*) - real(qp), intent(out) :: work(*) + real(${rk}$), intent(in) :: ab(ldab,*) + real(${rk}$), intent(out) :: work(*) ! ===================================================================== ! Local Scalars logical(lk) :: udiag integer(ilp) :: i, j, l - real(qp) :: scale, sum, value + real(${rk}$) :: scale, sum, value ! Intrinsic Functions intrinsic :: abs,max,min,sqrt ! Executable Statements @@ -32800,14 +32801,14 @@ module stdlib_linalg_lapack_q do j = 1, n do i = max( k+2-j, 1 ), k sum = abs( ab( i, j ) ) - if( value < sum .or. stdlib_qisnan( sum ) ) value = sum + if( value < sum .or. stdlib_${ri}$isnan( sum ) ) value = sum end do end do else do j = 1, n do i = 2, min( n+1-j, k+1 ) sum = abs( ab( i, j ) ) - if( value < sum .or. stdlib_qisnan( sum ) ) value = sum + if( value < sum .or. stdlib_${ri}$isnan( sum ) ) value = sum end do end do end if @@ -32817,14 +32818,14 @@ module stdlib_linalg_lapack_q do j = 1, n do i = max( k+2-j, 1 ), k + 1 sum = abs( ab( i, j ) ) - if( value < sum .or. stdlib_qisnan( sum ) ) value = sum + if( value < sum .or. stdlib_${ri}$isnan( sum ) ) value = sum end do end do else do j = 1, n do i = 1, min( n+1-j, k+1 ) sum = abs( ab( i, j ) ) - if( value < sum .or. stdlib_qisnan( sum ) ) value = sum + if( value < sum .or. stdlib_${ri}$isnan( sum ) ) value = sum end do end do end if @@ -32846,7 +32847,7 @@ module stdlib_linalg_lapack_q sum = sum + abs( ab( i, j ) ) end do end if - if( value < sum .or. stdlib_qisnan( sum ) ) value = sum + if( value < sum .or. stdlib_${ri}$isnan( sum ) ) value = sum end do else do j = 1, n @@ -32861,7 +32862,7 @@ module stdlib_linalg_lapack_q sum = sum + abs( ab( i, j ) ) end do end if - if( value < sum .or. stdlib_qisnan( sum ) ) value = sum + if( value < sum .or. stdlib_${ri}$isnan( sum ) ) value = sum end do end if else if( stdlib_lsame( norm, 'I' ) ) then @@ -32914,7 +32915,7 @@ module stdlib_linalg_lapack_q end if do i = 1, n sum = work( i ) - if( value < sum .or. stdlib_qisnan( sum ) ) value = sum + if( value < sum .or. stdlib_${ri}$isnan( sum ) ) value = sum end do else if( ( stdlib_lsame( norm, 'F' ) ) .or. ( stdlib_lsame( norm, 'E' ) ) ) & then @@ -32925,7 +32926,7 @@ module stdlib_linalg_lapack_q sum = n if( k>0 ) then do j = 2, n - call stdlib_qlassq( min( j-1, k ),ab( max( k+2-j, 1 ), j ), 1, scale,& + call stdlib_${ri}$lassq( min( j-1, k ),ab( max( k+2-j, 1 ), j ), 1, scale,& sum ) end do end if @@ -32933,7 +32934,7 @@ module stdlib_linalg_lapack_q scale = zero sum = one do j = 1, n - call stdlib_qlassq( min( j, k+1 ), ab( max( k+2-j, 1 ), j ),1, scale, sum ) + call stdlib_${ri}$lassq( min( j, k+1 ), ab( max( k+2-j, 1 ), j ),1, scale, sum ) end do end if @@ -32943,25 +32944,25 @@ module stdlib_linalg_lapack_q sum = n if( k>0 ) then do j = 1, n - 1 - call stdlib_qlassq( min( n-j, k ), ab( 2, j ), 1, scale,sum ) + call stdlib_${ri}$lassq( min( n-j, k ), ab( 2, j ), 1, scale,sum ) end do end if else scale = zero sum = one do j = 1, n - call stdlib_qlassq( min( n-j+1, k+1 ), ab( 1, j ), 1, scale,sum ) + call stdlib_${ri}$lassq( min( n-j+1, k+1 ), ab( 1, j ), 1, scale,sum ) end do end if end if value = scale*sqrt( sum ) end if - stdlib_qlantb = value + stdlib_${ri}$lantb = value return - end function stdlib_qlantb + end function stdlib_${ri}$lantb - real(qp) function stdlib_qlantp( norm, uplo, diag, n, ap, work ) + real(${rk}$) function stdlib_${ri}$lantp( norm, uplo, diag, n, ap, work ) !! DLANTP: returns the value of the one norm, or the Frobenius norm, or !! the infinity norm, or the element of largest absolute value of a !! triangular matrix A, supplied in packed form. @@ -32972,14 +32973,14 @@ module stdlib_linalg_lapack_q character, intent(in) :: diag, norm, uplo integer(ilp), intent(in) :: n ! Array Arguments - real(qp), intent(in) :: ap(*) - real(qp), intent(out) :: work(*) + real(${rk}$), intent(in) :: ap(*) + real(${rk}$), intent(out) :: work(*) ! ===================================================================== ! Local Scalars logical(lk) :: udiag integer(ilp) :: i, j, k - real(qp) :: scale, sum, value + real(${rk}$) :: scale, sum, value ! Intrinsic Functions intrinsic :: abs,sqrt ! Executable Statements @@ -32994,7 +32995,7 @@ module stdlib_linalg_lapack_q do j = 1, n do i = k, k + j - 2 sum = abs( ap( i ) ) - if( value < sum .or. stdlib_qisnan( sum ) ) value = sum + if( value < sum .or. stdlib_${ri}$isnan( sum ) ) value = sum end do k = k + j end do @@ -33002,7 +33003,7 @@ module stdlib_linalg_lapack_q do j = 1, n do i = k + 1, k + n - j sum = abs( ap( i ) ) - if( value < sum .or. stdlib_qisnan( sum ) ) value = sum + if( value < sum .or. stdlib_${ri}$isnan( sum ) ) value = sum end do k = k + n - j + 1 end do @@ -33013,7 +33014,7 @@ module stdlib_linalg_lapack_q do j = 1, n do i = k, k + j - 1 sum = abs( ap( i ) ) - if( value < sum .or. stdlib_qisnan( sum ) ) value = sum + if( value < sum .or. stdlib_${ri}$isnan( sum ) ) value = sum end do k = k + j end do @@ -33021,7 +33022,7 @@ module stdlib_linalg_lapack_q do j = 1, n do i = k, k + n - j sum = abs( ap( i ) ) - if( value < sum .or. stdlib_qisnan( sum ) ) value = sum + if( value < sum .or. stdlib_${ri}$isnan( sum ) ) value = sum end do k = k + n - j + 1 end do @@ -33046,7 +33047,7 @@ module stdlib_linalg_lapack_q end do end if k = k + j - if( value < sum .or. stdlib_qisnan( sum ) ) value = sum + if( value < sum .or. stdlib_${ri}$isnan( sum ) ) value = sum end do else do j = 1, n @@ -33062,7 +33063,7 @@ module stdlib_linalg_lapack_q end do end if k = k + n - j + 1 - if( value < sum .or. stdlib_qisnan( sum ) ) value = sum + if( value < sum .or. stdlib_${ri}$isnan( sum ) ) value = sum end do end if else if( stdlib_lsame( norm, 'I' ) ) then @@ -33118,7 +33119,7 @@ module stdlib_linalg_lapack_q value = zero do i = 1, n sum = work( i ) - if( value < sum .or. stdlib_qisnan( sum ) ) value = sum + if( value < sum .or. stdlib_${ri}$isnan( sum ) ) value = sum end do else if( ( stdlib_lsame( norm, 'F' ) ) .or. ( stdlib_lsame( norm, 'E' ) ) ) & then @@ -33129,7 +33130,7 @@ module stdlib_linalg_lapack_q sum = n k = 2 do j = 2, n - call stdlib_qlassq( j-1, ap( k ), 1, scale, sum ) + call stdlib_${ri}$lassq( j-1, ap( k ), 1, scale, sum ) k = k + j end do else @@ -33137,7 +33138,7 @@ module stdlib_linalg_lapack_q sum = one k = 1 do j = 1, n - call stdlib_qlassq( j, ap( k ), 1, scale, sum ) + call stdlib_${ri}$lassq( j, ap( k ), 1, scale, sum ) k = k + j end do end if @@ -33147,7 +33148,7 @@ module stdlib_linalg_lapack_q sum = n k = 2 do j = 1, n - 1 - call stdlib_qlassq( n-j, ap( k ), 1, scale, sum ) + call stdlib_${ri}$lassq( n-j, ap( k ), 1, scale, sum ) k = k + n - j + 1 end do else @@ -33155,19 +33156,19 @@ module stdlib_linalg_lapack_q sum = one k = 1 do j = 1, n - call stdlib_qlassq( n-j+1, ap( k ), 1, scale, sum ) + call stdlib_${ri}$lassq( n-j+1, ap( k ), 1, scale, sum ) k = k + n - j + 1 end do end if end if value = scale*sqrt( sum ) end if - stdlib_qlantp = value + stdlib_${ri}$lantp = value return - end function stdlib_qlantp + end function stdlib_${ri}$lantp - real(qp) function stdlib_qlantr( norm, uplo, diag, m, n, a, lda,work ) + real(${rk}$) function stdlib_${ri}$lantr( norm, uplo, diag, m, n, a, lda,work ) !! DLANTR: returns the value of the one norm, or the Frobenius norm, or !! the infinity norm, or the element of largest absolute value of a !! trapezoidal or triangular matrix A. @@ -33178,14 +33179,14 @@ module stdlib_linalg_lapack_q character, intent(in) :: diag, norm, uplo integer(ilp), intent(in) :: lda, m, n ! Array Arguments - real(qp), intent(in) :: a(lda,*) - real(qp), intent(out) :: work(*) + real(${rk}$), intent(in) :: a(lda,*) + real(${rk}$), intent(out) :: work(*) ! ===================================================================== ! Local Scalars logical(lk) :: udiag integer(ilp) :: i, j - real(qp) :: scale, sum, value + real(${rk}$) :: scale, sum, value ! Intrinsic Functions intrinsic :: abs,min,sqrt ! Executable Statements @@ -33199,14 +33200,14 @@ module stdlib_linalg_lapack_q do j = 1, n do i = 1, min( m, j-1 ) sum = abs( a( i, j ) ) - if( value < sum .or. stdlib_qisnan( sum ) ) value = sum + if( value < sum .or. stdlib_${ri}$isnan( sum ) ) value = sum end do end do else do j = 1, n do i = j + 1, m sum = abs( a( i, j ) ) - if( value < sum .or. stdlib_qisnan( sum ) ) value = sum + if( value < sum .or. stdlib_${ri}$isnan( sum ) ) value = sum end do end do end if @@ -33216,14 +33217,14 @@ module stdlib_linalg_lapack_q do j = 1, n do i = 1, min( m, j ) sum = abs( a( i, j ) ) - if( value < sum .or. stdlib_qisnan( sum ) ) value = sum + if( value < sum .or. stdlib_${ri}$isnan( sum ) ) value = sum end do end do else do j = 1, n do i = j, m sum = abs( a( i, j ) ) - if( value < sum .or. stdlib_qisnan( sum ) ) value = sum + if( value < sum .or. stdlib_${ri}$isnan( sum ) ) value = sum end do end do end if @@ -33245,7 +33246,7 @@ module stdlib_linalg_lapack_q sum = sum + abs( a( i, j ) ) end do end if - if( value < sum .or. stdlib_qisnan( sum ) ) value = sum + if( value < sum .or. stdlib_${ri}$isnan( sum ) ) value = sum end do else do j = 1, n @@ -33260,7 +33261,7 @@ module stdlib_linalg_lapack_q sum = sum + abs( a( i, j ) ) end do end if - if( value < sum .or. stdlib_qisnan( sum ) ) value = sum + if( value < sum .or. stdlib_${ri}$isnan( sum ) ) value = sum end do end if else if( stdlib_lsame( norm, 'I' ) ) then @@ -33312,7 +33313,7 @@ module stdlib_linalg_lapack_q value = zero do i = 1, m sum = work( i ) - if( value < sum .or. stdlib_qisnan( sum ) ) value = sum + if( value < sum .or. stdlib_${ri}$isnan( sum ) ) value = sum end do else if( ( stdlib_lsame( norm, 'F' ) ) .or. ( stdlib_lsame( norm, 'E' ) ) ) & then @@ -33322,13 +33323,13 @@ module stdlib_linalg_lapack_q scale = one sum = min( m, n ) do j = 2, n - call stdlib_qlassq( min( m, j-1 ), a( 1, j ), 1, scale, sum ) + call stdlib_${ri}$lassq( min( m, j-1 ), a( 1, j ), 1, scale, sum ) end do else scale = zero sum = one do j = 1, n - call stdlib_qlassq( min( m, j ), a( 1, j ), 1, scale, sum ) + call stdlib_${ri}$lassq( min( m, j ), a( 1, j ), 1, scale, sum ) end do end if else @@ -33336,24 +33337,24 @@ module stdlib_linalg_lapack_q scale = one sum = min( m, n ) do j = 1, n - call stdlib_qlassq( m-j, a( min( m, j+1 ), j ), 1, scale,sum ) + call stdlib_${ri}$lassq( m-j, a( min( m, j+1 ), j ), 1, scale,sum ) end do else scale = zero sum = one do j = 1, n - call stdlib_qlassq( m-j+1, a( j, j ), 1, scale, sum ) + call stdlib_${ri}$lassq( m-j+1, a( j, j ), 1, scale, sum ) end do end if end if value = scale*sqrt( sum ) end if - stdlib_qlantr = value + stdlib_${ri}$lantr = value return - end function stdlib_qlantr + end function stdlib_${ri}$lantr - pure subroutine stdlib_qlanv2( a, b, c, d, rt1r, rt1i, rt2r, rt2i, cs, sn ) + pure subroutine stdlib_${ri}$lanv2( a, b, c, d, rt1r, rt1i, rt2r, rt2i, cs, sn ) !! DLANV2: computes the Schur factorization of a real 2-by-2 nonsymmetric !! matrix in standard form: !! [ A B ] = [ CS -SN ] [ AA BB ] [ CS SN ] @@ -33366,23 +33367,23 @@ module stdlib_linalg_lapack_q ! -- lapack is a software package provided by univ. of tennessee, -- ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments - real(qp), intent(inout) :: a, b, c, d - real(qp), intent(out) :: cs, rt1i, rt1r, rt2i, rt2r, sn + real(${rk}$), intent(inout) :: a, b, c, d + real(${rk}$), intent(out) :: cs, rt1i, rt1r, rt2i, rt2r, sn ! ===================================================================== ! Parameters - real(qp), parameter :: multpl = 4.0e+0_qp + real(${rk}$), parameter :: multpl = 4.0e+0_${rk}$ ! Local Scalars - real(qp) :: aa, bb, bcmax, bcmis, cc, cs1, dd, eps, p, sab, sac, scale, sigma, sn1, & + real(${rk}$) :: aa, bb, bcmax, bcmis, cc, cs1, dd, eps, p, sab, sac, scale, sigma, sn1, & tau, temp, z, safmin, safmn2, safmx2 integer(ilp) :: count ! Intrinsic Functions intrinsic :: abs,max,min,sign,sqrt ! Executable Statements - safmin = stdlib_qlamch( 'S' ) - eps = stdlib_qlamch( 'P' ) - safmn2 = stdlib_qlamch( 'B' )**int( log( safmin / eps ) /log( stdlib_qlamch( 'B' ) ) / & + safmin = stdlib_${ri}$lamch( 'S' ) + eps = stdlib_${ri}$lamch( 'P' ) + safmn2 = stdlib_${ri}$lamch( 'B' )**int( log( safmin / eps ) /log( stdlib_${ri}$lamch( 'B' ) ) / & two,KIND=ilp) safmx2 = one / safmn2 if( c==zero ) then @@ -33415,13 +33416,13 @@ module stdlib_linalg_lapack_q a = d + z d = d - ( bcmax / z )*bcmis ! compute b and the rotation matrix - tau = stdlib_qlapy2( c, z ) + tau = stdlib_${ri}$lapy2( c, z ) cs = z / tau sn = c / tau b = b - c c = zero else - ! complex eigenvalues, or real(almost,KIND=qp) equal eigenvalues. + ! complex eigenvalues, or real(almost,KIND=${rk}$) equal eigenvalues. ! make diagonal elements equal. count = 0 sigma = b + c @@ -33439,7 +33440,7 @@ module stdlib_linalg_lapack_q if (count <= 20)goto 10 end if p = half*temp - tau = stdlib_qlapy2( sigma, temp ) + tau = stdlib_${ri}$lapy2( sigma, temp ) cs = sqrt( half*( one+abs( sigma ) / tau ) ) sn = -( p / ( tau*cs ) )*sign( one, sigma ) ! compute [ aa bb ] = [ a b ] [ cs -sn ] @@ -33496,10 +33497,10 @@ module stdlib_linalg_lapack_q rt2i = -rt1i end if return - end subroutine stdlib_qlanv2 + end subroutine stdlib_${ri}$lanv2 - pure subroutine stdlib_qlaorhr_col_getrfnp( m, n, a, lda, d, info ) + pure subroutine stdlib_${ri}$laorhr_col_getrfnp( m, n, a, lda, d, info ) !! DLAORHR_COL_GETRFNP: computes the modified LU factorization without !! pivoting of a real general M-by-N matrix A. The factorization has !! the form: @@ -33540,8 +33541,8 @@ module stdlib_linalg_lapack_q integer(ilp), intent(out) :: info integer(ilp), intent(in) :: lda, m, n ! Array Arguments - real(qp), intent(inout) :: a(lda,*) - real(qp), intent(out) :: d(*) + real(${rk}$), intent(inout) :: a(lda,*) + real(${rk}$), intent(out) :: d(*) ! ===================================================================== ! Local Scalars @@ -33568,21 +33569,21 @@ module stdlib_linalg_lapack_q nb = stdlib_ilaenv( 1, 'DLAORHR_COL_GETRFNP', ' ', m, n, -1, -1 ) if( nb<=1 .or. nb>=min( m, n ) ) then ! use unblocked code. - call stdlib_qlaorhr_col_getrfnp2( m, n, a, lda, d, info ) + call stdlib_${ri}$laorhr_col_getrfnp2( m, n, a, lda, d, info ) else ! use blocked code. do j = 1, min( m, n ), nb jb = min( min( m, n )-j+1, nb ) ! factor diagonal and subdiagonal blocks. - call stdlib_qlaorhr_col_getrfnp2( m-j+1, jb, a( j, j ), lda,d( j ), iinfo ) + call stdlib_${ri}$laorhr_col_getrfnp2( m-j+1, jb, a( j, j ), lda,d( j ), iinfo ) if( j+jb<=n ) then ! compute block row of u. - call stdlib_qtrsm( 'LEFT', 'LOWER', 'NO TRANSPOSE', 'UNIT', jb,n-j-jb+1, one, & + call stdlib_${ri}$trsm( 'LEFT', 'LOWER', 'NO TRANSPOSE', 'UNIT', jb,n-j-jb+1, one, & a( j, j ), lda, a( j, j+jb ),lda ) if( j+jb<=m ) then ! update trailing submatrix. - call stdlib_qgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', m-j-jb+1,n-j-jb+1, jb, -& + call stdlib_${ri}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', m-j-jb+1,n-j-jb+1, jb, -& one, a( j+jb, j ), lda,a( j, j+jb ), lda, one, a( j+jb, j+jb ),lda ) end if @@ -33590,10 +33591,10 @@ module stdlib_linalg_lapack_q end do end if return - end subroutine stdlib_qlaorhr_col_getrfnp + end subroutine stdlib_${ri}$laorhr_col_getrfnp - pure recursive subroutine stdlib_qlaorhr_col_getrfnp2( m, n, a, lda, d, info ) + pure recursive subroutine stdlib_${ri}$laorhr_col_getrfnp2( m, n, a, lda, d, info ) !! DLAORHR_COL_GETRFNP2: computes the modified LU factorization without !! pivoting of a real general M-by-N matrix A. The factorization has !! the form: @@ -33649,12 +33650,12 @@ module stdlib_linalg_lapack_q integer(ilp), intent(out) :: info integer(ilp), intent(in) :: lda, m, n ! Array Arguments - real(qp), intent(inout) :: a(lda,*) - real(qp), intent(out) :: d(*) + real(${rk}$), intent(inout) :: a(lda,*) + real(${rk}$), intent(out) :: d(*) ! ===================================================================== ! Local Scalars - real(qp) :: sfmin + real(${rk}$) :: sfmin integer(ilp) :: i, iinfo, n1, n2 ! Intrinsic Functions intrinsic :: abs,sign,max,min @@ -33690,10 +33691,10 @@ module stdlib_linalg_lapack_q a( 1, 1 ) = a( 1, 1 ) - d( 1 ) ! scale the elements 2:m of the column ! determine machine safe minimum - sfmin = stdlib_qlamch('S') + sfmin = stdlib_${ri}$lamch('S') ! construct the subdiagonal elements of l if( abs( a( 1, 1 ) ) >= sfmin ) then - call stdlib_qscal( m-1, one / a( 1, 1 ), a( 2, 1 ), 1 ) + call stdlib_${ri}$scal( m-1, one / a( 1, 1 ), a( 2, 1 ), 1 ) else do i = 2, m a( i, 1 ) = a( i, 1 ) / a( 1, 1 ) @@ -33704,26 +33705,26 @@ module stdlib_linalg_lapack_q n1 = min( m, n ) / 2 n2 = n-n1 ! factor b11, recursive call - call stdlib_qlaorhr_col_getrfnp2( n1, n1, a, lda, d, iinfo ) + call stdlib_${ri}$laorhr_col_getrfnp2( n1, n1, a, lda, d, iinfo ) ! solve for b21 - call stdlib_qtrsm( 'R', 'U', 'N', 'N', m-n1, n1, one, a, lda,a( n1+1, 1 ), lda ) + call stdlib_${ri}$trsm( 'R', 'U', 'N', 'N', m-n1, n1, one, a, lda,a( n1+1, 1 ), lda ) ! solve for b12 - call stdlib_qtrsm( 'L', 'L', 'N', 'U', n1, n2, one, a, lda,a( 1, n1+1 ), lda ) + call stdlib_${ri}$trsm( 'L', 'L', 'N', 'U', n1, n2, one, a, lda,a( 1, n1+1 ), lda ) ! update b22, i.e. compute the schur complement ! b22 := b22 - b21*b12 - call stdlib_qgemm( 'N', 'N', m-n1, n2, n1, -one, a( n1+1, 1 ), lda,a( 1, n1+1 ), & + call stdlib_${ri}$gemm( 'N', 'N', m-n1, n2, n1, -one, a( n1+1, 1 ), lda,a( 1, n1+1 ), & lda, one, a( n1+1, n1+1 ), lda ) ! factor b22, recursive call - call stdlib_qlaorhr_col_getrfnp2( m-n1, n2, a( n1+1, n1+1 ), lda,d( n1+1 ), iinfo ) + call stdlib_${ri}$laorhr_col_getrfnp2( m-n1, n2, a( n1+1, n1+1 ), lda,d( n1+1 ), iinfo ) end if return - end subroutine stdlib_qlaorhr_col_getrfnp2 + end subroutine stdlib_${ri}$laorhr_col_getrfnp2 - pure subroutine stdlib_qlapll( n, x, incx, y, incy, ssmin ) + pure subroutine stdlib_${ri}$lapll( n, x, incx, y, incy, ssmin ) !! Given two column vectors X and Y, let !! A = ( X Y ). !! The subroutine first computes the QR factorization of A = Q*R, @@ -33735,13 +33736,13 @@ module stdlib_linalg_lapack_q ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments integer(ilp), intent(in) :: incx, incy, n - real(qp), intent(out) :: ssmin + real(${rk}$), intent(out) :: ssmin ! Array Arguments - real(qp), intent(inout) :: x(*), y(*) + real(${rk}$), intent(inout) :: x(*), y(*) ! ===================================================================== ! Local Scalars - real(qp) :: a11, a12, a22, c, ssmax, tau + real(${rk}$) :: a11, a12, a22, c, ssmax, tau ! Executable Statements ! quick return if possible if( n<=1 ) then @@ -33749,21 +33750,21 @@ module stdlib_linalg_lapack_q return end if ! compute the qr factorization of the n-by-2 matrix ( x y ) - call stdlib_qlarfg( n, x( 1 ), x( 1+incx ), incx, tau ) + call stdlib_${ri}$larfg( n, x( 1 ), x( 1+incx ), incx, tau ) a11 = x( 1 ) x( 1 ) = one - c = -tau*stdlib_qdot( n, x, incx, y, incy ) - call stdlib_qaxpy( n, c, x, incx, y, incy ) - call stdlib_qlarfg( n-1, y( 1+incy ), y( 1+2*incy ), incy, tau ) + c = -tau*stdlib_${ri}$dot( n, x, incx, y, incy ) + call stdlib_${ri}$axpy( n, c, x, incx, y, incy ) + call stdlib_${ri}$larfg( n-1, y( 1+incy ), y( 1+2*incy ), incy, tau ) a12 = y( 1 ) a22 = y( 1+incy ) ! compute the svd of 2-by-2 upper triangular matrix. - call stdlib_qlas2( a11, a12, a22, ssmin, ssmax ) + call stdlib_${ri}$las2( a11, a12, a22, ssmin, ssmax ) return - end subroutine stdlib_qlapll + end subroutine stdlib_${ri}$lapll - pure subroutine stdlib_qlapmr( forwrd, m, n, x, ldx, k ) + pure subroutine stdlib_${ri}$lapmr( forwrd, m, n, x, ldx, k ) !! DLAPMR: rearranges the rows of the M by N matrix X as specified !! by the permutation K(1),K(2),...,K(M) of the integers 1,...,M. !! If FORWRD = .TRUE., forward permutation: @@ -33778,11 +33779,11 @@ module stdlib_linalg_lapack_q integer(ilp), intent(in) :: ldx, m, n ! Array Arguments integer(ilp), intent(inout) :: k(*) - real(qp), intent(inout) :: x(ldx,*) + real(${rk}$), intent(inout) :: x(ldx,*) ! ===================================================================== ! Local Scalars integer(ilp) :: i, in, j, jj - real(qp) :: temp + real(${rk}$) :: temp ! Executable Statements if( m<=1 )return do i = 1, m @@ -33828,10 +33829,10 @@ module stdlib_linalg_lapack_q end do end if return - end subroutine stdlib_qlapmr + end subroutine stdlib_${ri}$lapmr - pure subroutine stdlib_qlapmt( forwrd, m, n, x, ldx, k ) + pure subroutine stdlib_${ri}$lapmt( forwrd, m, n, x, ldx, k ) !! DLAPMT: rearranges the columns of the M by N matrix X as specified !! by the permutation K(1),K(2),...,K(N) of the integers 1,...,N. !! If FORWRD = .TRUE., forward permutation: @@ -33846,11 +33847,11 @@ module stdlib_linalg_lapack_q integer(ilp), intent(in) :: ldx, m, n ! Array Arguments integer(ilp), intent(inout) :: k(*) - real(qp), intent(inout) :: x(ldx,*) + real(${rk}$), intent(inout) :: x(ldx,*) ! ===================================================================== ! Local Scalars integer(ilp) :: i, ii, in, j - real(qp) :: temp + real(${rk}$) :: temp ! Executable Statements if( n<=1 )return do i = 1, n @@ -33896,62 +33897,62 @@ module stdlib_linalg_lapack_q end do end if return - end subroutine stdlib_qlapmt + end subroutine stdlib_${ri}$lapmt - pure real(qp) function stdlib_qlapy2( x, y ) + pure real(${rk}$) function stdlib_${ri}$lapy2( x, y ) !! DLAPY2: returns sqrt(x**2+y**2), taking care not to cause unnecessary !! overflow and unnecessary underflow. ! -- lapack auxiliary routine -- ! -- lapack is a software package provided by univ. of tennessee, -- ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments - real(qp), intent(in) :: x, y + real(${rk}$), intent(in) :: x, y ! ===================================================================== ! Local Scalars - real(qp) :: w, xabs, yabs, z, hugeval + real(${rk}$) :: w, xabs, yabs, z, hugeval logical(lk) :: x_is_nan, y_is_nan ! Intrinsic Functions intrinsic :: abs,max,min,sqrt ! Executable Statements - x_is_nan = stdlib_qisnan( x ) - y_is_nan = stdlib_qisnan( y ) - if ( x_is_nan ) stdlib_qlapy2 = x - if ( y_is_nan ) stdlib_qlapy2 = y - hugeval = stdlib_qlamch( 'OVERFLOW' ) + x_is_nan = stdlib_${ri}$isnan( x ) + y_is_nan = stdlib_${ri}$isnan( y ) + if ( x_is_nan ) stdlib_${ri}$lapy2 = x + if ( y_is_nan ) stdlib_${ri}$lapy2 = y + hugeval = stdlib_${ri}$lamch( 'OVERFLOW' ) if ( .not.( x_is_nan.or.y_is_nan ) ) then xabs = abs( x ) yabs = abs( y ) w = max( xabs, yabs ) z = min( xabs, yabs ) if( z==zero .or. w>hugeval ) then - stdlib_qlapy2 = w + stdlib_${ri}$lapy2 = w else - stdlib_qlapy2 = w*sqrt( one+( z / w )**2 ) + stdlib_${ri}$lapy2 = w*sqrt( one+( z / w )**2 ) end if end if return - end function stdlib_qlapy2 + end function stdlib_${ri}$lapy2 - pure real(qp) function stdlib_qlapy3( x, y, z ) + pure real(${rk}$) function stdlib_${ri}$lapy3( x, y, z ) !! DLAPY3: returns sqrt(x**2+y**2+z**2), taking care not to cause !! unnecessary overflow and unnecessary underflow. ! -- lapack auxiliary routine -- ! -- lapack is a software package provided by univ. of tennessee, -- ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments - real(qp), intent(in) :: x, y, z + real(${rk}$), intent(in) :: x, y, z ! ===================================================================== ! Local Scalars - real(qp) :: w, xabs, yabs, zabs, hugeval + real(${rk}$) :: w, xabs, yabs, zabs, hugeval ! Intrinsic Functions intrinsic :: abs,max,sqrt ! Executable Statements - hugeval = stdlib_qlamch( 'OVERFLOW' ) + hugeval = stdlib_${ri}$lamch( 'OVERFLOW' ) xabs = abs( x ) yabs = abs( y ) zabs = abs( z ) @@ -33960,15 +33961,15 @@ module stdlib_linalg_lapack_q ! w can be zero for max(0,nan,0) ! adding all three entries together will make sure ! nan will not disappear. - stdlib_qlapy3 = xabs + yabs + zabs + stdlib_${ri}$lapy3 = xabs + yabs + zabs else - stdlib_qlapy3 = w*sqrt( ( xabs / w )**2+( yabs / w )**2+( zabs / w )**2 ) + stdlib_${ri}$lapy3 = w*sqrt( ( xabs / w )**2+( yabs / w )**2+( zabs / w )**2 ) end if return - end function stdlib_qlapy3 + end function stdlib_${ri}$lapy3 - pure subroutine stdlib_qlaqgb( m, n, kl, ku, ab, ldab, r, c, rowcnd, colcnd,amax, equed ) + pure subroutine stdlib_${ri}$laqgb( m, n, kl, ku, ab, ldab, r, c, rowcnd, colcnd,amax, equed ) !! DLAQGB: equilibrates a general M by N band matrix A with KL !! subdiagonals and KU superdiagonals using the row and scaling factors !! in the vectors R and C. @@ -33979,17 +33980,17 @@ module stdlib_linalg_lapack_q ! Scalar Arguments character, intent(out) :: equed integer(ilp), intent(in) :: kl, ku, ldab, m, n - real(qp), intent(in) :: amax, colcnd, rowcnd + real(${rk}$), intent(in) :: amax, colcnd, rowcnd ! Array Arguments - real(qp), intent(inout) :: ab(ldab,*) - real(qp), intent(in) :: c(*), r(*) + real(${rk}$), intent(inout) :: ab(ldab,*) + real(${rk}$), intent(in) :: c(*), r(*) ! ===================================================================== ! Parameters - real(qp), parameter :: thresh = 0.1e+0_qp + real(${rk}$), parameter :: thresh = 0.1e+0_${rk}$ ! Local Scalars integer(ilp) :: i, j - real(qp) :: cj, large, small + real(${rk}$) :: cj, large, small ! Intrinsic Functions intrinsic :: max,min ! Executable Statements @@ -33999,7 +34000,7 @@ module stdlib_linalg_lapack_q return end if ! initialize large and small. - small = stdlib_qlamch( 'SAFE MINIMUM' ) / stdlib_qlamch( 'PRECISION' ) + small = stdlib_${ri}$lamch( 'SAFE MINIMUM' ) / stdlib_${ri}$lamch( 'PRECISION' ) large = one / small if( rowcnd>=thresh .and. amax>=small .and. amax<=large )then ! no row scaling @@ -34035,10 +34036,10 @@ module stdlib_linalg_lapack_q equed = 'B' end if return - end subroutine stdlib_qlaqgb + end subroutine stdlib_${ri}$laqgb - pure subroutine stdlib_qlaqge( m, n, a, lda, r, c, rowcnd, colcnd, amax,equed ) + pure subroutine stdlib_${ri}$laqge( m, n, a, lda, r, c, rowcnd, colcnd, amax,equed ) !! DLAQGE: equilibrates a general M by N matrix A using the row and !! column scaling factors in the vectors R and C. ! -- lapack auxiliary routine -- @@ -34047,17 +34048,17 @@ module stdlib_linalg_lapack_q ! Scalar Arguments character, intent(out) :: equed integer(ilp), intent(in) :: lda, m, n - real(qp), intent(in) :: amax, colcnd, rowcnd + real(${rk}$), intent(in) :: amax, colcnd, rowcnd ! Array Arguments - real(qp), intent(inout) :: a(lda,*) - real(qp), intent(in) :: c(*), r(*) + real(${rk}$), intent(inout) :: a(lda,*) + real(${rk}$), intent(in) :: c(*), r(*) ! ===================================================================== ! Parameters - real(qp), parameter :: thresh = 0.1e+0_qp + real(${rk}$), parameter :: thresh = 0.1e+0_${rk}$ ! Local Scalars integer(ilp) :: i, j - real(qp) :: cj, large, small + real(${rk}$) :: cj, large, small ! Executable Statements ! quick return if possible if( m<=0 .or. n<=0 ) then @@ -34065,7 +34066,7 @@ module stdlib_linalg_lapack_q return end if ! initialize large and small. - small = stdlib_qlamch( 'SAFE MINIMUM' ) / stdlib_qlamch( 'PRECISION' ) + small = stdlib_${ri}$lamch( 'SAFE MINIMUM' ) / stdlib_${ri}$lamch( 'PRECISION' ) large = one / small if( rowcnd>=thresh .and. amax>=small .and. amax<=large )then ! no row scaling @@ -34101,10 +34102,10 @@ module stdlib_linalg_lapack_q equed = 'B' end if return - end subroutine stdlib_qlaqge + end subroutine stdlib_${ri}$laqge - pure subroutine stdlib_qlaqp2( m, n, offset, a, lda, jpvt, tau, vn1, vn2,work ) + pure subroutine stdlib_${ri}$laqp2( m, n, offset, a, lda, jpvt, tau, vn1, vn2,work ) !! DLAQP2: computes a QR factorization with column pivoting of !! the block A(OFFSET+1:M,1:N). !! The block A(1:OFFSET,1:N) is accordingly pivoted, but not factorized. @@ -34115,25 +34116,25 @@ module stdlib_linalg_lapack_q integer(ilp), intent(in) :: lda, m, n, offset ! Array Arguments integer(ilp), intent(inout) :: jpvt(*) - real(qp), intent(inout) :: a(lda,*), vn1(*), vn2(*) - real(qp), intent(out) :: tau(*), work(*) + real(${rk}$), intent(inout) :: a(lda,*), vn1(*), vn2(*) + real(${rk}$), intent(out) :: tau(*), work(*) ! ===================================================================== ! Local Scalars integer(ilp) :: i, itemp, j, mn, offpi, pvt - real(qp) :: aii, temp, temp2, tol3z + real(${rk}$) :: aii, temp, temp2, tol3z ! Intrinsic Functions intrinsic :: abs,max,min,sqrt ! Executable Statements mn = min( m-offset, n ) - tol3z = sqrt(stdlib_qlamch('EPSILON')) + tol3z = sqrt(stdlib_${ri}$lamch('EPSILON')) ! compute factorization. loop_20: do i = 1, mn offpi = offset + i ! determine ith pivot column and swap if necessary. - pvt = ( i-1 ) + stdlib_iqamax( n-i+1, vn1( i ), 1 ) + pvt = ( i-1 ) + stdlib_i${ri}$amax( n-i+1, vn1( i ), 1 ) if( pvt/=i ) then - call stdlib_qswap( m, a( 1, pvt ), 1, a( 1, i ), 1 ) + call stdlib_${ri}$swap( m, a( 1, pvt ), 1, a( 1, i ), 1 ) itemp = jpvt( pvt ) jpvt( pvt ) = jpvt( i ) jpvt( i ) = itemp @@ -34142,16 +34143,16 @@ module stdlib_linalg_lapack_q end if ! generate elementary reflector h(i). if( offpi1 ) then - call stdlib_qgemv( 'NO TRANSPOSE', m-rk+1, k-1, -one, a( rk, 1 ),lda, f( k, 1 ), & + call stdlib_${ri}$gemv( 'NO TRANSPOSE', m-rk+1, k-1, -one, a( rk, 1 ),lda, f( k, 1 ), & ldf, one, a( rk, k ), 1 ) end if ! generate elementary reflector h(k). if( rk1 ) then - call stdlib_qgemv( 'TRANSPOSE', m-rk+1, k-1, -tau( k ), a( rk, 1 ),lda, a( rk, k & + call stdlib_${ri}$gemv( 'TRANSPOSE', m-rk+1, k-1, -tau( k ), a( rk, 1 ),lda, a( rk, k & ), 1, zero, auxv( 1 ), 1 ) - call stdlib_qgemv( 'NO TRANSPOSE', n, k-1, one, f( 1, 1 ), ldf,auxv( 1 ), 1, one,& + call stdlib_${ri}$gemv( 'NO TRANSPOSE', n, k-1, one, f( 1, 1 ), ldf,auxv( 1 ), 1, one,& f( 1, k ), 1 ) end if ! update the current row of a: ! a(rk,k+1:n) := a(rk,k+1:n) - a(rk,1:k)*f(k+1:n,1:k)**t. if( k0 ) then itemp = nint( vn2( lsticc ),KIND=ilp) - vn1( lsticc ) = stdlib_qnrm2( m-rk, a( rk+1, lsticc ), 1 ) + vn1( lsticc ) = stdlib_${ri}$nrm2( m-rk, a( rk+1, lsticc ), 1 ) ! note: the computation of vn1( lsticc ) relies on the fact that ! stdlib_dnrm2 does not fail on vectors with norm below the value of - ! sqrt(stdlib_qlamch('s')) + ! sqrt(stdlib_${ri}$lamch('s')) vn2( lsticc ) = vn1( lsticc ) lsticc = itemp go to 40 end if return - end subroutine stdlib_qlaqps + end subroutine stdlib_${ri}$laqps - subroutine stdlib_qlaqr0( wantt, wantz, n, ilo, ihi, h, ldh, wr, wi,iloz, ihiz, z, ldz, work,& + subroutine stdlib_${ri}$laqr0( wantt, wantz, n, ilo, ihi, h, ldh, wr, wi,iloz, ihiz, z, ldz, work,& !! DLAQR0: computes the eigenvalues of a Hessenberg matrix H !! and, optionally, the matrices T and Z from the Schur decomposition !! H = Z T Z**T, where T is an upper quasi-triangular matrix (the @@ -34333,17 +34334,17 @@ module stdlib_linalg_lapack_q integer(ilp), intent(out) :: info logical(lk), intent(in) :: wantt, wantz ! Array Arguments - real(qp), intent(inout) :: h(ldh,*), z(ldz,*) - real(qp), intent(out) :: wi(*), work(*), wr(*) + real(${rk}$), intent(inout) :: h(ldh,*), z(ldz,*) + real(${rk}$), intent(out) :: wi(*), work(*), wr(*) ! ================================================================ ! Parameters integer(ilp), parameter :: ntiny = 15 integer(ilp), parameter :: kexnw = 5 integer(ilp), parameter :: kexsh = 6 - real(qp), parameter :: wilk1 = 0.75_qp - real(qp), parameter :: wilk2 = -0.4375_qp + real(${rk}$), parameter :: wilk1 = 0.75_${rk}$ + real(${rk}$), parameter :: wilk2 = -0.4375_${rk}$ ! ==== matrices of order ntiny or smaller must be processed by - ! . stdlib_qlahqr because of insufficient subdiagonal scratch space. + ! . stdlib_${ri}$lahqr because of insufficient subdiagonal scratch space. ! . (this is a hard limit.) ==== ! ==== exceptional deflation windows: try to cure rare @@ -34359,14 +34360,14 @@ module stdlib_linalg_lapack_q ! Local Scalars - real(qp) :: aa, bb, cc, cs, dd, sn, ss, swap + real(${rk}$) :: aa, bb, cc, cs, dd, sn, ss, swap integer(ilp) :: i, inf, it, itmax, k, kacc22, kbot, kdu, ks, kt, ktop, ku, kv, kwh, & kwtop, kwv, ld, ls, lwkopt, ndec, ndfl, nh, nho, nibble, nmin, ns, nsmax, nsr, nve, nw,& nwmax, nwr, nwupbd logical(lk) :: sorted character :: jbcmpz*2 ! Local Arrays - real(qp) :: zdum(1,1) + real(${rk}$) :: zdum(1,1) ! Intrinsic Functions intrinsic :: abs,real,int,max,min,mod ! Executable Statements @@ -34377,9 +34378,9 @@ module stdlib_linalg_lapack_q return end if if( n<=ntiny ) then - ! ==== tiny matrices must use stdlib_qlahqr. ==== + ! ==== tiny matrices must use stdlib_${ri}$lahqr. ==== lwkopt = 1 - if( lwork/=-1 )call stdlib_qlahqr( wantt, wantz, n, ilo, ihi, h, ldh, wr, wi,iloz, & + if( lwork/=-1 )call stdlib_${ri}$lahqr( wantt, wantz, n, ilo, ihi, h, ldh, wr, wi,iloz, & ihiz, z, ldz, info ) else ! ==== use small bulge multi-shift qr with aggressive early @@ -34413,17 +34414,17 @@ module stdlib_linalg_lapack_q nsr = min( nsr, ( n-3 ) / 6, ihi-ilo ) nsr = max( 2, nsr-mod( nsr, 2 ) ) ! ==== estimate optimal workspace ==== - ! ==== workspace query call to stdlib_qlaqr3 ==== - call stdlib_qlaqr3( wantt, wantz, n, ilo, ihi, nwr+1, h, ldh, iloz,ihiz, z, ldz, ls,& + ! ==== workspace query call to stdlib_${ri}$laqr3 ==== + call stdlib_${ri}$laqr3( wantt, wantz, n, ilo, ihi, nwr+1, h, ldh, iloz,ihiz, z, ldz, ls,& ld, wr, wi, h, ldh, n, h, ldh,n, h, ldh, work, -1 ) - ! ==== optimal workspace = max(stdlib_qlaqr5, stdlib_qlaqr3) ==== + ! ==== optimal workspace = max(stdlib_${ri}$laqr5, stdlib_${ri}$laqr3) ==== lwkopt = max( 3*nsr / 2, int( work( 1 ),KIND=ilp) ) ! ==== quick return in case of workspace query. ==== if( lwork==-1 ) then - work( 1 ) = real( lwkopt,KIND=qp) + work( 1 ) = real( lwkopt,KIND=${rk}$) return end if - ! ==== stdlib_qlahqr/stdlib_qlaqr0 crossover point ==== + ! ==== stdlib_${ri}$lahqr/stdlib_${ri}$laqr0 crossover point ==== nmin = stdlib_ilaenv( 12, 'DLAQR0', jbcmpz, n, ilo, ihi, lwork ) nmin = max( ntiny, nmin ) ! ==== nibble crossover point ==== @@ -34512,7 +34513,7 @@ module stdlib_linalg_lapack_q kwv = nw + 2 nve = ( n-nw ) - kwv + 1 ! ==== aggressive early deflation ==== - call stdlib_qlaqr3( wantt, wantz, n, ktop, kbot, nw, h, ldh, iloz,ihiz, z, ldz, & + call stdlib_${ri}$laqr3( wantt, wantz, n, ktop, kbot, nw, h, ldh, iloz,ihiz, z, ldz, & ls, ld, wr, wi, h( kv, 1 ), ldh,nho, h( kv, kt ), ldh, nve, h( kwv, 1 ), ldh,& work, lwork ) ! ==== adjust kbot accounting for new deflations. ==== @@ -34527,7 +34528,7 @@ module stdlib_linalg_lapack_q if( ( ld==0 ) .or. ( ( 100*ld<=nw*nibble ) .and. ( kbot-ktop+1>min( nmin, nwmax )& ) ) ) then ! ==== ns = nominal number of simultaneous shifts. - ! . this may be lowered (slightly) if stdlib_qlaqr3 + ! . this may be lowered (slightly) if stdlib_${ri}$laqr3 ! . did not provide that many shifts. ==== ns = min( nsmax, nsr, max( 2, kbot-ktop ) ) ns = ns - mod( ns, 2 ) @@ -34535,7 +34536,7 @@ module stdlib_linalg_lapack_q ! . in a multiple of kexsh iterations, ! . then try exceptional shifts. ! . otherwise use shifts provided by - ! . stdlib_qlaqr3 above or from the eigenvalues + ! . stdlib_${ri}$laqr3 above or from the eigenvalues ! . of a trailing principal submatrix. ==== if( mod( ndfl, kexsh )==0 ) then ks = kbot - ns + 1 @@ -34545,7 +34546,7 @@ module stdlib_linalg_lapack_q bb = ss cc = wilk2*ss dd = aa - call stdlib_qlanv2( aa, bb, cc, dd, wr( i-1 ), wi( i-1 ),wr( i ), wi( i & + call stdlib_${ri}$lanv2( aa, bb, cc, dd, wr( i-1 ), wi( i-1 ),wr( i ), wi( i & ), cs, sn ) end do if( ks==ktop ) then @@ -34555,21 +34556,21 @@ module stdlib_linalg_lapack_q wi( ks ) = wi( ks+1 ) end if else - ! ==== got ns/2 or fewer shifts? use stdlib_qlaqr4 or - ! . stdlib_qlahqr on a trailing principal submatrix to + ! ==== got ns/2 or fewer shifts? use stdlib_${ri}$laqr4 or + ! . stdlib_${ri}$lahqr on a trailing principal submatrix to ! . get more. (since ns<=nsmax<=(n-3)/6, ! . there is enough space below the subdiagonal ! . to fit an ns-by-ns scratch array.) ==== if( kbot-ks+1<=ns / 2 ) then ks = kbot - ns + 1 kt = n - ns + 1 - call stdlib_qlacpy( 'A', ns, ns, h( ks, ks ), ldh,h( kt, 1 ), ldh ) + call stdlib_${ri}$lacpy( 'A', ns, ns, h( ks, ks ), ldh,h( kt, 1 ), ldh ) if( ns>nmin ) then - call stdlib_qlaqr4( .false., .false., ns, 1, ns,h( kt, 1 ), ldh, wr( & + call stdlib_${ri}$laqr4( .false., .false., ns, 1, ns,h( kt, 1 ), ldh, wr( & ks ),wi( ks ), 1, 1, zdum, 1, work,lwork, inf ) else - call stdlib_qlahqr( .false., .false., ns, 1, ns,h( kt, 1 ), ldh, wr( & + call stdlib_${ri}$lahqr( .false., .false., ns, 1, ns,h( kt, 1 ), ldh, wr( & ks ),wi( ks ), 1, 1, zdum, 1, inf ) end if ks = ks + inf @@ -34581,7 +34582,7 @@ module stdlib_linalg_lapack_q cc = h( kbot, kbot-1 ) bb = h( kbot-1, kbot ) dd = h( kbot, kbot ) - call stdlib_qlanv2( aa, bb, cc, dd, wr( kbot-1 ),wi( kbot-1 ), wr( & + call stdlib_${ri}$lanv2( aa, bb, cc, dd, wr( kbot-1 ),wi( kbot-1 ), wr( & kbot ),wi( kbot ), cs, sn ) ks = kbot - 1 end if @@ -34663,7 +34664,7 @@ module stdlib_linalg_lapack_q kwv = kdu + 4 nve = n - kdu - kwv + 1 ! ==== small-bulge multi-shift qr sweep ==== - call stdlib_qlaqr5( wantt, wantz, kacc22, n, ktop, kbot, ns,wr( ks ), wi( ks )& + call stdlib_${ri}$laqr5( wantt, wantz, kacc22, n, ktop, kbot, ns,wr( ks ), wi( ks )& , h, ldh, iloz, ihiz, z,ldz, work, 3, h( ku, 1 ), ldh, nve,h( kwv, 1 ), ldh, & nho, h( ku, kwh ), ldh ) end if @@ -34681,11 +34682,11 @@ module stdlib_linalg_lapack_q 90 continue end if ! ==== return the optimal value of lwork. ==== - work( 1 ) = real( lwkopt,KIND=qp) - end subroutine stdlib_qlaqr0 + work( 1 ) = real( lwkopt,KIND=${rk}$) + end subroutine stdlib_${ri}$laqr0 - pure subroutine stdlib_qlaqr1( n, h, ldh, sr1, si1, sr2, si2, v ) + pure subroutine stdlib_${ri}$laqr1( n, h, ldh, sr1, si1, sr2, si2, v ) !! Given a 2-by-2 or 3-by-3 matrix H, DLAQR1: sets v to a !! scalar multiple of the first column of the product !! (*) K = (H - (sr1 + i*si1)*I)*(H - (sr2 + i*si2)*I) @@ -34700,15 +34701,15 @@ module stdlib_linalg_lapack_q ! -- lapack is a software package provided by univ. of tennessee, -- ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments - real(qp), intent(in) :: si1, si2, sr1, sr2 + real(${rk}$), intent(in) :: si1, si2, sr1, sr2 integer(ilp), intent(in) :: ldh, n ! Array Arguments - real(qp), intent(in) :: h(ldh,*) - real(qp), intent(out) :: v(*) + real(${rk}$), intent(in) :: h(ldh,*) + real(${rk}$), intent(out) :: v(*) ! ================================================================ ! Local Scalars - real(qp) :: h21s, h31s, s + real(${rk}$) :: h21s, h31s, s ! Intrinsic Functions intrinsic :: abs ! Executable Statements @@ -34742,10 +34743,10 @@ module stdlib_linalg_lapack_q v( 3 ) = h31s*( h( 1, 1 )+h( 3, 3 )-sr1-sr2 ) +h21s*h( 3, 2 ) end if end if - end subroutine stdlib_qlaqr1 + end subroutine stdlib_${ri}$laqr1 - subroutine stdlib_qlaqr2( wantt, wantz, n, ktop, kbot, nw, h, ldh, iloz,ihiz, z, ldz, ns, nd,& + subroutine stdlib_${ri}$laqr2( wantt, wantz, n, ktop, kbot, nw, h, ldh, iloz,ihiz, z, ldz, ns, nd,& !! DLAQR2: is identical to DLAQR3 except that it avoids !! recursion by calling DLAHQR instead of DLAQR4. !! Aggressive early deflation: @@ -34767,12 +34768,12 @@ module stdlib_linalg_lapack_q integer(ilp), intent(out) :: nd, ns logical(lk), intent(in) :: wantt, wantz ! Array Arguments - real(qp), intent(inout) :: h(ldh,*), z(ldz,*) - real(qp), intent(out) :: si(*), sr(*), t(ldt,*), v(ldv,*), work(*), wv(ldwv,*) + real(${rk}$), intent(inout) :: h(ldh,*), z(ldz,*) + real(${rk}$), intent(out) :: si(*), sr(*), t(ldt,*), v(ldv,*), work(*), wv(ldwv,*) ! ================================================================ ! Local Scalars - real(qp) :: aa, bb, beta, cc, cs, dd, evi, evk, foo, s, safmax, safmin, smlnum, sn, & + real(${rk}$) :: aa, bb, beta, cc, cs, dd, evi, evk, foo, s, safmax, safmin, smlnum, sn, & tau, ulp integer(ilp) :: i, ifst, ilst, info, infqr, j, jw, k, kcol, kend, kln, krow, kwtop, & ltop, lwk1, lwk2, lwkopt @@ -34785,11 +34786,11 @@ module stdlib_linalg_lapack_q if( jw<=2 ) then lwkopt = 1 else - ! ==== workspace query call to stdlib_qgehrd ==== - call stdlib_qgehrd( jw, 1, jw-1, t, ldt, work, work, -1, info ) + ! ==== workspace query call to stdlib_${ri}$gehrd ==== + call stdlib_${ri}$gehrd( jw, 1, jw-1, t, ldt, work, work, -1, info ) lwk1 = int( work( 1 ),KIND=ilp) - ! ==== workspace query call to stdlib_qormhr ==== - call stdlib_qormhr( 'R', 'N', jw, jw, 1, jw-1, t, ldt, work, v, ldv,work, -1, info ) + ! ==== workspace query call to stdlib_${ri}$ormhr ==== + call stdlib_${ri}$ormhr( 'R', 'N', jw, jw, 1, jw-1, t, ldt, work, v, ldv,work, -1, info ) lwk2 = int( work( 1 ),KIND=ilp) ! ==== optimal workspace ==== @@ -34797,7 +34798,7 @@ module stdlib_linalg_lapack_q end if ! ==== quick return in case of workspace query. ==== if( lwork==-1 ) then - work( 1 ) = real( lwkopt,KIND=qp) + work( 1 ) = real( lwkopt,KIND=${rk}$) return end if ! ==== nothing to do ... @@ -34809,11 +34810,11 @@ module stdlib_linalg_lapack_q ! ... nor for an empty deflation window. ==== if( nw<1 )return ! ==== machine constants ==== - safmin = stdlib_qlamch( 'SAFE MINIMUM' ) + safmin = stdlib_${ri}$lamch( 'SAFE MINIMUM' ) safmax = one / safmin - call stdlib_qlabad( safmin, safmax ) - ulp = stdlib_qlamch( 'PRECISION' ) - smlnum = safmin*( real( n,KIND=qp) / ulp ) + call stdlib_${ri}$labad( safmin, safmax ) + ulp = stdlib_${ri}$lamch( 'PRECISION' ) + smlnum = safmin*( real( n,KIND=${rk}$) / ulp ) ! ==== setup deflation window ==== jw = min( nw, kbot-ktop+1 ) kwtop = kbot - jw + 1 @@ -34841,12 +34842,12 @@ module stdlib_linalg_lapack_q ! . aggressive early deflation using that part of ! . the deflation window that converged using infqr ! . here and there to keep track.) ==== - call stdlib_qlacpy( 'U', jw, jw, h( kwtop, kwtop ), ldh, t, ldt ) - call stdlib_qcopy( jw-1, h( kwtop+1, kwtop ), ldh+1, t( 2, 1 ), ldt+1 ) - call stdlib_qlaset( 'A', jw, jw, zero, one, v, ldv ) - call stdlib_qlahqr( .true., .true., jw, 1, jw, t, ldt, sr( kwtop ),si( kwtop ), 1, jw, & + call stdlib_${ri}$lacpy( 'U', jw, jw, h( kwtop, kwtop ), ldh, t, ldt ) + call stdlib_${ri}$copy( jw-1, h( kwtop+1, kwtop ), ldh+1, t( 2, 1 ), ldt+1 ) + call stdlib_${ri}$laset( 'A', jw, jw, zero, one, v, ldv ) + call stdlib_${ri}$lahqr( .true., .true., jw, 1, jw, t, ldt, sr( kwtop ),si( kwtop ), 1, jw, & v, ldv, infqr ) - ! ==== stdlib_qtrexc needs a clean margin near the diagonal ==== + ! ==== stdlib_${ri}$trexc needs a clean margin near the diagonal ==== do j = 1, jw - 3 t( j+2, j ) = zero t( j+3, j ) = zero @@ -34872,9 +34873,9 @@ module stdlib_linalg_lapack_q ns = ns - 1 else ! ==== undeflatable. move it up out of the way. - ! . (stdlib_qtrexc can not fail in this case.) ==== + ! . (stdlib_${ri}$trexc can not fail in this case.) ==== ifst = ns - call stdlib_qtrexc( 'V', jw, t, ldt, v, ldv, ifst, ilst, work,info ) + call stdlib_${ri}$trexc( 'V', jw, t, ldt, v, ldv, ifst, ilst, work,info ) ilst = ilst + 1 end if else @@ -34888,10 +34889,10 @@ module stdlib_linalg_lapack_q ns = ns - 2 else ! ==== undeflatable. move them up out of the way. - ! . fortunately, stdlib_qtrexc does the right thing with + ! . fortunately, stdlib_${ri}$trexc does the right thing with ! . ilst in case of a rare exchange failure. ==== ifst = ns - call stdlib_qtrexc( 'V', jw, t, ldt, v, ldv, ifst, ilst, work,info ) + call stdlib_${ri}$trexc( 'V', jw, t, ldt, v, ldv, ifst, ilst, work,info ) ilst = ilst + 2 end if end if @@ -34940,7 +34941,7 @@ module stdlib_linalg_lapack_q sorted = .false. ifst = i ilst = k - call stdlib_qtrexc( 'V', jw, t, ldt, v, ldv, ifst, ilst, work,info ) + call stdlib_${ri}$trexc( 'V', jw, t, ldt, v, ldv, ifst, ilst, work,info ) if( info==0 ) then i = ilst else @@ -34976,7 +34977,7 @@ module stdlib_linalg_lapack_q cc = t( i, i-1 ) bb = t( i-1, i ) dd = t( i, i ) - call stdlib_qlanv2( aa, bb, cc, dd, sr( kwtop+i-2 ),si( kwtop+i-2 ), sr( kwtop+i-& + call stdlib_${ri}$lanv2( aa, bb, cc, dd, sr( kwtop+i-2 ),si( kwtop+i-2 ), sr( kwtop+i-& 1 ),si( kwtop+i-1 ), cs, sn ) i = i - 2 end if @@ -34985,24 +34986,24 @@ module stdlib_linalg_lapack_q if( ns1 .and. s/=zero ) then ! ==== reflect spike back into lower triangle ==== - call stdlib_qcopy( ns, v, ldv, work, 1 ) + call stdlib_${ri}$copy( ns, v, ldv, work, 1 ) beta = work( 1 ) - call stdlib_qlarfg( ns, beta, work( 2 ), 1, tau ) + call stdlib_${ri}$larfg( ns, beta, work( 2 ), 1, tau ) work( 1 ) = one - call stdlib_qlaset( 'L', jw-2, jw-2, zero, zero, t( 3, 1 ), ldt ) - call stdlib_qlarf( 'L', ns, jw, work, 1, tau, t, ldt,work( jw+1 ) ) - call stdlib_qlarf( 'R', ns, ns, work, 1, tau, t, ldt,work( jw+1 ) ) - call stdlib_qlarf( 'R', jw, ns, work, 1, tau, v, ldv,work( jw+1 ) ) - call stdlib_qgehrd( jw, 1, ns, t, ldt, work, work( jw+1 ),lwork-jw, info ) + call stdlib_${ri}$laset( 'L', jw-2, jw-2, zero, zero, t( 3, 1 ), ldt ) + call stdlib_${ri}$larf( 'L', ns, jw, work, 1, tau, t, ldt,work( jw+1 ) ) + call stdlib_${ri}$larf( 'R', ns, ns, work, 1, tau, t, ldt,work( jw+1 ) ) + call stdlib_${ri}$larf( 'R', jw, ns, work, 1, tau, v, ldv,work( jw+1 ) ) + call stdlib_${ri}$gehrd( jw, 1, ns, t, ldt, work, work( jw+1 ),lwork-jw, info ) end if ! ==== copy updated reduced window into place ==== if( kwtop>1 )h( kwtop, kwtop-1 ) = s*v( 1, 1 ) - call stdlib_qlacpy( 'U', jw, jw, t, ldt, h( kwtop, kwtop ), ldh ) - call stdlib_qcopy( jw-1, t( 2, 1 ), ldt+1, h( kwtop+1, kwtop ),ldh+1 ) + call stdlib_${ri}$lacpy( 'U', jw, jw, t, ldt, h( kwtop, kwtop ), ldh ) + call stdlib_${ri}$copy( jw-1, t( 2, 1 ), ldt+1, h( kwtop+1, kwtop ),ldh+1 ) ! ==== accumulate orthogonal matrix in order update ! . h and z, if requested. ==== - if( ns>1 .and. s/=zero )call stdlib_qormhr( 'R', 'N', jw, ns, 1, ns, t, ldt, work, & + if( ns>1 .and. s/=zero )call stdlib_${ri}$ormhr( 'R', 'N', jw, ns, 1, ns, t, ldt, work, & v, ldv,work( jw+1 ), lwork-jw, info ) ! ==== update vertical slab in h ==== if( wantt ) then @@ -35012,26 +35013,26 @@ module stdlib_linalg_lapack_q end if do krow = ltop, kwtop - 1, nv kln = min( nv, kwtop-krow ) - call stdlib_qgemm( 'N', 'N', kln, jw, jw, one, h( krow, kwtop ),ldh, v, ldv, & + call stdlib_${ri}$gemm( 'N', 'N', kln, jw, jw, one, h( krow, kwtop ),ldh, v, ldv, & zero, wv, ldwv ) - call stdlib_qlacpy( 'A', kln, jw, wv, ldwv, h( krow, kwtop ), ldh ) + call stdlib_${ri}$lacpy( 'A', kln, jw, wv, ldwv, h( krow, kwtop ), ldh ) end do ! ==== update horizontal slab in h ==== if( wantt ) then do kcol = kbot + 1, n, nh kln = min( nh, n-kcol+1 ) - call stdlib_qgemm( 'C', 'N', jw, kln, jw, one, v, ldv,h( kwtop, kcol ), ldh, & + call stdlib_${ri}$gemm( 'C', 'N', jw, kln, jw, one, v, ldv,h( kwtop, kcol ), ldh, & zero, t, ldt ) - call stdlib_qlacpy( 'A', jw, kln, t, ldt, h( kwtop, kcol ),ldh ) + call stdlib_${ri}$lacpy( 'A', jw, kln, t, ldt, h( kwtop, kcol ),ldh ) end do end if ! ==== update vertical slab in z ==== if( wantz ) then do krow = iloz, ihiz, nv kln = min( nv, ihiz-krow+1 ) - call stdlib_qgemm( 'N', 'N', kln, jw, jw, one, z( krow, kwtop ),ldz, v, ldv, & + call stdlib_${ri}$gemm( 'N', 'N', kln, jw, jw, one, z( krow, kwtop ),ldz, v, ldv, & zero, wv, ldwv ) - call stdlib_qlacpy( 'A', kln, jw, wv, ldwv, z( krow, kwtop ),ldz ) + call stdlib_${ri}$lacpy( 'A', kln, jw, wv, ldwv, z( krow, kwtop ),ldz ) end do end if end if @@ -35044,11 +35045,11 @@ module stdlib_linalg_lapack_q ! . window.) ==== ns = ns - infqr ! ==== return optimal workspace. ==== - work( 1 ) = real( lwkopt,KIND=qp) - end subroutine stdlib_qlaqr2 + work( 1 ) = real( lwkopt,KIND=${rk}$) + end subroutine stdlib_${ri}$laqr2 - subroutine stdlib_qlaqr3( wantt, wantz, n, ktop, kbot, nw, h, ldh, iloz,ihiz, z, ldz, ns, nd,& + subroutine stdlib_${ri}$laqr3( wantt, wantz, n, ktop, kbot, nw, h, ldh, iloz,ihiz, z, ldz, ns, nd,& !! Aggressive early deflation: !! DLAQR3: accepts as input an upper Hessenberg matrix !! H and performs an orthogonal similarity transformation @@ -35068,12 +35069,12 @@ module stdlib_linalg_lapack_q integer(ilp), intent(out) :: nd, ns logical(lk), intent(in) :: wantt, wantz ! Array Arguments - real(qp), intent(inout) :: h(ldh,*), z(ldz,*) - real(qp), intent(out) :: si(*), sr(*), t(ldt,*), v(ldv,*), work(*), wv(ldwv,*) + real(${rk}$), intent(inout) :: h(ldh,*), z(ldz,*) + real(${rk}$), intent(out) :: si(*), sr(*), t(ldt,*), v(ldv,*), work(*), wv(ldwv,*) ! ================================================================ ! Local Scalars - real(qp) :: aa, bb, beta, cc, cs, dd, evi, evk, foo, s, safmax, safmin, smlnum, sn, & + real(${rk}$) :: aa, bb, beta, cc, cs, dd, evi, evk, foo, s, safmax, safmin, smlnum, sn, & tau, ulp integer(ilp) :: i, ifst, ilst, info, infqr, j, jw, k, kcol, kend, kln, krow, kwtop, & ltop, lwk1, lwk2, lwk3, lwkopt, nmin @@ -35086,15 +35087,15 @@ module stdlib_linalg_lapack_q if( jw<=2 ) then lwkopt = 1 else - ! ==== workspace query call to stdlib_qgehrd ==== - call stdlib_qgehrd( jw, 1, jw-1, t, ldt, work, work, -1, info ) + ! ==== workspace query call to stdlib_${ri}$gehrd ==== + call stdlib_${ri}$gehrd( jw, 1, jw-1, t, ldt, work, work, -1, info ) lwk1 = int( work( 1 ),KIND=ilp) - ! ==== workspace query call to stdlib_qormhr ==== - call stdlib_qormhr( 'R', 'N', jw, jw, 1, jw-1, t, ldt, work, v, ldv,work, -1, info ) + ! ==== workspace query call to stdlib_${ri}$ormhr ==== + call stdlib_${ri}$ormhr( 'R', 'N', jw, jw, 1, jw-1, t, ldt, work, v, ldv,work, -1, info ) lwk2 = int( work( 1 ),KIND=ilp) - ! ==== workspace query call to stdlib_qlaqr4 ==== - call stdlib_qlaqr4( .true., .true., jw, 1, jw, t, ldt, sr, si, 1, jw,v, ldv, work, -& + ! ==== workspace query call to stdlib_${ri}$laqr4 ==== + call stdlib_${ri}$laqr4( .true., .true., jw, 1, jw, t, ldt, sr, si, 1, jw,v, ldv, work, -& 1, infqr ) lwk3 = int( work( 1 ),KIND=ilp) ! ==== optimal workspace ==== @@ -35102,7 +35103,7 @@ module stdlib_linalg_lapack_q end if ! ==== quick return in case of workspace query. ==== if( lwork==-1 ) then - work( 1 ) = real( lwkopt,KIND=qp) + work( 1 ) = real( lwkopt,KIND=${rk}$) return end if ! ==== nothing to do ... @@ -35114,11 +35115,11 @@ module stdlib_linalg_lapack_q ! ... nor for an empty deflation window. ==== if( nw<1 )return ! ==== machine constants ==== - safmin = stdlib_qlamch( 'SAFE MINIMUM' ) + safmin = stdlib_${ri}$lamch( 'SAFE MINIMUM' ) safmax = one / safmin - call stdlib_qlabad( safmin, safmax ) - ulp = stdlib_qlamch( 'PRECISION' ) - smlnum = safmin*( real( n,KIND=qp) / ulp ) + call stdlib_${ri}$labad( safmin, safmax ) + ulp = stdlib_${ri}$lamch( 'PRECISION' ) + smlnum = safmin*( real( n,KIND=${rk}$) / ulp ) ! ==== setup deflation window ==== jw = min( nw, kbot-ktop+1 ) kwtop = kbot - jw + 1 @@ -35146,18 +35147,18 @@ module stdlib_linalg_lapack_q ! . aggressive early deflation using that part of ! . the deflation window that converged using infqr ! . here and there to keep track.) ==== - call stdlib_qlacpy( 'U', jw, jw, h( kwtop, kwtop ), ldh, t, ldt ) - call stdlib_qcopy( jw-1, h( kwtop+1, kwtop ), ldh+1, t( 2, 1 ), ldt+1 ) - call stdlib_qlaset( 'A', jw, jw, zero, one, v, ldv ) + call stdlib_${ri}$lacpy( 'U', jw, jw, h( kwtop, kwtop ), ldh, t, ldt ) + call stdlib_${ri}$copy( jw-1, h( kwtop+1, kwtop ), ldh+1, t( 2, 1 ), ldt+1 ) + call stdlib_${ri}$laset( 'A', jw, jw, zero, one, v, ldv ) nmin = stdlib_ilaenv( 12, 'DLAQR3', 'SV', jw, 1, jw, lwork ) if( jw>nmin ) then - call stdlib_qlaqr4( .true., .true., jw, 1, jw, t, ldt, sr( kwtop ),si( kwtop ), 1, & + call stdlib_${ri}$laqr4( .true., .true., jw, 1, jw, t, ldt, sr( kwtop ),si( kwtop ), 1, & jw, v, ldv, work, lwork, infqr ) else - call stdlib_qlahqr( .true., .true., jw, 1, jw, t, ldt, sr( kwtop ),si( kwtop ), 1, & + call stdlib_${ri}$lahqr( .true., .true., jw, 1, jw, t, ldt, sr( kwtop ),si( kwtop ), 1, & jw, v, ldv, infqr ) end if - ! ==== stdlib_qtrexc needs a clean margin near the diagonal ==== + ! ==== stdlib_${ri}$trexc needs a clean margin near the diagonal ==== do j = 1, jw - 3 t( j+2, j ) = zero t( j+3, j ) = zero @@ -35183,9 +35184,9 @@ module stdlib_linalg_lapack_q ns = ns - 1 else ! ==== undeflatable. move it up out of the way. - ! . (stdlib_qtrexc can not fail in this case.) ==== + ! . (stdlib_${ri}$trexc can not fail in this case.) ==== ifst = ns - call stdlib_qtrexc( 'V', jw, t, ldt, v, ldv, ifst, ilst, work,info ) + call stdlib_${ri}$trexc( 'V', jw, t, ldt, v, ldv, ifst, ilst, work,info ) ilst = ilst + 1 end if else @@ -35199,10 +35200,10 @@ module stdlib_linalg_lapack_q ns = ns - 2 else ! ==== undeflatable. move them up out of the way. - ! . fortunately, stdlib_qtrexc does the right thing with + ! . fortunately, stdlib_${ri}$trexc does the right thing with ! . ilst in case of a rare exchange failure. ==== ifst = ns - call stdlib_qtrexc( 'V', jw, t, ldt, v, ldv, ifst, ilst, work,info ) + call stdlib_${ri}$trexc( 'V', jw, t, ldt, v, ldv, ifst, ilst, work,info ) ilst = ilst + 2 end if end if @@ -35251,7 +35252,7 @@ module stdlib_linalg_lapack_q sorted = .false. ifst = i ilst = k - call stdlib_qtrexc( 'V', jw, t, ldt, v, ldv, ifst, ilst, work,info ) + call stdlib_${ri}$trexc( 'V', jw, t, ldt, v, ldv, ifst, ilst, work,info ) if( info==0 ) then i = ilst else @@ -35287,7 +35288,7 @@ module stdlib_linalg_lapack_q cc = t( i, i-1 ) bb = t( i-1, i ) dd = t( i, i ) - call stdlib_qlanv2( aa, bb, cc, dd, sr( kwtop+i-2 ),si( kwtop+i-2 ), sr( kwtop+i-& + call stdlib_${ri}$lanv2( aa, bb, cc, dd, sr( kwtop+i-2 ),si( kwtop+i-2 ), sr( kwtop+i-& 1 ),si( kwtop+i-1 ), cs, sn ) i = i - 2 end if @@ -35296,24 +35297,24 @@ module stdlib_linalg_lapack_q if( ns1 .and. s/=zero ) then ! ==== reflect spike back into lower triangle ==== - call stdlib_qcopy( ns, v, ldv, work, 1 ) + call stdlib_${ri}$copy( ns, v, ldv, work, 1 ) beta = work( 1 ) - call stdlib_qlarfg( ns, beta, work( 2 ), 1, tau ) + call stdlib_${ri}$larfg( ns, beta, work( 2 ), 1, tau ) work( 1 ) = one - call stdlib_qlaset( 'L', jw-2, jw-2, zero, zero, t( 3, 1 ), ldt ) - call stdlib_qlarf( 'L', ns, jw, work, 1, tau, t, ldt,work( jw+1 ) ) - call stdlib_qlarf( 'R', ns, ns, work, 1, tau, t, ldt,work( jw+1 ) ) - call stdlib_qlarf( 'R', jw, ns, work, 1, tau, v, ldv,work( jw+1 ) ) - call stdlib_qgehrd( jw, 1, ns, t, ldt, work, work( jw+1 ),lwork-jw, info ) + call stdlib_${ri}$laset( 'L', jw-2, jw-2, zero, zero, t( 3, 1 ), ldt ) + call stdlib_${ri}$larf( 'L', ns, jw, work, 1, tau, t, ldt,work( jw+1 ) ) + call stdlib_${ri}$larf( 'R', ns, ns, work, 1, tau, t, ldt,work( jw+1 ) ) + call stdlib_${ri}$larf( 'R', jw, ns, work, 1, tau, v, ldv,work( jw+1 ) ) + call stdlib_${ri}$gehrd( jw, 1, ns, t, ldt, work, work( jw+1 ),lwork-jw, info ) end if ! ==== copy updated reduced window into place ==== if( kwtop>1 )h( kwtop, kwtop-1 ) = s*v( 1, 1 ) - call stdlib_qlacpy( 'U', jw, jw, t, ldt, h( kwtop, kwtop ), ldh ) - call stdlib_qcopy( jw-1, t( 2, 1 ), ldt+1, h( kwtop+1, kwtop ),ldh+1 ) + call stdlib_${ri}$lacpy( 'U', jw, jw, t, ldt, h( kwtop, kwtop ), ldh ) + call stdlib_${ri}$copy( jw-1, t( 2, 1 ), ldt+1, h( kwtop+1, kwtop ),ldh+1 ) ! ==== accumulate orthogonal matrix in order update ! . h and z, if requested. ==== - if( ns>1 .and. s/=zero )call stdlib_qormhr( 'R', 'N', jw, ns, 1, ns, t, ldt, work, & + if( ns>1 .and. s/=zero )call stdlib_${ri}$ormhr( 'R', 'N', jw, ns, 1, ns, t, ldt, work, & v, ldv,work( jw+1 ), lwork-jw, info ) ! ==== update vertical slab in h ==== if( wantt ) then @@ -35323,26 +35324,26 @@ module stdlib_linalg_lapack_q end if do krow = ltop, kwtop - 1, nv kln = min( nv, kwtop-krow ) - call stdlib_qgemm( 'N', 'N', kln, jw, jw, one, h( krow, kwtop ),ldh, v, ldv, & + call stdlib_${ri}$gemm( 'N', 'N', kln, jw, jw, one, h( krow, kwtop ),ldh, v, ldv, & zero, wv, ldwv ) - call stdlib_qlacpy( 'A', kln, jw, wv, ldwv, h( krow, kwtop ), ldh ) + call stdlib_${ri}$lacpy( 'A', kln, jw, wv, ldwv, h( krow, kwtop ), ldh ) end do ! ==== update horizontal slab in h ==== if( wantt ) then do kcol = kbot + 1, n, nh kln = min( nh, n-kcol+1 ) - call stdlib_qgemm( 'C', 'N', jw, kln, jw, one, v, ldv,h( kwtop, kcol ), ldh, & + call stdlib_${ri}$gemm( 'C', 'N', jw, kln, jw, one, v, ldv,h( kwtop, kcol ), ldh, & zero, t, ldt ) - call stdlib_qlacpy( 'A', jw, kln, t, ldt, h( kwtop, kcol ),ldh ) + call stdlib_${ri}$lacpy( 'A', jw, kln, t, ldt, h( kwtop, kcol ),ldh ) end do end if ! ==== update vertical slab in z ==== if( wantz ) then do krow = iloz, ihiz, nv kln = min( nv, ihiz-krow+1 ) - call stdlib_qgemm( 'N', 'N', kln, jw, jw, one, z( krow, kwtop ),ldz, v, ldv, & + call stdlib_${ri}$gemm( 'N', 'N', kln, jw, jw, one, z( krow, kwtop ),ldz, v, ldv, & zero, wv, ldwv ) - call stdlib_qlacpy( 'A', kln, jw, wv, ldwv, z( krow, kwtop ),ldz ) + call stdlib_${ri}$lacpy( 'A', kln, jw, wv, ldwv, z( krow, kwtop ),ldz ) end do end if end if @@ -35355,11 +35356,11 @@ module stdlib_linalg_lapack_q ! . window.) ==== ns = ns - infqr ! ==== return optimal workspace. ==== - work( 1 ) = real( lwkopt,KIND=qp) - end subroutine stdlib_qlaqr3 + work( 1 ) = real( lwkopt,KIND=${rk}$) + end subroutine stdlib_${ri}$laqr3 - subroutine stdlib_qlaqr4( wantt, wantz, n, ilo, ihi, h, ldh, wr, wi,iloz, ihiz, z, ldz, work,& + subroutine stdlib_${ri}$laqr4( wantt, wantz, n, ilo, ihi, h, ldh, wr, wi,iloz, ihiz, z, ldz, work,& !! DLAQR4: implements one level of recursion for DLAQR0. !! It is a complete implementation of the small bulge multi-shift !! QR algorithm. It may be called by DLAQR0 and, for large enough @@ -35383,17 +35384,17 @@ module stdlib_linalg_lapack_q integer(ilp), intent(out) :: info logical(lk), intent(in) :: wantt, wantz ! Array Arguments - real(qp), intent(inout) :: h(ldh,*), z(ldz,*) - real(qp), intent(out) :: wi(*), work(*), wr(*) + real(${rk}$), intent(inout) :: h(ldh,*), z(ldz,*) + real(${rk}$), intent(out) :: wi(*), work(*), wr(*) ! ================================================================ ! Parameters integer(ilp), parameter :: ntiny = 15 integer(ilp), parameter :: kexnw = 5 integer(ilp), parameter :: kexsh = 6 - real(qp), parameter :: wilk1 = 0.75_qp - real(qp), parameter :: wilk2 = -0.4375_qp + real(${rk}$), parameter :: wilk1 = 0.75_${rk}$ + real(${rk}$), parameter :: wilk2 = -0.4375_${rk}$ ! ==== matrices of order ntiny or smaller must be processed by - ! . stdlib_qlahqr because of insufficient subdiagonal scratch space. + ! . stdlib_${ri}$lahqr because of insufficient subdiagonal scratch space. ! . (this is a hard limit.) ==== ! ==== exceptional deflation windows: try to cure rare @@ -35409,14 +35410,14 @@ module stdlib_linalg_lapack_q ! Local Scalars - real(qp) :: aa, bb, cc, cs, dd, sn, ss, swap + real(${rk}$) :: aa, bb, cc, cs, dd, sn, ss, swap integer(ilp) :: i, inf, it, itmax, k, kacc22, kbot, kdu, ks, kt, ktop, ku, kv, kwh, & kwtop, kwv, ld, ls, lwkopt, ndec, ndfl, nh, nho, nibble, nmin, ns, nsmax, nsr, nve, nw,& nwmax, nwr, nwupbd logical(lk) :: sorted character :: jbcmpz*2 ! Local Arrays - real(qp) :: zdum(1,1) + real(${rk}$) :: zdum(1,1) ! Intrinsic Functions intrinsic :: abs,real,int,max,min,mod ! Executable Statements @@ -35427,9 +35428,9 @@ module stdlib_linalg_lapack_q return end if if( n<=ntiny ) then - ! ==== tiny matrices must use stdlib_qlahqr. ==== + ! ==== tiny matrices must use stdlib_${ri}$lahqr. ==== lwkopt = 1 - if( lwork/=-1 )call stdlib_qlahqr( wantt, wantz, n, ilo, ihi, h, ldh, wr, wi,iloz, & + if( lwork/=-1 )call stdlib_${ri}$lahqr( wantt, wantz, n, ilo, ihi, h, ldh, wr, wi,iloz, & ihiz, z, ldz, info ) else ! ==== use small bulge multi-shift qr with aggressive early @@ -35463,17 +35464,17 @@ module stdlib_linalg_lapack_q nsr = min( nsr, ( n-3 ) / 6, ihi-ilo ) nsr = max( 2, nsr-mod( nsr, 2 ) ) ! ==== estimate optimal workspace ==== - ! ==== workspace query call to stdlib_qlaqr2 ==== - call stdlib_qlaqr2( wantt, wantz, n, ilo, ihi, nwr+1, h, ldh, iloz,ihiz, z, ldz, ls,& + ! ==== workspace query call to stdlib_${ri}$laqr2 ==== + call stdlib_${ri}$laqr2( wantt, wantz, n, ilo, ihi, nwr+1, h, ldh, iloz,ihiz, z, ldz, ls,& ld, wr, wi, h, ldh, n, h, ldh,n, h, ldh, work, -1 ) - ! ==== optimal workspace = max(stdlib_qlaqr5, stdlib_qlaqr2) ==== + ! ==== optimal workspace = max(stdlib_${ri}$laqr5, stdlib_${ri}$laqr2) ==== lwkopt = max( 3*nsr / 2, int( work( 1 ),KIND=ilp) ) ! ==== quick return in case of workspace query. ==== if( lwork==-1 ) then - work( 1 ) = real( lwkopt,KIND=qp) + work( 1 ) = real( lwkopt,KIND=${rk}$) return end if - ! ==== stdlib_qlahqr/stdlib_qlaqr0 crossover point ==== + ! ==== stdlib_${ri}$lahqr/stdlib_${ri}$laqr0 crossover point ==== nmin = stdlib_ilaenv( 12, 'DLAQR4', jbcmpz, n, ilo, ihi, lwork ) nmin = max( ntiny, nmin ) ! ==== nibble crossover point ==== @@ -35562,7 +35563,7 @@ module stdlib_linalg_lapack_q kwv = nw + 2 nve = ( n-nw ) - kwv + 1 ! ==== aggressive early deflation ==== - call stdlib_qlaqr2( wantt, wantz, n, ktop, kbot, nw, h, ldh, iloz,ihiz, z, ldz, & + call stdlib_${ri}$laqr2( wantt, wantz, n, ktop, kbot, nw, h, ldh, iloz,ihiz, z, ldz, & ls, ld, wr, wi, h( kv, 1 ), ldh,nho, h( kv, kt ), ldh, nve, h( kwv, 1 ), ldh,& work, lwork ) ! ==== adjust kbot accounting for new deflations. ==== @@ -35577,7 +35578,7 @@ module stdlib_linalg_lapack_q if( ( ld==0 ) .or. ( ( 100*ld<=nw*nibble ) .and. ( kbot-ktop+1>min( nmin, nwmax )& ) ) ) then ! ==== ns = nominal number of simultaneous shifts. - ! . this may be lowered (slightly) if stdlib_qlaqr2 + ! . this may be lowered (slightly) if stdlib_${ri}$laqr2 ! . did not provide that many shifts. ==== ns = min( nsmax, nsr, max( 2, kbot-ktop ) ) ns = ns - mod( ns, 2 ) @@ -35585,7 +35586,7 @@ module stdlib_linalg_lapack_q ! . in a multiple of kexsh iterations, ! . then try exceptional shifts. ! . otherwise use shifts provided by - ! . stdlib_qlaqr2 above or from the eigenvalues + ! . stdlib_${ri}$laqr2 above or from the eigenvalues ! . of a trailing principal submatrix. ==== if( mod( ndfl, kexsh )==0 ) then ks = kbot - ns + 1 @@ -35595,7 +35596,7 @@ module stdlib_linalg_lapack_q bb = ss cc = wilk2*ss dd = aa - call stdlib_qlanv2( aa, bb, cc, dd, wr( i-1 ), wi( i-1 ),wr( i ), wi( i & + call stdlib_${ri}$lanv2( aa, bb, cc, dd, wr( i-1 ), wi( i-1 ),wr( i ), wi( i & ), cs, sn ) end do if( ks==ktop ) then @@ -35605,7 +35606,7 @@ module stdlib_linalg_lapack_q wi( ks ) = wi( ks+1 ) end if else - ! ==== got ns/2 or fewer shifts? use stdlib_qlahqr + ! ==== got ns/2 or fewer shifts? use stdlib_${ri}$lahqr ! . on a trailing principal submatrix to ! . get more. (since ns<=nsmax<=(n-3)/6, ! . there is enough space below the subdiagonal @@ -35613,9 +35614,9 @@ module stdlib_linalg_lapack_q if( kbot-ks+1<=ns / 2 ) then ks = kbot - ns + 1 kt = n - ns + 1 - call stdlib_qlacpy( 'A', ns, ns, h( ks, ks ), ldh,h( kt, 1 ), ldh ) + call stdlib_${ri}$lacpy( 'A', ns, ns, h( ks, ks ), ldh,h( kt, 1 ), ldh ) - call stdlib_qlahqr( .false., .false., ns, 1, ns,h( kt, 1 ), ldh, wr( ks & + call stdlib_${ri}$lahqr( .false., .false., ns, 1, ns,h( kt, 1 ), ldh, wr( ks & ), wi( ks ),1, 1, zdum, 1, inf ) ks = ks + inf ! ==== in case of a rare qr failure use @@ -35626,7 +35627,7 @@ module stdlib_linalg_lapack_q cc = h( kbot, kbot-1 ) bb = h( kbot-1, kbot ) dd = h( kbot, kbot ) - call stdlib_qlanv2( aa, bb, cc, dd, wr( kbot-1 ),wi( kbot-1 ), wr( & + call stdlib_${ri}$lanv2( aa, bb, cc, dd, wr( kbot-1 ),wi( kbot-1 ), wr( & kbot ),wi( kbot ), cs, sn ) ks = kbot - 1 end if @@ -35708,7 +35709,7 @@ module stdlib_linalg_lapack_q kwv = kdu + 4 nve = n - kdu - kwv + 1 ! ==== small-bulge multi-shift qr sweep ==== - call stdlib_qlaqr5( wantt, wantz, kacc22, n, ktop, kbot, ns,wr( ks ), wi( ks )& + call stdlib_${ri}$laqr5( wantt, wantz, kacc22, n, ktop, kbot, ns,wr( ks ), wi( ks )& , h, ldh, iloz, ihiz, z,ldz, work, 3, h( ku, 1 ), ldh, nve,h( kwv, 1 ), ldh, & nho, h( ku, kwh ), ldh ) end if @@ -35726,11 +35727,11 @@ module stdlib_linalg_lapack_q 90 continue end if ! ==== return the optimal value of lwork. ==== - work( 1 ) = real( lwkopt,KIND=qp) - end subroutine stdlib_qlaqr4 + work( 1 ) = real( lwkopt,KIND=${rk}$) + end subroutine stdlib_${ri}$laqr4 - pure subroutine stdlib_qlaqr5( wantt, wantz, kacc22, n, ktop, kbot, nshfts,sr, si, h, ldh, & + pure subroutine stdlib_${ri}$laqr5( wantt, wantz, kacc22, n, ktop, kbot, nshfts,sr, si, h, ldh, & !! DLAQR5:, called by DLAQR0, performs a !! single small-bulge multi-shift QR sweep. iloz, ihiz, z, ldz, v, ldv, u,ldu, nv, wv, ldwv, nh, wh, ldwh ) @@ -35742,12 +35743,12 @@ module stdlib_linalg_lapack_q ldz, n, nh, nshfts, nv logical(lk), intent(in) :: wantt, wantz ! Array Arguments - real(qp), intent(inout) :: h(ldh,*), si(*), sr(*), z(ldz,*) - real(qp), intent(out) :: u(ldu,*), v(ldv,*), wh(ldwh,*), wv(ldwv,*) + real(${rk}$), intent(inout) :: h(ldh,*), si(*), sr(*), z(ldz,*) + real(${rk}$), intent(out) :: u(ldu,*), v(ldv,*), wh(ldwh,*), wv(ldwv,*) ! ================================================================ ! Local Scalars - real(qp) :: alpha, beta, h11, h12, h21, h22, refsum, safmax, safmin, scl, smlnum, swap,& + real(${rk}$) :: alpha, beta, h11, h12, h21, h22, refsum, safmax, safmin, scl, smlnum, swap,& tst1, tst2, ulp integer(ilp) :: i, i2, i4, incol, j, jbot, jcol, jlen, jrow, jtop, k, k1, kdu, kms, & krcol, m, m22, mbot, mtop, nbmps, ndcol, ns, nu @@ -35755,7 +35756,7 @@ module stdlib_linalg_lapack_q ! Intrinsic Functions intrinsic :: abs,real,max,min,mod ! Local Arrays - real(qp) :: vt(3) + real(${rk}$) :: vt(3) ! Executable Statements ! ==== if there are no shifts, then there is nothing to do. ==== if( nshfts<2 )return @@ -35784,11 +35785,11 @@ module stdlib_linalg_lapack_q ! . the remaining shifts are paired. ==== ns = nshfts - mod( nshfts, 2 ) ! ==== machine constants for deflation ==== - safmin = stdlib_qlamch( 'SAFE MINIMUM' ) + safmin = stdlib_${ri}$lamch( 'SAFE MINIMUM' ) safmax = one / safmin - call stdlib_qlabad( safmin, safmax ) - ulp = stdlib_qlamch( 'PRECISION' ) - smlnum = safmin*( real( n,KIND=qp) / ulp ) + call stdlib_${ri}$labad( safmin, safmax ) + ulp = stdlib_${ri}$lamch( 'PRECISION' ) + smlnum = safmin*( real( n,KIND=${rk}$) / ulp ) ! ==== use accumulated reflections to update far-from-diagonal ! . entries ? ==== accum = ( kacc22==1 ) .or. ( kacc22==2 ) @@ -35809,7 +35810,7 @@ module stdlib_linalg_lapack_q jtop = ktop end if ndcol = incol + kdu - if( accum )call stdlib_qlaset( 'ALL', kdu, kdu, zero, one, u, ldu ) + if( accum )call stdlib_${ri}$laset( 'ALL', kdu, kdu, zero, one, u, ldu ) ! ==== near-the-diagonal bulge chase. the following loop ! . performs the near-the-diagonal part of a small bulge ! . multi-shift qr sweep. each 4*nbmps column diagonal @@ -35839,14 +35840,14 @@ module stdlib_linalg_lapack_q ! . separately ==== k = krcol + 2*( m22-1 ) if( k==ktop-1 ) then - call stdlib_qlaqr1( 2, h( k+1, k+1 ), ldh, sr( 2*m22-1 ),si( 2*m22-1 ), sr(& + call stdlib_${ri}$laqr1( 2, h( k+1, k+1 ), ldh, sr( 2*m22-1 ),si( 2*m22-1 ), sr(& 2*m22 ), si( 2*m22 ),v( 1, m22 ) ) beta = v( 1, m22 ) - call stdlib_qlarfg( 2, beta, v( 2, m22 ), 1, v( 1, m22 ) ) + call stdlib_${ri}$larfg( 2, beta, v( 2, m22 ), 1, v( 1, m22 ) ) else beta = h( k+1, k ) v( 2, m22 ) = h( k+2, k ) - call stdlib_qlarfg( 2, beta, v( 2, m22 ), 1, v( 1, m22 ) ) + call stdlib_${ri}$larfg( 2, beta, v( 2, m22 ), 1, v( 1, m22 ) ) h( k+1, k ) = beta h( k+2, k ) = zero end if @@ -35926,10 +35927,10 @@ module stdlib_linalg_lapack_q loop_80: do m = mbot, mtop, -1 k = krcol + 2*( m-1 ) if( k==ktop-1 ) then - call stdlib_qlaqr1( 3, h( ktop, ktop ), ldh, sr( 2*m-1 ),si( 2*m-1 ), sr( & + call stdlib_${ri}$laqr1( 3, h( ktop, ktop ), ldh, sr( 2*m-1 ),si( 2*m-1 ), sr( & 2*m ), si( 2*m ),v( 1, m ) ) alpha = v( 1, m ) - call stdlib_qlarfg( 3, alpha, v( 2, m ), 1, v( 1, m ) ) + call stdlib_${ri}$larfg( 3, alpha, v( 2, m ), 1, v( 1, m ) ) else ! ==== perform delayed transformation of row below ! . mth bulge. exploit fact that first two elements @@ -35943,7 +35944,7 @@ module stdlib_linalg_lapack_q beta = h( k+1, k ) v( 2, m ) = h( k+2, k ) v( 3, m ) = h( k+3, k ) - call stdlib_qlarfg( 3, beta, v( 2, m ), 1, v( 1, m ) ) + call stdlib_${ri}$larfg( 3, beta, v( 2, m ), 1, v( 1, m ) ) ! ==== a bulge may collapse because of vigilant ! . deflation or destructive underflow. in the ! . underflow case, try the two-small-subdiagonals @@ -35960,10 +35961,10 @@ module stdlib_linalg_lapack_q ! . if the fill resulting from the new ! . reflector is too large, then abandon it. ! . otherwise, use the new one. ==== - call stdlib_qlaqr1( 3, h( k+1, k+1 ), ldh, sr( 2*m-1 ),si( 2*m-1 ), sr( & + call stdlib_${ri}$laqr1( 3, h( k+1, k+1 ), ldh, sr( 2*m-1 ),si( 2*m-1 ), sr( & 2*m ), si( 2*m ),vt ) alpha = vt( 1 ) - call stdlib_qlarfg( 3, alpha, vt( 2 ), 1, vt( 1 ) ) + call stdlib_${ri}$larfg( 3, alpha, vt( 2 ), 1, vt( 1 ) ) refsum = vt( 1 )*( h( k+1, k )+vt( 2 )*h( k+2, k ) ) if( abs( h( k+2, k )-refsum*vt( 2 ) )+abs( refsum*vt( 3 ) )>ulp*( abs( & h( k, k ) )+abs( h( k+1,k+1 ) )+abs( h( k+2, k+2 ) ) ) ) then @@ -36109,35 +36110,35 @@ module stdlib_linalg_lapack_q ! ==== horizontal multiply ==== do jcol = min( ndcol, kbot ) + 1, jbot, nh jlen = min( nh, jbot-jcol+1 ) - call stdlib_qgemm( 'C', 'N', nu, jlen, nu, one, u( k1, k1 ),ldu, h( incol+k1, & + call stdlib_${ri}$gemm( 'C', 'N', nu, jlen, nu, one, u( k1, k1 ),ldu, h( incol+k1, & jcol ), ldh, zero, wh,ldwh ) - call stdlib_qlacpy( 'ALL', nu, jlen, wh, ldwh,h( incol+k1, jcol ), ldh ) + call stdlib_${ri}$lacpy( 'ALL', nu, jlen, wh, ldwh,h( incol+k1, jcol ), ldh ) end do ! ==== vertical multiply ==== do jrow = jtop, max( ktop, incol ) - 1, nv jlen = min( nv, max( ktop, incol )-jrow ) - call stdlib_qgemm( 'N', 'N', jlen, nu, nu, one,h( jrow, incol+k1 ), ldh, u( & + call stdlib_${ri}$gemm( 'N', 'N', jlen, nu, nu, one,h( jrow, incol+k1 ), ldh, u( & k1, k1 ),ldu, zero, wv, ldwv ) - call stdlib_qlacpy( 'ALL', jlen, nu, wv, ldwv,h( jrow, incol+k1 ), ldh ) + call stdlib_${ri}$lacpy( 'ALL', jlen, nu, wv, ldwv,h( jrow, incol+k1 ), ldh ) end do ! ==== z multiply (also vertical) ==== if( wantz ) then do jrow = iloz, ihiz, nv jlen = min( nv, ihiz-jrow+1 ) - call stdlib_qgemm( 'N', 'N', jlen, nu, nu, one,z( jrow, incol+k1 ), ldz, u(& + call stdlib_${ri}$gemm( 'N', 'N', jlen, nu, nu, one,z( jrow, incol+k1 ), ldz, u(& k1, k1 ),ldu, zero, wv, ldwv ) - call stdlib_qlacpy( 'ALL', jlen, nu, wv, ldwv,z( jrow, incol+k1 ), ldz ) + call stdlib_${ri}$lacpy( 'ALL', jlen, nu, wv, ldwv,z( jrow, incol+k1 ), ldz ) end do end if end if end do loop_180 - end subroutine stdlib_qlaqr5 + end subroutine stdlib_${ri}$laqr5 - pure subroutine stdlib_qlaqsb( uplo, n, kd, ab, ldab, s, scond, amax, equed ) + pure subroutine stdlib_${ri}$laqsb( uplo, n, kd, ab, ldab, s, scond, amax, equed ) !! DLAQSB: equilibrates a symmetric band matrix A using the scaling !! factors in the vector S. ! -- lapack auxiliary routine -- @@ -36147,17 +36148,17 @@ module stdlib_linalg_lapack_q character, intent(out) :: equed character, intent(in) :: uplo integer(ilp), intent(in) :: kd, ldab, n - real(qp), intent(in) :: amax, scond + real(${rk}$), intent(in) :: amax, scond ! Array Arguments - real(qp), intent(inout) :: ab(ldab,*) - real(qp), intent(in) :: s(*) + real(${rk}$), intent(inout) :: ab(ldab,*) + real(${rk}$), intent(in) :: s(*) ! ===================================================================== ! Parameters - real(qp), parameter :: thresh = 0.1e+0_qp + real(${rk}$), parameter :: thresh = 0.1e+0_${rk}$ ! Local Scalars integer(ilp) :: i, j - real(qp) :: cj, large, small + real(${rk}$) :: cj, large, small ! Intrinsic Functions intrinsic :: max,min ! Executable Statements @@ -36167,7 +36168,7 @@ module stdlib_linalg_lapack_q return end if ! initialize large and small. - small = stdlib_qlamch( 'SAFE MINIMUM' ) / stdlib_qlamch( 'PRECISION' ) + small = stdlib_${ri}$lamch( 'SAFE MINIMUM' ) / stdlib_${ri}$lamch( 'PRECISION' ) large = one / small if( scond>=thresh .and. amax>=small .and. amax<=large ) then ! no equilibration @@ -36194,10 +36195,10 @@ module stdlib_linalg_lapack_q equed = 'Y' end if return - end subroutine stdlib_qlaqsb + end subroutine stdlib_${ri}$laqsb - pure subroutine stdlib_qlaqsp( uplo, n, ap, s, scond, amax, equed ) + pure subroutine stdlib_${ri}$laqsp( uplo, n, ap, s, scond, amax, equed ) !! DLAQSP: equilibrates a symmetric matrix A using the scaling factors !! in the vector S. ! -- lapack auxiliary routine -- @@ -36207,17 +36208,17 @@ module stdlib_linalg_lapack_q character, intent(out) :: equed character, intent(in) :: uplo integer(ilp), intent(in) :: n - real(qp), intent(in) :: amax, scond + real(${rk}$), intent(in) :: amax, scond ! Array Arguments - real(qp), intent(inout) :: ap(*) - real(qp), intent(in) :: s(*) + real(${rk}$), intent(inout) :: ap(*) + real(${rk}$), intent(in) :: s(*) ! ===================================================================== ! Parameters - real(qp), parameter :: thresh = 0.1e+0_qp + real(${rk}$), parameter :: thresh = 0.1e+0_${rk}$ ! Local Scalars integer(ilp) :: i, j, jc - real(qp) :: cj, large, small + real(${rk}$) :: cj, large, small ! Executable Statements ! quick return if possible if( n<=0 ) then @@ -36225,7 +36226,7 @@ module stdlib_linalg_lapack_q return end if ! initialize large and small. - small = stdlib_qlamch( 'SAFE MINIMUM' ) / stdlib_qlamch( 'PRECISION' ) + small = stdlib_${ri}$lamch( 'SAFE MINIMUM' ) / stdlib_${ri}$lamch( 'PRECISION' ) large = one / small if( scond>=thresh .and. amax>=small .and. amax<=large ) then ! no equilibration @@ -36256,10 +36257,10 @@ module stdlib_linalg_lapack_q equed = 'Y' end if return - end subroutine stdlib_qlaqsp + end subroutine stdlib_${ri}$laqsp - pure subroutine stdlib_qlaqsy( uplo, n, a, lda, s, scond, amax, equed ) + pure subroutine stdlib_${ri}$laqsy( uplo, n, a, lda, s, scond, amax, equed ) !! DLAQSY: equilibrates a symmetric matrix A using the scaling factors !! in the vector S. ! -- lapack auxiliary routine -- @@ -36269,17 +36270,17 @@ module stdlib_linalg_lapack_q character, intent(out) :: equed character, intent(in) :: uplo integer(ilp), intent(in) :: lda, n - real(qp), intent(in) :: amax, scond + real(${rk}$), intent(in) :: amax, scond ! Array Arguments - real(qp), intent(inout) :: a(lda,*) - real(qp), intent(in) :: s(*) + real(${rk}$), intent(inout) :: a(lda,*) + real(${rk}$), intent(in) :: s(*) ! ===================================================================== ! Parameters - real(qp), parameter :: thresh = 0.1e+0_qp + real(${rk}$), parameter :: thresh = 0.1e+0_${rk}$ ! Local Scalars integer(ilp) :: i, j - real(qp) :: cj, large, small + real(${rk}$) :: cj, large, small ! Executable Statements ! quick return if possible if( n<=0 ) then @@ -36287,7 +36288,7 @@ module stdlib_linalg_lapack_q return end if ! initialize large and small. - small = stdlib_qlamch( 'SAFE MINIMUM' ) / stdlib_qlamch( 'PRECISION' ) + small = stdlib_${ri}$lamch( 'SAFE MINIMUM' ) / stdlib_${ri}$lamch( 'PRECISION' ) large = one / small if( scond>=thresh .and. amax>=small .and. amax<=large ) then ! no equilibration @@ -36314,10 +36315,10 @@ module stdlib_linalg_lapack_q equed = 'Y' end if return - end subroutine stdlib_qlaqsy + end subroutine stdlib_${ri}$laqsy - subroutine stdlib_qlaqtr( ltran, lreal, n, t, ldt, b, w, scale, x, work,info ) + subroutine stdlib_${ri}$laqtr( ltran, lreal, n, t, ldt, b, w, scale, x, work,info ) !! DLAQTR: solves the real quasi-triangular system !! op(T)*p = scale*c, if LREAL = .TRUE. !! or the complex quasi-triangular systems @@ -36343,21 +36344,21 @@ module stdlib_linalg_lapack_q logical(lk), intent(in) :: lreal, ltran integer(ilp), intent(out) :: info integer(ilp), intent(in) :: ldt, n - real(qp), intent(out) :: scale - real(qp), intent(in) :: w + real(${rk}$), intent(out) :: scale + real(${rk}$), intent(in) :: w ! Array Arguments - real(qp), intent(in) :: b(*), t(ldt,*) - real(qp), intent(out) :: work(*) - real(qp), intent(inout) :: x(*) + real(${rk}$), intent(in) :: b(*), t(ldt,*) + real(${rk}$), intent(out) :: work(*) + real(${rk}$), intent(inout) :: x(*) ! ===================================================================== ! Local Scalars logical(lk) :: notran integer(ilp) :: i, ierr, j, j1, j2, jnext, k, n1, n2 - real(qp) :: bignum, eps, rec, scaloc, si, smin, sminw, smlnum, sr, tjj, tmp, xj, xmax, & + real(${rk}$) :: bignum, eps, rec, scaloc, si, smin, sminw, smlnum, sr, tjj, tmp, xj, xmax, & xnorm, z ! Local Arrays - real(qp) :: d(2,2), v(2,2) + real(${rk}$) :: d(2,2), v(2,2) ! Intrinsic Functions intrinsic :: abs,max ! Executable Statements @@ -36367,18 +36368,18 @@ module stdlib_linalg_lapack_q ! quick return if possible if( n==0 )return ! set constants to control overflow - eps = stdlib_qlamch( 'P' ) - smlnum = stdlib_qlamch( 'S' ) / eps + eps = stdlib_${ri}$lamch( 'P' ) + smlnum = stdlib_${ri}$lamch( 'S' ) / eps bignum = one / smlnum - xnorm = stdlib_qlange( 'M', n, n, t, ldt, d ) - if( .not.lreal )xnorm = max( xnorm, abs( w ), stdlib_qlange( 'M', n, 1, b, n, d ) ) + xnorm = stdlib_${ri}$lange( 'M', n, n, t, ldt, d ) + if( .not.lreal )xnorm = max( xnorm, abs( w ), stdlib_${ri}$lange( 'M', n, 1, b, n, d ) ) smin = max( smlnum, eps*xnorm ) ! compute 1-norm of each column of strictly upper triangular ! part of t to control overflow in triangular solver. work( 1 ) = zero do j = 2, n - work( j ) = stdlib_qasum( j-1, t( 1, j ), 1 ) + work( j ) = stdlib_${ri}$asum( j-1, t( 1, j ), 1 ) end do if( .not.lreal ) then do i = 2, n @@ -36388,12 +36389,12 @@ module stdlib_linalg_lapack_q n2 = 2*n n1 = n if( .not.lreal )n1 = n2 - k = stdlib_iqamax( n1, x, 1 ) + k = stdlib_i${ri}$amax( n1, x, 1 ) xmax = abs( x( k ) ) scale = one if( xmax>bignum ) then scale = bignum / xmax - call stdlib_qscal( n1, scale, x, 1 ) + call stdlib_${ri}$scal( n1, scale, x, 1 ) xmax = bignum end if if( lreal ) then @@ -36427,7 +36428,7 @@ module stdlib_linalg_lapack_q if( tjjbignum*tjj ) then rec = one / xj - call stdlib_qscal( n, rec, x, 1 ) + call stdlib_${ri}$scal( n, rec, x, 1 ) scale = scale*rec xmax = xmax*rec end if @@ -36439,13 +36440,13 @@ module stdlib_linalg_lapack_q if( xj>one ) then rec = one / xj if( work( j1 )>( bignum-xmax )*rec ) then - call stdlib_qscal( n, rec, x, 1 ) + call stdlib_${ri}$scal( n, rec, x, 1 ) scale = scale*rec end if end if if( j1>1 ) then - call stdlib_qaxpy( j1-1, -x( j1 ), t( 1, j1 ), 1, x, 1 ) - k = stdlib_iqamax( j1-1, x, 1 ) + call stdlib_${ri}$axpy( j1-1, -x( j1 ), t( 1, j1 ), 1, x, 1 ) + k = stdlib_i${ri}$amax( j1-1, x, 1 ) xmax = abs( x( k ) ) end if else @@ -36454,11 +36455,11 @@ module stdlib_linalg_lapack_q ! care of possible overflow by scaling factor. d( 1, 1 ) = x( j1 ) d( 2, 1 ) = x( j2 ) - call stdlib_qlaln2( .false., 2, 1, smin, one, t( j1, j1 ),ldt, one, one, d,& + call stdlib_${ri}$laln2( .false., 2, 1, smin, one, t( j1, j1 ),ldt, one, one, d,& 2, zero, zero, v, 2,scaloc, xnorm, ierr ) if( ierr/=0 )info = 2 if( scaloc/=one ) then - call stdlib_qscal( n, scaloc, x, 1 ) + call stdlib_${ri}$scal( n, scaloc, x, 1 ) scale = scale*scaloc end if x( j1 ) = v( 1, 1 ) @@ -36469,15 +36470,15 @@ module stdlib_linalg_lapack_q if( xj>one ) then rec = one / xj if( max( work( j1 ), work( j2 ) )>( bignum-xmax )*rec ) then - call stdlib_qscal( n, rec, x, 1 ) + call stdlib_${ri}$scal( n, rec, x, 1 ) scale = scale*rec end if end if ! update right-hand side if( j1>1 ) then - call stdlib_qaxpy( j1-1, -x( j1 ), t( 1, j1 ), 1, x, 1 ) - call stdlib_qaxpy( j1-1, -x( j2 ), t( 1, j2 ), 1, x, 1 ) - k = stdlib_iqamax( j1-1, x, 1 ) + call stdlib_${ri}$axpy( j1-1, -x( j1 ), t( 1, j1 ), 1, x, 1 ) + call stdlib_${ri}$axpy( j1-1, -x( j2 ), t( 1, j2 ), 1, x, 1 ) + k = stdlib_i${ri}$amax( j1-1, x, 1 ) xmax = abs( x( k ) ) end if end if @@ -36504,12 +36505,12 @@ module stdlib_linalg_lapack_q if( xmax>one ) then rec = one / xmax if( work( j1 )>( bignum-xj )*rec ) then - call stdlib_qscal( n, rec, x, 1 ) + call stdlib_${ri}$scal( n, rec, x, 1 ) scale = scale*rec xmax = xmax*rec end if end if - x( j1 ) = x( j1 ) - stdlib_qdot( j1-1, t( 1, j1 ), 1, x, 1 ) + x( j1 ) = x( j1 ) - stdlib_${ri}$dot( j1-1, t( 1, j1 ), 1, x, 1 ) xj = abs( x( j1 ) ) tjj = abs( t( j1, j1 ) ) tmp = t( j1, j1 ) @@ -36521,7 +36522,7 @@ module stdlib_linalg_lapack_q if( tjjbignum*tjj ) then rec = one / xj - call stdlib_qscal( n, rec, x, 1 ) + call stdlib_${ri}$scal( n, rec, x, 1 ) scale = scale*rec xmax = xmax*rec end if @@ -36536,18 +36537,18 @@ module stdlib_linalg_lapack_q if( xmax>one ) then rec = one / xmax if( max( work( j2 ), work( j1 ) )>( bignum-xj )*rec ) then - call stdlib_qscal( n, rec, x, 1 ) + call stdlib_${ri}$scal( n, rec, x, 1 ) scale = scale*rec xmax = xmax*rec end if end if - d( 1, 1 ) = x( j1 ) - stdlib_qdot( j1-1, t( 1, j1 ), 1, x,1 ) - d( 2, 1 ) = x( j2 ) - stdlib_qdot( j1-1, t( 1, j2 ), 1, x,1 ) - call stdlib_qlaln2( .true., 2, 1, smin, one, t( j1, j1 ),ldt, one, one, d, & + d( 1, 1 ) = x( j1 ) - stdlib_${ri}$dot( j1-1, t( 1, j1 ), 1, x,1 ) + d( 2, 1 ) = x( j2 ) - stdlib_${ri}$dot( j1-1, t( 1, j2 ), 1, x,1 ) + call stdlib_${ri}$laln2( .true., 2, 1, smin, one, t( j1, j1 ),ldt, one, one, d, & 2, zero, zero, v, 2,scaloc, xnorm, ierr ) if( ierr/=0 )info = 2 if( scaloc/=one ) then - call stdlib_qscal( n, scaloc, x, 1 ) + call stdlib_${ri}$scal( n, scaloc, x, 1 ) scale = scale*scaloc end if x( j1 ) = v( 1, 1 ) @@ -36589,12 +36590,12 @@ module stdlib_linalg_lapack_q if( tjjbignum*tjj ) then rec = one / xj - call stdlib_qscal( n2, rec, x, 1 ) + call stdlib_${ri}$scal( n2, rec, x, 1 ) scale = scale*rec xmax = xmax*rec end if end if - call stdlib_qladiv( x( j1 ), x( n+j1 ), tmp, z, sr, si ) + call stdlib_${ri}$ladiv( x( j1 ), x( n+j1 ), tmp, z, sr, si ) x( j1 ) = sr x( n+j1 ) = si xj = abs( x( j1 ) ) + abs( x( n+j1 ) ) @@ -36603,13 +36604,13 @@ module stdlib_linalg_lapack_q if( xj>one ) then rec = one / xj if( work( j1 )>( bignum-xmax )*rec ) then - call stdlib_qscal( n2, rec, x, 1 ) + call stdlib_${ri}$scal( n2, rec, x, 1 ) scale = scale*rec end if end if if( j1>1 ) then - call stdlib_qaxpy( j1-1, -x( j1 ), t( 1, j1 ), 1, x, 1 ) - call stdlib_qaxpy( j1-1, -x( n+j1 ), t( 1, j1 ), 1,x( n+1 ), 1 ) + call stdlib_${ri}$axpy( j1-1, -x( j1 ), t( 1, j1 ), 1, x, 1 ) + call stdlib_${ri}$axpy( j1-1, -x( n+j1 ), t( 1, j1 ), 1,x( n+1 ), 1 ) x( 1 ) = x( 1 ) + b( j1 )*x( n+j1 ) x( n+1 ) = x( n+1 ) - b( j1 )*x( j1 ) xmax = zero @@ -36623,11 +36624,11 @@ module stdlib_linalg_lapack_q d( 2, 1 ) = x( j2 ) d( 1, 2 ) = x( n+j1 ) d( 2, 2 ) = x( n+j2 ) - call stdlib_qlaln2( .false., 2, 2, sminw, one, t( j1, j1 ),ldt, one, one, & + call stdlib_${ri}$laln2( .false., 2, 2, sminw, one, t( j1, j1 ),ldt, one, one, & d, 2, zero, -w, v, 2,scaloc, xnorm, ierr ) if( ierr/=0 )info = 2 if( scaloc/=one ) then - call stdlib_qscal( 2*n, scaloc, x, 1 ) + call stdlib_${ri}$scal( 2*n, scaloc, x, 1 ) scale = scaloc*scale end if x( j1 ) = v( 1, 1 ) @@ -36641,16 +36642,16 @@ module stdlib_linalg_lapack_q if( xj>one ) then rec = one / xj if( max( work( j1 ), work( j2 ) )>( bignum-xmax )*rec ) then - call stdlib_qscal( n2, rec, x, 1 ) + call stdlib_${ri}$scal( n2, rec, x, 1 ) scale = scale*rec end if end if ! update the right-hand side. if( j1>1 ) then - call stdlib_qaxpy( j1-1, -x( j1 ), t( 1, j1 ), 1, x, 1 ) - call stdlib_qaxpy( j1-1, -x( j2 ), t( 1, j2 ), 1, x, 1 ) - call stdlib_qaxpy( j1-1, -x( n+j1 ), t( 1, j1 ), 1,x( n+1 ), 1 ) - call stdlib_qaxpy( j1-1, -x( n+j2 ), t( 1, j2 ), 1,x( n+1 ), 1 ) + call stdlib_${ri}$axpy( j1-1, -x( j1 ), t( 1, j1 ), 1, x, 1 ) + call stdlib_${ri}$axpy( j1-1, -x( j2 ), t( 1, j2 ), 1, x, 1 ) + call stdlib_${ri}$axpy( j1-1, -x( n+j1 ), t( 1, j1 ), 1,x( n+1 ), 1 ) + call stdlib_${ri}$axpy( j1-1, -x( n+j2 ), t( 1, j2 ), 1,x( n+1 ), 1 ) x( 1 ) = x( 1 ) + b( j1 )*x( n+j1 ) +b( j2 )*x( n+j2 ) x( n+1 ) = x( n+1 ) - b( j1 )*x( j1 ) -b( j2 )*x( j2 ) xmax = zero @@ -36682,13 +36683,13 @@ module stdlib_linalg_lapack_q if( xmax>one ) then rec = one / xmax if( work( j1 )>( bignum-xj )*rec ) then - call stdlib_qscal( n2, rec, x, 1 ) + call stdlib_${ri}$scal( n2, rec, x, 1 ) scale = scale*rec xmax = xmax*rec end if end if - x( j1 ) = x( j1 ) - stdlib_qdot( j1-1, t( 1, j1 ), 1, x, 1 ) - x( n+j1 ) = x( n+j1 ) - stdlib_qdot( j1-1, t( 1, j1 ), 1,x( n+1 ), 1 ) + x( j1 ) = x( j1 ) - stdlib_${ri}$dot( j1-1, t( 1, j1 ), 1, x, 1 ) + x( n+j1 ) = x( n+j1 ) - stdlib_${ri}$dot( j1-1, t( 1, j1 ), 1,x( n+1 ), 1 ) if( j1>1 ) then x( j1 ) = x( j1 ) - b( j1 )*x( n+1 ) @@ -36709,12 +36710,12 @@ module stdlib_linalg_lapack_q if( tjjbignum*tjj ) then rec = one / xj - call stdlib_qscal( n2, rec, x, 1 ) + call stdlib_${ri}$scal( n2, rec, x, 1 ) scale = scale*rec xmax = xmax*rec end if end if - call stdlib_qladiv( x( j1 ), x( n+j1 ), tmp, -z, sr, si ) + call stdlib_${ri}$ladiv( x( j1 ), x( n+j1 ), tmp, -z, sr, si ) x( j1 ) = sr x( j1+n ) = si xmax = max( abs( x( j1 ) )+abs( x( j1+n ) ), xmax ) @@ -36727,26 +36728,26 @@ module stdlib_linalg_lapack_q if( xmax>one ) then rec = one / xmax if( max( work( j1 ), work( j2 ) )>( bignum-xj ) / xmax ) then - call stdlib_qscal( n2, rec, x, 1 ) + call stdlib_${ri}$scal( n2, rec, x, 1 ) scale = scale*rec xmax = xmax*rec end if end if - d( 1, 1 ) = x( j1 ) - stdlib_qdot( j1-1, t( 1, j1 ), 1, x,1 ) - d( 2, 1 ) = x( j2 ) - stdlib_qdot( j1-1, t( 1, j2 ), 1, x,1 ) - d( 1, 2 ) = x( n+j1 ) - stdlib_qdot( j1-1, t( 1, j1 ), 1,x( n+1 ), 1 ) + d( 1, 1 ) = x( j1 ) - stdlib_${ri}$dot( j1-1, t( 1, j1 ), 1, x,1 ) + d( 2, 1 ) = x( j2 ) - stdlib_${ri}$dot( j1-1, t( 1, j2 ), 1, x,1 ) + d( 1, 2 ) = x( n+j1 ) - stdlib_${ri}$dot( j1-1, t( 1, j1 ), 1,x( n+1 ), 1 ) - d( 2, 2 ) = x( n+j2 ) - stdlib_qdot( j1-1, t( 1, j2 ), 1,x( n+1 ), 1 ) + d( 2, 2 ) = x( n+j2 ) - stdlib_${ri}$dot( j1-1, t( 1, j2 ), 1,x( n+1 ), 1 ) d( 1, 1 ) = d( 1, 1 ) - b( j1 )*x( n+1 ) d( 2, 1 ) = d( 2, 1 ) - b( j2 )*x( n+1 ) d( 1, 2 ) = d( 1, 2 ) + b( j1 )*x( 1 ) d( 2, 2 ) = d( 2, 2 ) + b( j2 )*x( 1 ) - call stdlib_qlaln2( .true., 2, 2, sminw, one, t( j1, j1 ),ldt, one, one, d,& + call stdlib_${ri}$laln2( .true., 2, 2, sminw, one, t( j1, j1 ),ldt, one, one, d,& 2, zero, w, v, 2,scaloc, xnorm, ierr ) if( ierr/=0 )info = 2 if( scaloc/=one ) then - call stdlib_qscal( n2, scaloc, x, 1 ) + call stdlib_${ri}$scal( n2, scaloc, x, 1 ) scale = scaloc*scale end if x( j1 ) = v( 1, 1 ) @@ -36760,10 +36761,10 @@ module stdlib_linalg_lapack_q end if end if return - end subroutine stdlib_qlaqtr + end subroutine stdlib_${ri}$laqtr - recursive subroutine stdlib_qlaqz0( wants, wantq, wantz, n, ilo, ihi, a,lda, b, ldb, alphar, & + recursive subroutine stdlib_${ri}$laqz0( wants, wantq, wantz, n, ilo, ihi, a,lda, b, ldb, alphar, & !! DLAQZ0: computes the eigenvalues of a real matrix pair (H,T), !! where H is an upper Hessenberg matrix and T is upper triangular, !! using the double-shift QZ method. @@ -36817,11 +36818,11 @@ module stdlib_linalg_lapack_q character, intent( in ) :: wants, wantq, wantz integer(ilp), intent( in ) :: n, ilo, ihi, lda, ldb, ldq, ldz, lwork,rec integer(ilp), intent( out ) :: info - real(qp), intent( inout ) :: a( lda, * ), b( ldb, * ),q( ldq, * ), z( ldz, * ), alphar(& + real(${rk}$), intent( inout ) :: a( lda, * ), b( ldb, * ),q( ldq, * ), z( ldz, * ), alphar(& * ),alphai( * ), beta( * ), work( * ) ! local scalars - real(qp) :: smlnum, ulp, eshift, safmin, safmax, c1, s1, temp, swap + real(${rk}$) :: smlnum, ulp, eshift, safmin, safmax, c1, s1, temp, swap integer(ilp) :: istart, istop, iiter, maxit, istart2, k, ld, nshifts, nblock, nw, nmin,& nibble, n_undeflated, n_qeflated, ns, sweep_info, shiftpos, lworkreq, k2, istartm, & istopm, iwants, iwantq, iwantz, norm_info, aed_info, nwr, nbr, nsr, itemp1, itemp2, & @@ -36890,7 +36891,7 @@ module stdlib_linalg_lapack_q end if ! quick return if possible if( n<=0 ) then - work( 1 ) = real( 1,KIND=qp) + work( 1 ) = real( 1,KIND=${rk}$) return end if ! get the parameters @@ -36906,28 +36907,28 @@ module stdlib_linalg_lapack_q nsr = min( nsr, ( n+6 ) / 9, ihi-ilo ) nsr = max( 2, nsr-mod( nsr, 2 ) ) rcost = stdlib_ilaenv( 17, 'DLAQZ0', jbcmpz, n, ilo, ihi, lwork ) - itemp1 = int( nsr/sqrt( 1+2*nsr/( real( rcost,KIND=qp)/100*n ) ),KIND=ilp) + itemp1 = int( nsr/sqrt( 1+2*nsr/( real( rcost,KIND=${rk}$)/100*n ) ),KIND=ilp) itemp1 = ( ( itemp1-1 )/4 )*4+4 nbr = nsr+itemp1 if( n < nmin .or. rec >= 2 ) then - call stdlib_qhgeqz( wants, wantq, wantz, n, ilo, ihi, a, lda, b, ldb,alphar, alphai,& + call stdlib_${ri}$hgeqz( wants, wantq, wantz, n, ilo, ihi, a, lda, b, ldb,alphar, alphai,& beta, q, ldq, z, ldz, work,lwork, info ) return end if ! find out required workspace - ! workspace query to stdlib_qlaqz3 + ! workspace query to stdlib_${ri}$laqz3 nw = max( nwr, nmin ) - call stdlib_qlaqz3( ilschur, ilq, ilz, n, ilo, ihi, nw, a, lda, b, ldb,q, ldq, z, ldz, & + call stdlib_${ri}$laqz3( ilschur, ilq, ilz, n, ilo, ihi, nw, a, lda, b, ldb,q, ldq, z, ldz, & n_undeflated, n_qeflated, alphar,alphai, beta, work, nw, work, nw, work, -1, rec,& aed_info ) itemp1 = int( work( 1 ),KIND=ilp) - ! workspace query to stdlib_qlaqz4 - call stdlib_qlaqz4( ilschur, ilq, ilz, n, ilo, ihi, nsr, nbr, alphar,alphai, beta, a, & + ! workspace query to stdlib_${ri}$laqz4 + call stdlib_${ri}$laqz4( ilschur, ilq, ilz, n, ilo, ihi, nsr, nbr, alphar,alphai, beta, a, & lda, b, ldb, q, ldq, z, ldz, work,nbr, work, nbr, work, -1, sweep_info ) itemp2 = int( work( 1 ),KIND=ilp) lworkreq = max( itemp1+2*nw**2, itemp2+2*nbr**2 ) if ( lwork ==-1 ) then - work( 1 ) = real( lworkreq,KIND=qp) + work( 1 ) = real( lworkreq,KIND=${rk}$) return else if ( lwork < lworkreq ) then info = -19 @@ -36937,14 +36938,14 @@ module stdlib_linalg_lapack_q return end if ! initialize q and z - if( iwantq==3 ) call stdlib_qlaset( 'FULL', n, n, zero, one, q, ldq ) - if( iwantz==3 ) call stdlib_qlaset( 'FULL', n, n, zero, one, z, ldz ) + if( iwantq==3 ) call stdlib_${ri}$laset( 'FULL', n, n, zero, one, q, ldq ) + if( iwantz==3 ) call stdlib_${ri}$laset( 'FULL', n, n, zero, one, z, ldz ) ! get machine constants - safmin = stdlib_qlamch( 'SAFE MINIMUM' ) + safmin = stdlib_${ri}$lamch( 'SAFE MINIMUM' ) safmax = one/safmin - call stdlib_qlabad( safmin, safmax ) - ulp = stdlib_qlamch( 'PRECISION' ) - smlnum = safmin*( real( n,KIND=qp)/ulp ) + call stdlib_${ri}$labad( safmin, safmax ) + ulp = stdlib_${ri}$lamch( 'PRECISION' ) + smlnum = safmin*( real( n,KIND=${rk}$)/ulp ) istart = ilo istop = ihi maxit = 3*( ihi-ilo+1 ) @@ -37022,41 +37023,41 @@ module stdlib_linalg_lapack_q ! a diagonal element of b is negligable, move it ! to the top and deflate it do k2 = k, istart2+1, -1 - call stdlib_qlartg( b( k2-1, k2 ), b( k2-1, k2-1 ), c1, s1,temp ) + call stdlib_${ri}$lartg( b( k2-1, k2 ), b( k2-1, k2-1 ), c1, s1,temp ) b( k2-1, k2 ) = temp b( k2-1, k2-1 ) = zero - call stdlib_qrot( k2-2-istartm+1, b( istartm, k2 ), 1,b( istartm, k2-1 ), & + call stdlib_${ri}$rot( k2-2-istartm+1, b( istartm, k2 ), 1,b( istartm, k2-1 ), & 1, c1, s1 ) - call stdlib_qrot( min( k2+1, istop )-istartm+1, a( istartm,k2 ), 1, a( & + call stdlib_${ri}$rot( min( k2+1, istop )-istartm+1, a( istartm,k2 ), 1, a( & istartm, k2-1 ), 1, c1, s1 ) if ( ilz ) then - call stdlib_qrot( n, z( 1, k2 ), 1, z( 1, k2-1 ), 1, c1,s1 ) + call stdlib_${ri}$rot( n, z( 1, k2 ), 1, z( 1, k2-1 ), 1, c1,s1 ) end if if( k2 0 ) then @@ -37125,11 +37126,11 @@ module stdlib_linalg_lapack_q end do if ( mod( ld, 6 ) == 0 ) then ! exceptional shift. chosen for no particularly good reason. - if( ( real( maxit,KIND=qp)*safmin )*abs( a( istop,istop-1 ) )safmax .or. abs( v( 2 ) ) > safmax .or.abs( v( 3 ) )>safmax .or. & - stdlib_qisnan( v( 1 ) ) .or.stdlib_qisnan( v( 2 ) ) .or. stdlib_qisnan( v( 3 ) ) ) & + stdlib_${ri}$isnan( v( 1 ) ) .or.stdlib_${ri}$isnan( v( 2 ) ) .or. stdlib_${ri}$isnan( v( 3 ) ) ) & then v( 1 ) = zero v( 2 ) = zero v( 3 ) = zero end if - end subroutine stdlib_qlaqz1 + end subroutine stdlib_${ri}$laqz1 - pure subroutine stdlib_qlaqz2( ilq, ilz, k, istartm, istopm, ihi, a, lda, b,ldb, nq, qstart, & + pure subroutine stdlib_${ri}$laqz2( ilq, ilz, k, istartm, istopm, ihi, a, lda, b,ldb, nq, qstart, & !! DLAQZ2: chases a 2x2 shift bulge in a matrix pencil down a single position q, ldq, nz, zstart, z, ldz ) ! arguments logical(lk), intent( in ) :: ilq, ilz integer(ilp), intent( in ) :: k, lda, ldb, ldq, ldz, istartm, istopm,nq, nz, qstart, & zstart, ihi - real(qp), intent(inout) :: a(lda,*), b(ldb,*), q(ldq,*), z(ldz,*) + real(${rk}$), intent(inout) :: a(lda,*), b(ldb,*), q(ldq,*), z(ldz,*) ! local variables - real(qp) :: h(2,3), c1, s1, c2, s2, temp + real(${rk}$) :: h(2,3), c1, s1, c2, s2, temp if( k+2 == ihi ) then ! shift is located on the edge of the matrix, remove it h = b( ihi-1:ihi, ihi-2:ihi ) ! make h upper triangular - call stdlib_qlartg( h( 1, 1 ), h( 2, 1 ), c1, s1, temp ) + call stdlib_${ri}$lartg( h( 1, 1 ), h( 2, 1 ), c1, s1, temp ) h( 2, 1 ) = zero h( 1, 1 ) = temp - call stdlib_qrot( 2, h( 1, 2 ), 2, h( 2, 2 ), 2, c1, s1 ) - call stdlib_qlartg( h( 2, 3 ), h( 2, 2 ), c1, s1, temp ) - call stdlib_qrot( 1, h( 1, 3 ), 1, h( 1, 2 ), 1, c1, s1 ) - call stdlib_qlartg( h( 1, 2 ), h( 1, 1 ), c2, s2, temp ) - call stdlib_qrot( ihi-istartm+1, b( istartm, ihi ), 1, b( istartm,ihi-1 ), 1, c1, & + call stdlib_${ri}$rot( 2, h( 1, 2 ), 2, h( 2, 2 ), 2, c1, s1 ) + call stdlib_${ri}$lartg( h( 2, 3 ), h( 2, 2 ), c1, s1, temp ) + call stdlib_${ri}$rot( 1, h( 1, 3 ), 1, h( 1, 2 ), 1, c1, s1 ) + call stdlib_${ri}$lartg( h( 1, 2 ), h( 1, 1 ), c2, s2, temp ) + call stdlib_${ri}$rot( ihi-istartm+1, b( istartm, ihi ), 1, b( istartm,ihi-1 ), 1, c1, & s1 ) - call stdlib_qrot( ihi-istartm+1, b( istartm, ihi-1 ), 1, b( istartm,ihi-2 ), 1, c2, & + call stdlib_${ri}$rot( ihi-istartm+1, b( istartm, ihi-1 ), 1, b( istartm,ihi-2 ), 1, c2, & s2 ) b( ihi-1, ihi-2 ) = zero b( ihi, ihi-2 ) = zero - call stdlib_qrot( ihi-istartm+1, a( istartm, ihi ), 1, a( istartm,ihi-1 ), 1, c1, & + call stdlib_${ri}$rot( ihi-istartm+1, a( istartm, ihi ), 1, a( istartm,ihi-1 ), 1, c1, & s1 ) - call stdlib_qrot( ihi-istartm+1, a( istartm, ihi-1 ), 1, a( istartm,ihi-2 ), 1, c2, & + call stdlib_${ri}$rot( ihi-istartm+1, a( istartm, ihi-1 ), 1, a( istartm,ihi-2 ), 1, c2, & s2 ) if ( ilz ) then - call stdlib_qrot( nz, z( 1, ihi-zstart+1 ), 1, z( 1, ihi-1-zstart+1 ), 1, c1, s1 & + call stdlib_${ri}$rot( nz, z( 1, ihi-zstart+1 ), 1, z( 1, ihi-1-zstart+1 ), 1, c1, s1 & ) - call stdlib_qrot( nz, z( 1, ihi-1-zstart+1 ), 1, z( 1,ihi-2-zstart+1 ), 1, c2, & + call stdlib_${ri}$rot( nz, z( 1, ihi-1-zstart+1 ), 1, z( 1,ihi-2-zstart+1 ), 1, c2, & s2 ) end if - call stdlib_qlartg( a( ihi-1, ihi-2 ), a( ihi, ihi-2 ), c1, s1,temp ) + call stdlib_${ri}$lartg( a( ihi-1, ihi-2 ), a( ihi, ihi-2 ), c1, s1,temp ) a( ihi-1, ihi-2 ) = temp a( ihi, ihi-2 ) = zero - call stdlib_qrot( istopm-ihi+2, a( ihi-1, ihi-1 ), lda, a( ihi,ihi-1 ), lda, c1, s1 & + call stdlib_${ri}$rot( istopm-ihi+2, a( ihi-1, ihi-1 ), lda, a( ihi,ihi-1 ), lda, c1, s1 & ) - call stdlib_qrot( istopm-ihi+2, b( ihi-1, ihi-1 ), ldb, b( ihi,ihi-1 ), ldb, c1, s1 & + call stdlib_${ri}$rot( istopm-ihi+2, b( ihi-1, ihi-1 ), ldb, b( ihi,ihi-1 ), ldb, c1, s1 & ) if ( ilq ) then - call stdlib_qrot( nq, q( 1, ihi-1-qstart+1 ), 1, q( 1, ihi-qstart+1 ), 1, c1, s1 & + call stdlib_${ri}$rot( nq, q( 1, ihi-1-qstart+1 ), 1, q( 1, ihi-qstart+1 ), 1, c1, s1 & ) end if - call stdlib_qlartg( b( ihi, ihi ), b( ihi, ihi-1 ), c1, s1, temp ) + call stdlib_${ri}$lartg( b( ihi, ihi ), b( ihi, ihi-1 ), c1, s1, temp ) b( ihi, ihi ) = temp b( ihi, ihi-1 ) = zero - call stdlib_qrot( ihi-istartm, b( istartm, ihi ), 1, b( istartm,ihi-1 ), 1, c1, s1 ) + call stdlib_${ri}$rot( ihi-istartm, b( istartm, ihi ), 1, b( istartm,ihi-1 ), 1, c1, s1 ) - call stdlib_qrot( ihi-istartm+1, a( istartm, ihi ), 1, a( istartm,ihi-1 ), 1, c1, & + call stdlib_${ri}$rot( ihi-istartm+1, a( istartm, ihi ), 1, a( istartm,ihi-1 ), 1, c1, & s1 ) if ( ilz ) then - call stdlib_qrot( nz, z( 1, ihi-zstart+1 ), 1, z( 1, ihi-1-zstart+1 ), 1, c1, s1 & + call stdlib_${ri}$rot( nz, z( 1, ihi-zstart+1 ), 1, z( 1, ihi-1-zstart+1 ), 1, c1, s1 & ) end if else ! normal operation, move bulge down h = b( k+1:k+2, k:k+2 ) ! make h upper triangular - call stdlib_qlartg( h( 1, 1 ), h( 2, 1 ), c1, s1, temp ) + call stdlib_${ri}$lartg( h( 1, 1 ), h( 2, 1 ), c1, s1, temp ) h( 2, 1 ) = zero h( 1, 1 ) = temp - call stdlib_qrot( 2, h( 1, 2 ), 2, h( 2, 2 ), 2, c1, s1 ) + call stdlib_${ri}$rot( 2, h( 1, 2 ), 2, h( 2, 2 ), 2, c1, s1 ) ! calculate z1 and z2 - call stdlib_qlartg( h( 2, 3 ), h( 2, 2 ), c1, s1, temp ) - call stdlib_qrot( 1, h( 1, 3 ), 1, h( 1, 2 ), 1, c1, s1 ) - call stdlib_qlartg( h( 1, 2 ), h( 1, 1 ), c2, s2, temp ) + call stdlib_${ri}$lartg( h( 2, 3 ), h( 2, 2 ), c1, s1, temp ) + call stdlib_${ri}$rot( 1, h( 1, 3 ), 1, h( 1, 2 ), 1, c1, s1 ) + call stdlib_${ri}$lartg( h( 1, 2 ), h( 1, 1 ), c2, s2, temp ) ! apply transformations from the right - call stdlib_qrot( k+3-istartm+1, a( istartm, k+2 ), 1, a( istartm,k+1 ), 1, c1, s1 ) + call stdlib_${ri}$rot( k+3-istartm+1, a( istartm, k+2 ), 1, a( istartm,k+1 ), 1, c1, s1 ) - call stdlib_qrot( k+3-istartm+1, a( istartm, k+1 ), 1, a( istartm,k ), 1, c2, s2 ) + call stdlib_${ri}$rot( k+3-istartm+1, a( istartm, k+1 ), 1, a( istartm,k ), 1, c2, s2 ) - call stdlib_qrot( k+2-istartm+1, b( istartm, k+2 ), 1, b( istartm,k+1 ), 1, c1, s1 ) + call stdlib_${ri}$rot( k+2-istartm+1, b( istartm, k+2 ), 1, b( istartm,k+1 ), 1, c1, s1 ) - call stdlib_qrot( k+2-istartm+1, b( istartm, k+1 ), 1, b( istartm,k ), 1, c2, s2 ) + call stdlib_${ri}$rot( k+2-istartm+1, b( istartm, k+1 ), 1, b( istartm,k ), 1, c2, s2 ) if ( ilz ) then - call stdlib_qrot( nz, z( 1, k+2-zstart+1 ), 1, z( 1, k+1-zstart+1 ), 1, c1, s1 ) + call stdlib_${ri}$rot( nz, z( 1, k+2-zstart+1 ), 1, z( 1, k+1-zstart+1 ), 1, c1, s1 ) - call stdlib_qrot( nz, z( 1, k+1-zstart+1 ), 1, z( 1, k-zstart+1 ),1, c2, s2 ) + call stdlib_${ri}$rot( nz, z( 1, k+1-zstart+1 ), 1, z( 1, k-zstart+1 ),1, c2, s2 ) end if b( k+1, k ) = zero b( k+2, k ) = zero ! calculate q1 and q2 - call stdlib_qlartg( a( k+2, k ), a( k+3, k ), c1, s1, temp ) + call stdlib_${ri}$lartg( a( k+2, k ), a( k+3, k ), c1, s1, temp ) a( k+2, k ) = temp a( k+3, k ) = zero - call stdlib_qlartg( a( k+1, k ), a( k+2, k ), c2, s2, temp ) + call stdlib_${ri}$lartg( a( k+1, k ), a( k+2, k ), c2, s2, temp ) a( k+1, k ) = temp a( k+2, k ) = zero ! apply transformations from the left - call stdlib_qrot( istopm-k, a( k+2, k+1 ), lda, a( k+3, k+1 ), lda,c1, s1 ) - call stdlib_qrot( istopm-k, a( k+1, k+1 ), lda, a( k+2, k+1 ), lda,c2, s2 ) - call stdlib_qrot( istopm-k, b( k+2, k+1 ), ldb, b( k+3, k+1 ), ldb,c1, s1 ) - call stdlib_qrot( istopm-k, b( k+1, k+1 ), ldb, b( k+2, k+1 ), ldb,c2, s2 ) + call stdlib_${ri}$rot( istopm-k, a( k+2, k+1 ), lda, a( k+3, k+1 ), lda,c1, s1 ) + call stdlib_${ri}$rot( istopm-k, a( k+1, k+1 ), lda, a( k+2, k+1 ), lda,c2, s2 ) + call stdlib_${ri}$rot( istopm-k, b( k+2, k+1 ), ldb, b( k+3, k+1 ), ldb,c1, s1 ) + call stdlib_${ri}$rot( istopm-k, b( k+1, k+1 ), ldb, b( k+2, k+1 ), ldb,c2, s2 ) if ( ilq ) then - call stdlib_qrot( nq, q( 1, k+2-qstart+1 ), 1, q( 1, k+3-qstart+1 ), 1, c1, s1 ) + call stdlib_${ri}$rot( nq, q( 1, k+2-qstart+1 ), 1, q( 1, k+3-qstart+1 ), 1, c1, s1 ) - call stdlib_qrot( nq, q( 1, k+1-qstart+1 ), 1, q( 1, k+2-qstart+1 ), 1, c2, s2 ) + call stdlib_${ri}$rot( nq, q( 1, k+1-qstart+1 ), 1, q( 1, k+2-qstart+1 ), 1, c2, s2 ) end if end if - end subroutine stdlib_qlaqz2 + end subroutine stdlib_${ri}$laqz2 - recursive subroutine stdlib_qlaqz3( ilschur, ilq, ilz, n, ilo, ihi, nw,a, lda, b, ldb, q, & + recursive subroutine stdlib_${ri}$laqz3( ilschur, ilq, ilz, n, ilo, ihi, nw,a, lda, b, ldb, q, & !! DLAQZ3: performs AED ldq, z, ldz, ns,nd, alphar, alphai, beta, qc, ldqc,zc, ldzc, work, lwork, rec, info ) ! arguments logical(lk), intent( in ) :: ilschur, ilq, ilz integer(ilp), intent( in ) :: n, ilo, ihi, nw, lda, ldb, ldq, ldz,ldqc, ldzc, lwork, & rec - real(qp), intent( inout ) :: a( lda, * ), b( ldb, * ),q( ldq, * ), z( ldz, * ), alphar(& + real(${rk}$), intent( inout ) :: a( lda, * ), b( ldb, * ),q( ldq, * ), z( ldz, * ), alphar(& * ),alphai( * ), beta( * ) integer(ilp), intent( out ) :: ns, nd, info - real(qp), intent(inout) :: qc(ldqc,*), zc(ldzc,*) - real(qp), intent(out) :: work(*) + real(${rk}$), intent(inout) :: qc(ldqc,*), zc(ldzc,*) + real(${rk}$), intent(out) :: work(*) ! local scalars logical(lk) :: bulge integer(ilp) :: jw, kwtop, kwbot, istopm, istartm, k, k2, dtgexc_info, ifst, ilst, & lworkreq, qz_small_info - real(qp) :: s, smlnum, ulp, safmin, safmax, c1, s1, temp + real(${rk}$) :: s, smlnum, ulp, safmin, safmax, c1, s1, temp info = 0 ! set up deflation window jw = min( nw, ihi-ilo+1 ) @@ -37351,10 +37352,10 @@ module stdlib_linalg_lapack_q ! determine required workspace ifst = 1 ilst = jw - call stdlib_qtgexc( .true., .true., jw, a, lda, b, ldb, qc, ldqc, zc,ldzc, ifst, ilst, & + call stdlib_${ri}$tgexc( .true., .true., jw, a, lda, b, ldb, qc, ldqc, zc,ldzc, ifst, ilst, & work, -1, dtgexc_info ) lworkreq = int( work( 1 ),KIND=ilp) - call stdlib_qlaqz0( 'S', 'V', 'V', jw, 1, jw, a( kwtop, kwtop ), lda,b( kwtop, kwtop ),& + call stdlib_${ri}$laqz0( 'S', 'V', 'V', jw, 1, jw, a( kwtop, kwtop ), lda,b( kwtop, kwtop ),& ldb, alphar, alphai, beta, qc,ldqc, zc, ldzc, work, -1, rec+1, qz_small_info ) lworkreq = max( lworkreq, int( work( 1 ),KIND=ilp)+2*jw**2 ) lworkreq = max( lworkreq, n*nw, 2*nw**2+n ) @@ -37370,11 +37371,11 @@ module stdlib_linalg_lapack_q return end if ! get machine constants - safmin = stdlib_qlamch( 'SAFE MINIMUM' ) + safmin = stdlib_${ri}$lamch( 'SAFE MINIMUM' ) safmax = one/safmin - call stdlib_qlabad( safmin, safmax ) - ulp = stdlib_qlamch( 'PRECISION' ) - smlnum = safmin*( real( n,KIND=qp)/ulp ) + call stdlib_${ri}$labad( safmin, safmax ) + ulp = stdlib_${ri}$lamch( 'PRECISION' ) + smlnum = safmin*( real( n,KIND=${rk}$)/ulp ) if ( ihi == kwtop ) then ! 1 by 1 deflation window, just try a regular deflation alphar( kwtop ) = a( kwtop, kwtop ) @@ -37391,21 +37392,21 @@ module stdlib_linalg_lapack_q end if end if ! store window in case of convergence failure - call stdlib_qlacpy( 'ALL', jw, jw, a( kwtop, kwtop ), lda, work, jw ) - call stdlib_qlacpy( 'ALL', jw, jw, b( kwtop, kwtop ), ldb, work( jw**2+1 ), jw ) + call stdlib_${ri}$lacpy( 'ALL', jw, jw, a( kwtop, kwtop ), lda, work, jw ) + call stdlib_${ri}$lacpy( 'ALL', jw, jw, b( kwtop, kwtop ), ldb, work( jw**2+1 ), jw ) ! transform window to real schur form - call stdlib_qlaset( 'FULL', jw, jw, zero, one, qc, ldqc ) - call stdlib_qlaset( 'FULL', jw, jw, zero, one, zc, ldzc ) - call stdlib_qlaqz0( 'S', 'V', 'V', jw, 1, jw, a( kwtop, kwtop ), lda,b( kwtop, kwtop ),& + call stdlib_${ri}$laset( 'FULL', jw, jw, zero, one, qc, ldqc ) + call stdlib_${ri}$laset( 'FULL', jw, jw, zero, one, zc, ldzc ) + call stdlib_${ri}$laqz0( 'S', 'V', 'V', jw, 1, jw, a( kwtop, kwtop ), lda,b( kwtop, kwtop ),& ldb, alphar, alphai, beta, qc,ldqc, zc, ldzc, work( 2*jw**2+1 ), lwork-2*jw**2,rec+1, & qz_small_info ) if( qz_small_info /= 0 ) then ! convergence failure, restore the window and exit nd = 0 ns = jw-qz_small_info - call stdlib_qlacpy( 'ALL', jw, jw, work, jw, a( kwtop, kwtop ), lda ) - call stdlib_qlacpy( 'ALL', jw, jw, work( jw**2+1 ), jw, b( kwtop,kwtop ), ldb ) + call stdlib_${ri}$lacpy( 'ALL', jw, jw, work, jw, a( kwtop, kwtop ), lda ) + call stdlib_${ri}$lacpy( 'ALL', jw, jw, work( jw**2+1 ), jw, b( kwtop,kwtop ), ldb ) return end if @@ -37436,7 +37437,7 @@ module stdlib_linalg_lapack_q ! not deflatable, move out of the way ifst = kwbot-kwtop+1 ilst = k2 - call stdlib_qtgexc( .true., .true., jw, a( kwtop, kwtop ),lda, b( kwtop, & + call stdlib_${ri}$tgexc( .true., .true., jw, a( kwtop, kwtop ),lda, b( kwtop, & kwtop ), ldb, qc, ldqc,zc, ldzc, ifst, ilst, work, lwork,dtgexc_info ) k2 = k2+2 @@ -37456,7 +37457,7 @@ module stdlib_linalg_lapack_q ! not deflatable, move out of the way ifst = kwbot-kwtop+1 ilst = k2 - call stdlib_qtgexc( .true., .true., jw, a( kwtop, kwtop ),lda, b( kwtop, & + call stdlib_${ri}$tgexc( .true., .true., jw, a( kwtop, kwtop ),lda, b( kwtop, & kwtop ), ldb, qc, ldqc,zc, ldzc, ifst, ilst, work, lwork,dtgexc_info ) k2 = k2+1 @@ -37478,7 +37479,7 @@ module stdlib_linalg_lapack_q end if if ( bulge ) then ! 2x2 eigenvalue block - call stdlib_qlag2( a( k, k ), lda, b( k, k ), ldb, safmin,beta( k ), beta( k+1 ),& + call stdlib_${ri}$lag2( a( k, k ), lda, b( k, k ), ldb, safmin,beta( k ), beta( k+1 ),& alphar( k ),alphar( k+1 ), alphai( k ) ) alphai( k+1 ) = -alphai( k ) k = k+2 @@ -37494,14 +37495,14 @@ module stdlib_linalg_lapack_q ! reflect spike back, this will create optimally packed bulges a( kwtop:kwbot, kwtop-1 ) = a( kwtop, kwtop-1 )*qc( 1,1:jw-nd ) do k = kwbot-1, kwtop, -1 - call stdlib_qlartg( a( k, kwtop-1 ), a( k+1, kwtop-1 ), c1, s1,temp ) + call stdlib_${ri}$lartg( a( k, kwtop-1 ), a( k+1, kwtop-1 ), c1, s1,temp ) a( k, kwtop-1 ) = temp a( k+1, kwtop-1 ) = zero k2 = max( kwtop, k-1 ) - call stdlib_qrot( ihi-k2+1, a( k, k2 ), lda, a( k+1, k2 ), lda, c1,s1 ) - call stdlib_qrot( ihi-( k-1 )+1, b( k, k-1 ), ldb, b( k+1, k-1 ),ldb, c1, s1 ) + call stdlib_${ri}$rot( ihi-k2+1, a( k, k2 ), lda, a( k+1, k2 ), lda, c1,s1 ) + call stdlib_${ri}$rot( ihi-( k-1 )+1, b( k, k-1 ), ldb, b( k+1, k-1 ),ldb, c1, s1 ) - call stdlib_qrot( jw, qc( 1, k-kwtop+1 ), 1, qc( 1, k+1-kwtop+1 ),1, c1, s1 ) + call stdlib_${ri}$rot( jw, qc( 1, k-kwtop+1 ), 1, qc( 1, k+1-kwtop+1 ),1, c1, s1 ) end do ! chase bulges down @@ -37512,7 +37513,7 @@ module stdlib_linalg_lapack_q if ( ( k >= kwtop+1 ) .and. a( k+1, k-1 ) /= zero ) then ! move double pole block down and remove it do k2 = k-1, kwbot-2 - call stdlib_qlaqz2( .true., .true., k2, kwtop, kwtop+jw-1,kwbot, a, lda, b,& + call stdlib_${ri}$laqz2( .true., .true., k2, kwtop, kwtop+jw-1,kwbot, a, lda, b,& ldb, jw, kwtop, qc,ldqc, jw, kwtop, zc, ldzc ) end do k = k-2 @@ -37520,35 +37521,35 @@ module stdlib_linalg_lapack_q ! k points to single shift do k2 = k, kwbot-2 ! move shift down - call stdlib_qlartg( b( k2+1, k2+1 ), b( k2+1, k2 ), c1, s1,temp ) + call stdlib_${ri}$lartg( b( k2+1, k2+1 ), b( k2+1, k2 ), c1, s1,temp ) b( k2+1, k2+1 ) = temp b( k2+1, k2 ) = zero - call stdlib_qrot( k2+2-istartm+1, a( istartm, k2+1 ), 1,a( istartm, k2 ), & + call stdlib_${ri}$rot( k2+2-istartm+1, a( istartm, k2+1 ), 1,a( istartm, k2 ), & 1, c1, s1 ) - call stdlib_qrot( k2-istartm+1, b( istartm, k2+1 ), 1,b( istartm, k2 ), 1, & + call stdlib_${ri}$rot( k2-istartm+1, b( istartm, k2+1 ), 1,b( istartm, k2 ), 1, & c1, s1 ) - call stdlib_qrot( jw, zc( 1, k2+1-kwtop+1 ), 1, zc( 1,k2-kwtop+1 ), 1, c1, & + call stdlib_${ri}$rot( jw, zc( 1, k2+1-kwtop+1 ), 1, zc( 1,k2-kwtop+1 ), 1, c1, & s1 ) - call stdlib_qlartg( a( k2+1, k2 ), a( k2+2, k2 ), c1, s1,temp ) + call stdlib_${ri}$lartg( a( k2+1, k2 ), a( k2+2, k2 ), c1, s1,temp ) a( k2+1, k2 ) = temp a( k2+2, k2 ) = zero - call stdlib_qrot( istopm-k2, a( k2+1, k2+1 ), lda, a( k2+2,k2+1 ), lda, c1,& + call stdlib_${ri}$rot( istopm-k2, a( k2+1, k2+1 ), lda, a( k2+2,k2+1 ), lda, c1,& s1 ) - call stdlib_qrot( istopm-k2, b( k2+1, k2+1 ), ldb, b( k2+2,k2+1 ), ldb, c1,& + call stdlib_${ri}$rot( istopm-k2, b( k2+1, k2+1 ), ldb, b( k2+2,k2+1 ), ldb, c1,& s1 ) - call stdlib_qrot( jw, qc( 1, k2+1-kwtop+1 ), 1, qc( 1,k2+2-kwtop+1 ), 1, & + call stdlib_${ri}$rot( jw, qc( 1, k2+1-kwtop+1 ), 1, qc( 1,k2+2-kwtop+1 ), 1, & c1, s1 ) end do ! remove the shift - call stdlib_qlartg( b( kwbot, kwbot ), b( kwbot, kwbot-1 ), c1,s1, temp ) + call stdlib_${ri}$lartg( b( kwbot, kwbot ), b( kwbot, kwbot-1 ), c1,s1, temp ) b( kwbot, kwbot ) = temp b( kwbot, kwbot-1 ) = zero - call stdlib_qrot( kwbot-istartm, b( istartm, kwbot ), 1,b( istartm, kwbot-1 ),& + call stdlib_${ri}$rot( kwbot-istartm, b( istartm, kwbot ), 1,b( istartm, kwbot-1 ),& 1, c1, s1 ) - call stdlib_qrot( kwbot-istartm+1, a( istartm, kwbot ), 1,a( istartm, kwbot-1 & + call stdlib_${ri}$rot( kwbot-istartm+1, a( istartm, kwbot ), 1,a( istartm, kwbot-1 & ), 1, c1, s1 ) - call stdlib_qrot( jw, zc( 1, kwbot-kwtop+1 ), 1, zc( 1,kwbot-1-kwtop+1 ), 1, & + call stdlib_${ri}$rot( jw, zc( 1, kwbot-kwtop+1 ), 1, zc( 1,kwbot-1-kwtop+1 ), 1, & c1, s1 ) k = k-1 end if @@ -37563,51 +37564,51 @@ module stdlib_linalg_lapack_q istopm = ihi end if if ( istopm-ihi > 0 ) then - call stdlib_qgemm( 'T', 'N', jw, istopm-ihi, jw, one, qc, ldqc,a( kwtop, ihi+1 ), & + call stdlib_${ri}$gemm( 'T', 'N', jw, istopm-ihi, jw, one, qc, ldqc,a( kwtop, ihi+1 ), & lda, zero, work, jw ) - call stdlib_qlacpy( 'ALL', jw, istopm-ihi, work, jw, a( kwtop,ihi+1 ), lda ) - call stdlib_qgemm( 'T', 'N', jw, istopm-ihi, jw, one, qc, ldqc,b( kwtop, ihi+1 ), & + call stdlib_${ri}$lacpy( 'ALL', jw, istopm-ihi, work, jw, a( kwtop,ihi+1 ), lda ) + call stdlib_${ri}$gemm( 'T', 'N', jw, istopm-ihi, jw, one, qc, ldqc,b( kwtop, ihi+1 ), & ldb, zero, work, jw ) - call stdlib_qlacpy( 'ALL', jw, istopm-ihi, work, jw, b( kwtop,ihi+1 ), ldb ) + call stdlib_${ri}$lacpy( 'ALL', jw, istopm-ihi, work, jw, b( kwtop,ihi+1 ), ldb ) end if if ( ilq ) then - call stdlib_qgemm( 'N', 'N', n, jw, jw, one, q( 1, kwtop ), ldq, qc,ldqc, zero, & + call stdlib_${ri}$gemm( 'N', 'N', n, jw, jw, one, q( 1, kwtop ), ldq, qc,ldqc, zero, & work, n ) - call stdlib_qlacpy( 'ALL', n, jw, work, n, q( 1, kwtop ), ldq ) + call stdlib_${ri}$lacpy( 'ALL', n, jw, work, n, q( 1, kwtop ), ldq ) end if if ( kwtop-1-istartm+1 > 0 ) then - call stdlib_qgemm( 'N', 'N', kwtop-istartm, jw, jw, one, a( istartm,kwtop ), lda, & + call stdlib_${ri}$gemm( 'N', 'N', kwtop-istartm, jw, jw, one, a( istartm,kwtop ), lda, & zc, ldzc, zero, work,kwtop-istartm ) - call stdlib_qlacpy( 'ALL', kwtop-istartm, jw, work, kwtop-istartm,a( istartm, kwtop & + call stdlib_${ri}$lacpy( 'ALL', kwtop-istartm, jw, work, kwtop-istartm,a( istartm, kwtop & ), lda ) - call stdlib_qgemm( 'N', 'N', kwtop-istartm, jw, jw, one, b( istartm,kwtop ), ldb, & + call stdlib_${ri}$gemm( 'N', 'N', kwtop-istartm, jw, jw, one, b( istartm,kwtop ), ldb, & zc, ldzc, zero, work,kwtop-istartm ) - call stdlib_qlacpy( 'ALL', kwtop-istartm, jw, work, kwtop-istartm,b( istartm, kwtop & + call stdlib_${ri}$lacpy( 'ALL', kwtop-istartm, jw, work, kwtop-istartm,b( istartm, kwtop & ), ldb ) end if if ( ilz ) then - call stdlib_qgemm( 'N', 'N', n, jw, jw, one, z( 1, kwtop ), ldz, zc,ldzc, zero, & + call stdlib_${ri}$gemm( 'N', 'N', n, jw, jw, one, z( 1, kwtop ), ldz, zc,ldzc, zero, & work, n ) - call stdlib_qlacpy( 'ALL', n, jw, work, n, z( 1, kwtop ), ldz ) + call stdlib_${ri}$lacpy( 'ALL', n, jw, work, n, z( 1, kwtop ), ldz ) end if - end subroutine stdlib_qlaqz3 + end subroutine stdlib_${ri}$laqz3 - pure subroutine stdlib_qlaqz4( ilschur, ilq, ilz, n, ilo, ihi, nshifts,nblock_qesired, sr, & + pure subroutine stdlib_${ri}$laqz4( ilschur, ilq, ilz, n, ilo, ihi, nshifts,nblock_qesired, sr, & !! DLAQZ4: Executes a single multishift QZ sweep si, ss, a, lda, b, ldb, q,ldq, z, ldz, qc, ldqc, zc, ldzc, work, lwork,info ) ! function arguments logical(lk), intent( in ) :: ilschur, ilq, ilz integer(ilp), intent( in ) :: n, ilo, ihi, lda, ldb, ldq, ldz, lwork,nshifts, & nblock_qesired, ldqc, ldzc - real(qp), intent( inout ) :: a( lda, * ), b( ldb, * ),q( ldq, * ), z( ldz, * ), qc( & + real(${rk}$), intent( inout ) :: a( lda, * ), b( ldb, * ),q( ldq, * ), z( ldz, * ), qc( & ldqc, * ),zc( ldzc, * ), work( * ), sr( * ), si( * ),ss( * ) integer(ilp), intent( out ) :: info ! local scalars integer(ilp) :: i, j, ns, istartm, istopm, sheight, swidth, k, np, istartb, istopb, & ishift, nblock, npos - real(qp) :: temp, v(3), c1, s1, c2, s2, swap + real(${rk}$) :: temp, v(3), c1, s1, c2, s2, swap info = 0 if ( nblock_qesired < nshifts+1 ) then info = -8 @@ -37667,24 +37668,24 @@ module stdlib_linalg_lapack_q ! them down one by one just enough to make space for ! the other shifts. the near-the-diagonal block is ! of size (ns+1) x ns. - call stdlib_qlaset( 'FULL', ns+1, ns+1, zero, one, qc, ldqc ) - call stdlib_qlaset( 'FULL', ns, ns, zero, one, zc, ldzc ) + call stdlib_${ri}$laset( 'FULL', ns+1, ns+1, zero, one, qc, ldqc ) + call stdlib_${ri}$laset( 'FULL', ns, ns, zero, one, zc, ldzc ) do i = 1, ns, 2 ! introduce the shift - call stdlib_qlaqz1( a( ilo, ilo ), lda, b( ilo, ilo ), ldb, sr( i ),sr( i+1 ), si( & + call stdlib_${ri}$laqz1( a( ilo, ilo ), lda, b( ilo, ilo ), ldb, sr( i ),sr( i+1 ), si( & i ), ss( i ), ss( i+1 ), v ) temp = v( 2 ) - call stdlib_qlartg( temp, v( 3 ), c1, s1, v( 2 ) ) - call stdlib_qlartg( v( 1 ), v( 2 ), c2, s2, temp ) - call stdlib_qrot( ns, a( ilo+1, ilo ), lda, a( ilo+2, ilo ), lda, c1,s1 ) - call stdlib_qrot( ns, a( ilo, ilo ), lda, a( ilo+1, ilo ), lda, c2,s2 ) - call stdlib_qrot( ns, b( ilo+1, ilo ), ldb, b( ilo+2, ilo ), ldb, c1,s1 ) - call stdlib_qrot( ns, b( ilo, ilo ), ldb, b( ilo+1, ilo ), ldb, c2,s2 ) - call stdlib_qrot( ns+1, qc( 1, 2 ), 1, qc( 1, 3 ), 1, c1, s1 ) - call stdlib_qrot( ns+1, qc( 1, 1 ), 1, qc( 1, 2 ), 1, c2, s2 ) + call stdlib_${ri}$lartg( temp, v( 3 ), c1, s1, v( 2 ) ) + call stdlib_${ri}$lartg( v( 1 ), v( 2 ), c2, s2, temp ) + call stdlib_${ri}$rot( ns, a( ilo+1, ilo ), lda, a( ilo+2, ilo ), lda, c1,s1 ) + call stdlib_${ri}$rot( ns, a( ilo, ilo ), lda, a( ilo+1, ilo ), lda, c2,s2 ) + call stdlib_${ri}$rot( ns, b( ilo+1, ilo ), ldb, b( ilo+2, ilo ), ldb, c1,s1 ) + call stdlib_${ri}$rot( ns, b( ilo, ilo ), ldb, b( ilo+1, ilo ), ldb, c2,s2 ) + call stdlib_${ri}$rot( ns+1, qc( 1, 2 ), 1, qc( 1, 3 ), 1, c1, s1 ) + call stdlib_${ri}$rot( ns+1, qc( 1, 1 ), 1, qc( 1, 2 ), 1, c2, s2 ) ! chase the shift down do j = 1, ns-1-i - call stdlib_qlaqz2( .true., .true., j, 1, ns, ihi-ilo+1, a( ilo,ilo ), lda, b( & + call stdlib_${ri}$laqz2( .true., .true., j, 1, ns, ihi-ilo+1, a( ilo,ilo ), lda, b( & ilo, ilo ), ldb, ns+1, 1, qc,ldqc, ns, 1, zc, ldzc ) end do end do @@ -37694,38 +37695,38 @@ module stdlib_linalg_lapack_q sheight = ns+1 swidth = istopm-( ilo+ns )+1 if ( swidth > 0 ) then - call stdlib_qgemm( 'T', 'N', sheight, swidth, sheight, one, qc, ldqc,a( ilo, ilo+ns & + call stdlib_${ri}$gemm( 'T', 'N', sheight, swidth, sheight, one, qc, ldqc,a( ilo, ilo+ns & ), lda, zero, work, sheight ) - call stdlib_qlacpy( 'ALL', sheight, swidth, work, sheight, a( ilo,ilo+ns ), lda ) + call stdlib_${ri}$lacpy( 'ALL', sheight, swidth, work, sheight, a( ilo,ilo+ns ), lda ) - call stdlib_qgemm( 'T', 'N', sheight, swidth, sheight, one, qc, ldqc,b( ilo, ilo+ns & + call stdlib_${ri}$gemm( 'T', 'N', sheight, swidth, sheight, one, qc, ldqc,b( ilo, ilo+ns & ), ldb, zero, work, sheight ) - call stdlib_qlacpy( 'ALL', sheight, swidth, work, sheight, b( ilo,ilo+ns ), ldb ) + call stdlib_${ri}$lacpy( 'ALL', sheight, swidth, work, sheight, b( ilo,ilo+ns ), ldb ) end if if ( ilq ) then - call stdlib_qgemm( 'N', 'N', n, sheight, sheight, one, q( 1, ilo ),ldq, qc, ldqc, & + call stdlib_${ri}$gemm( 'N', 'N', n, sheight, sheight, one, q( 1, ilo ),ldq, qc, ldqc, & zero, work, n ) - call stdlib_qlacpy( 'ALL', n, sheight, work, n, q( 1, ilo ), ldq ) + call stdlib_${ri}$lacpy( 'ALL', n, sheight, work, n, q( 1, ilo ), ldq ) end if ! update a(istartm:ilo-1,ilo:ilo+ns-1) and b(istartm:ilo-1,ilo:ilo+ns-1) ! from the right with zc(1:ns,1:ns) sheight = ilo-1-istartm+1 swidth = ns if ( sheight > 0 ) then - call stdlib_qgemm( 'N', 'N', sheight, swidth, swidth, one, a( istartm,ilo ), lda, & + call stdlib_${ri}$gemm( 'N', 'N', sheight, swidth, swidth, one, a( istartm,ilo ), lda, & zc, ldzc, zero, work, sheight ) - call stdlib_qlacpy( 'ALL', sheight, swidth, work, sheight, a( istartm,ilo ), lda ) + call stdlib_${ri}$lacpy( 'ALL', sheight, swidth, work, sheight, a( istartm,ilo ), lda ) - call stdlib_qgemm( 'N', 'N', sheight, swidth, swidth, one, b( istartm,ilo ), ldb, & + call stdlib_${ri}$gemm( 'N', 'N', sheight, swidth, swidth, one, b( istartm,ilo ), ldb, & zc, ldzc, zero, work, sheight ) - call stdlib_qlacpy( 'ALL', sheight, swidth, work, sheight, b( istartm,ilo ), ldb ) + call stdlib_${ri}$lacpy( 'ALL', sheight, swidth, work, sheight, b( istartm,ilo ), ldb ) end if if ( ilz ) then - call stdlib_qgemm( 'N', 'N', n, swidth, swidth, one, z( 1, ilo ), ldz,zc, ldzc, & + call stdlib_${ri}$gemm( 'N', 'N', n, swidth, swidth, one, z( 1, ilo ), ldz,zc, ldzc, & zero, work, n ) - call stdlib_qlacpy( 'ALL', n, swidth, work, n, z( 1, ilo ), ldz ) + call stdlib_${ri}$lacpy( 'ALL', n, swidth, work, n, z( 1, ilo ), ldz ) end if ! the following block chases the shifts down to the bottom ! right block. if possible, a shift is moved down npos @@ -37739,15 +37740,15 @@ module stdlib_linalg_lapack_q istartb = k+1 ! istopb points to the last column we will be updating istopb = k+nblock-1 - call stdlib_qlaset( 'FULL', ns+np, ns+np, zero, one, qc, ldqc ) - call stdlib_qlaset( 'FULL', ns+np, ns+np, zero, one, zc, ldzc ) + call stdlib_${ri}$laset( 'FULL', ns+np, ns+np, zero, one, qc, ldqc ) + call stdlib_${ri}$laset( 'FULL', ns+np, ns+np, zero, one, zc, ldzc ) ! near the diagonal shift chase do i = ns-1, 0, -2 do j = 0, np-1 ! move down the block with index k+i+j-1, updating ! the (ns+np x ns+np) block: ! (k:k+ns+np,k:k+ns+np-1) - call stdlib_qlaqz2( .true., .true., k+i+j-1, istartb, istopb,ihi, a, lda, b, & + call stdlib_${ri}$laqz2( .true., .true., k+i+j-1, istartb, istopb,ihi, a, lda, b, & ldb, nblock, k+1, qc, ldqc,nblock, k, zc, ldzc ) end do end do @@ -37758,45 +37759,45 @@ module stdlib_linalg_lapack_q sheight = ns+np swidth = istopm-( k+ns+np )+1 if ( swidth > 0 ) then - call stdlib_qgemm( 'T', 'N', sheight, swidth, sheight, one, qc,ldqc, a( k+1, k+& + call stdlib_${ri}$gemm( 'T', 'N', sheight, swidth, sheight, one, qc,ldqc, a( k+1, k+& ns+np ), lda, zero, work,sheight ) - call stdlib_qlacpy( 'ALL', sheight, swidth, work, sheight, a( k+1,k+ns+np ), lda & + call stdlib_${ri}$lacpy( 'ALL', sheight, swidth, work, sheight, a( k+1,k+ns+np ), lda & ) - call stdlib_qgemm( 'T', 'N', sheight, swidth, sheight, one, qc,ldqc, b( k+1, k+& + call stdlib_${ri}$gemm( 'T', 'N', sheight, swidth, sheight, one, qc,ldqc, b( k+1, k+& ns+np ), ldb, zero, work,sheight ) - call stdlib_qlacpy( 'ALL', sheight, swidth, work, sheight, b( k+1,k+ns+np ), ldb & + call stdlib_${ri}$lacpy( 'ALL', sheight, swidth, work, sheight, b( k+1,k+ns+np ), ldb & ) end if if ( ilq ) then - call stdlib_qgemm( 'N', 'N', n, nblock, nblock, one, q( 1, k+1 ),ldq, qc, ldqc, & + call stdlib_${ri}$gemm( 'N', 'N', n, nblock, nblock, one, q( 1, k+1 ),ldq, qc, ldqc, & zero, work, n ) - call stdlib_qlacpy( 'ALL', n, nblock, work, n, q( 1, k+1 ), ldq ) + call stdlib_${ri}$lacpy( 'ALL', n, nblock, work, n, q( 1, k+1 ), ldq ) end if ! update a(istartm:k,k:k+ns+npos-1) and b(istartm:k,k:k+ns+npos-1) ! from the right with zc(1:ns+np,1:ns+np) sheight = k-istartm+1 swidth = nblock if ( sheight > 0 ) then - call stdlib_qgemm( 'N', 'N', sheight, swidth, swidth, one,a( istartm, k ), lda, & + call stdlib_${ri}$gemm( 'N', 'N', sheight, swidth, swidth, one,a( istartm, k ), lda, & zc, ldzc, zero, work,sheight ) - call stdlib_qlacpy( 'ALL', sheight, swidth, work, sheight,a( istartm, k ), lda ) + call stdlib_${ri}$lacpy( 'ALL', sheight, swidth, work, sheight,a( istartm, k ), lda ) - call stdlib_qgemm( 'N', 'N', sheight, swidth, swidth, one,b( istartm, k ), ldb, & + call stdlib_${ri}$gemm( 'N', 'N', sheight, swidth, swidth, one,b( istartm, k ), ldb, & zc, ldzc, zero, work,sheight ) - call stdlib_qlacpy( 'ALL', sheight, swidth, work, sheight,b( istartm, k ), ldb ) + call stdlib_${ri}$lacpy( 'ALL', sheight, swidth, work, sheight,b( istartm, k ), ldb ) end if if ( ilz ) then - call stdlib_qgemm( 'N', 'N', n, nblock, nblock, one, z( 1, k ),ldz, zc, ldzc, & + call stdlib_${ri}$gemm( 'N', 'N', n, nblock, nblock, one, z( 1, k ),ldz, zc, ldzc, & zero, work, n ) - call stdlib_qlacpy( 'ALL', n, nblock, work, n, z( 1, k ), ldz ) + call stdlib_${ri}$lacpy( 'ALL', n, nblock, work, n, z( 1, k ), ldz ) end if k = k+np end do ! the following block removes the shifts from the bottom right corner ! one by one. updates are initially applied to a(ihi-ns+1:ihi,ihi-ns:ihi). - call stdlib_qlaset( 'FULL', ns, ns, zero, one, qc, ldqc ) - call stdlib_qlaset( 'FULL', ns+1, ns+1, zero, one, zc, ldzc ) + call stdlib_${ri}$laset( 'FULL', ns, ns, zero, one, qc, ldqc ) + call stdlib_${ri}$laset( 'FULL', ns+1, ns+1, zero, one, zc, ldzc ) ! istartb points to the first row we will be updating istartb = ihi-ns+1 ! istopb points to the last column we will be updating @@ -37804,7 +37805,7 @@ module stdlib_linalg_lapack_q do i = 1, ns, 2 ! chase the shift down to the bottom right corner do ishift = ihi-i-1, ihi-2 - call stdlib_qlaqz2( .true., .true., ishift, istartb, istopb, ihi,a, lda, b, ldb, & + call stdlib_${ri}$laqz2( .true., .true., ishift, istartb, istopb, ihi,a, lda, b, ldb, & ns, ihi-ns+1, qc, ldqc, ns+1,ihi-ns, zc, ldzc ) end do end do @@ -37814,43 +37815,43 @@ module stdlib_linalg_lapack_q sheight = ns swidth = istopm-( ihi+1 )+1 if ( swidth > 0 ) then - call stdlib_qgemm( 'T', 'N', sheight, swidth, sheight, one, qc, ldqc,a( ihi-ns+1, & + call stdlib_${ri}$gemm( 'T', 'N', sheight, swidth, sheight, one, qc, ldqc,a( ihi-ns+1, & ihi+1 ), lda, zero, work, sheight ) - call stdlib_qlacpy( 'ALL', sheight, swidth, work, sheight,a( ihi-ns+1, ihi+1 ), lda & + call stdlib_${ri}$lacpy( 'ALL', sheight, swidth, work, sheight,a( ihi-ns+1, ihi+1 ), lda & ) - call stdlib_qgemm( 'T', 'N', sheight, swidth, sheight, one, qc, ldqc,b( ihi-ns+1, & + call stdlib_${ri}$gemm( 'T', 'N', sheight, swidth, sheight, one, qc, ldqc,b( ihi-ns+1, & ihi+1 ), ldb, zero, work, sheight ) - call stdlib_qlacpy( 'ALL', sheight, swidth, work, sheight,b( ihi-ns+1, ihi+1 ), ldb & + call stdlib_${ri}$lacpy( 'ALL', sheight, swidth, work, sheight,b( ihi-ns+1, ihi+1 ), ldb & ) end if if ( ilq ) then - call stdlib_qgemm( 'N', 'N', n, ns, ns, one, q( 1, ihi-ns+1 ), ldq,qc, ldqc, zero, & + call stdlib_${ri}$gemm( 'N', 'N', n, ns, ns, one, q( 1, ihi-ns+1 ), ldq,qc, ldqc, zero, & work, n ) - call stdlib_qlacpy( 'ALL', n, ns, work, n, q( 1, ihi-ns+1 ), ldq ) + call stdlib_${ri}$lacpy( 'ALL', n, ns, work, n, q( 1, ihi-ns+1 ), ldq ) end if ! update a(istartm:ihi-ns,ihi-ns:ihi) ! from the right with zc(1:ns+1,1:ns+1) sheight = ihi-ns-istartm+1 swidth = ns+1 if ( sheight > 0 ) then - call stdlib_qgemm( 'N', 'N', sheight, swidth, swidth, one, a( istartm,ihi-ns ), lda,& + call stdlib_${ri}$gemm( 'N', 'N', sheight, swidth, swidth, one, a( istartm,ihi-ns ), lda,& zc, ldzc, zero, work, sheight ) - call stdlib_qlacpy( 'ALL', sheight, swidth, work, sheight, a( istartm,ihi-ns ), lda & + call stdlib_${ri}$lacpy( 'ALL', sheight, swidth, work, sheight, a( istartm,ihi-ns ), lda & ) - call stdlib_qgemm( 'N', 'N', sheight, swidth, swidth, one, b( istartm,ihi-ns ), ldb,& + call stdlib_${ri}$gemm( 'N', 'N', sheight, swidth, swidth, one, b( istartm,ihi-ns ), ldb,& zc, ldzc, zero, work, sheight ) - call stdlib_qlacpy( 'ALL', sheight, swidth, work, sheight, b( istartm,ihi-ns ), ldb & + call stdlib_${ri}$lacpy( 'ALL', sheight, swidth, work, sheight, b( istartm,ihi-ns ), ldb & ) end if if ( ilz ) then - call stdlib_qgemm( 'N', 'N', n, ns+1, ns+1, one, z( 1, ihi-ns ), ldz,zc, ldzc, zero,& + call stdlib_${ri}$gemm( 'N', 'N', n, ns+1, ns+1, one, z( 1, ihi-ns ), ldz,zc, ldzc, zero,& work, n ) - call stdlib_qlacpy( 'ALL', n, ns+1, work, n, z( 1, ihi-ns ), ldz ) + call stdlib_${ri}$lacpy( 'ALL', n, ns+1, work, n, z( 1, ihi-ns ), ldz ) end if - end subroutine stdlib_qlaqz4 + end subroutine stdlib_${ri}$laqz4 - pure subroutine stdlib_qlar1v( n, b1, bn, lambda, d, l, ld, lld,pivmin, gaptol, z, wantnc, & + pure subroutine stdlib_${ri}$lar1v( n, b1, bn, lambda, d, l, ld, lld,pivmin, gaptol, z, wantnc, & !! DLAR1V: computes the (scaled) r-th column of the inverse of !! the sumbmatrix in rows B1 through BN of the tridiagonal matrix !! L D L**T - sigma I. When sigma is close to an eigenvalue, the @@ -37875,23 +37876,23 @@ module stdlib_linalg_lapack_q integer(ilp), intent(in) :: b1, bn, n integer(ilp), intent(out) :: negcnt integer(ilp), intent(inout) :: r - real(qp), intent(in) :: gaptol, lambda, pivmin - real(qp), intent(out) :: mingma, nrminv, resid, rqcorr, ztz + real(${rk}$), intent(in) :: gaptol, lambda, pivmin + real(${rk}$), intent(out) :: mingma, nrminv, resid, rqcorr, ztz ! Array Arguments integer(ilp), intent(out) :: isuppz(*) - real(qp), intent(in) :: d(*), l(*), ld(*), lld(*) - real(qp), intent(out) :: work(*) - real(qp), intent(inout) :: z(*) + real(${rk}$), intent(in) :: d(*), l(*), ld(*), lld(*) + real(${rk}$), intent(out) :: work(*) + real(${rk}$), intent(inout) :: z(*) ! ===================================================================== ! Local Scalars logical(lk) :: sawnan1, sawnan2 integer(ilp) :: i, indlpl, indp, inds, indumn, neg1, neg2, r1, r2 - real(qp) :: dminus, dplus, eps, s, tmp + real(${rk}$) :: dminus, dplus, eps, s, tmp ! Intrinsic Functions intrinsic :: abs ! Executable Statements - eps = stdlib_qlamch( 'PRECISION' ) + eps = stdlib_${ri}$lamch( 'PRECISION' ) if( r==0 ) then r1 = b1 r2 = bn @@ -37922,7 +37923,7 @@ module stdlib_linalg_lapack_q work( inds+i ) = s*work( indlpl+i )*l( i ) s = work( inds+i ) - lambda end do - sawnan1 = stdlib_qisnan( s ) + sawnan1 = stdlib_${ri}$isnan( s ) if( sawnan1 ) goto 60 do i = r1, r2 - 1 dplus = d( i ) + s @@ -37930,7 +37931,7 @@ module stdlib_linalg_lapack_q work( inds+i ) = s*work( indlpl+i )*l( i ) s = work( inds+i ) - lambda end do - sawnan1 = stdlib_qisnan( s ) + sawnan1 = stdlib_${ri}$isnan( s ) 60 continue if( sawnan1 ) then ! runs a slower version of the above loop if a nan is detected @@ -37967,7 +37968,7 @@ module stdlib_linalg_lapack_q work( indp+i-1 ) = work( indp+i )*tmp - lambda end do tmp = work( indp+r1-1 ) - sawnan2 = stdlib_qisnan( tmp ) + sawnan2 = stdlib_${ri}$isnan( tmp ) if( sawnan2 ) then ! runs a slower version of the above loop if a nan is detected neg2 = 0 @@ -38069,10 +38070,10 @@ module stdlib_linalg_lapack_q resid = abs( mingma )*nrminv rqcorr = mingma*tmp return - end subroutine stdlib_qlar1v + end subroutine stdlib_${ri}$lar1v - pure subroutine stdlib_qlar2v( n, x, y, z, incx, c, s, incc ) + pure subroutine stdlib_${ri}$lar2v( n, x, y, z, incx, c, s, incc ) !! DLAR2V: applies a vector of real plane rotations from both sides to !! a sequence of 2-by-2 real symmetric matrices, defined by the elements !! of the vectors x, y and z. For i = 1,2,...,n @@ -38084,12 +38085,12 @@ module stdlib_linalg_lapack_q ! Scalar Arguments integer(ilp), intent(in) :: incc, incx, n ! Array Arguments - real(qp), intent(in) :: c(*), s(*) - real(qp), intent(inout) :: x(*), y(*), z(*) + real(${rk}$), intent(in) :: c(*), s(*) + real(${rk}$), intent(inout) :: x(*), y(*), z(*) ! ===================================================================== ! Local Scalars integer(ilp) :: i, ic, ix - real(qp) :: ci, si, t1, t2, t3, t4, t5, t6, xi, yi, zi + real(${rk}$) :: ci, si, t1, t2, t3, t4, t5, t6, xi, yi, zi ! Executable Statements ix = 1 ic = 1 @@ -38112,10 +38113,10 @@ module stdlib_linalg_lapack_q ic = ic + incc end do return - end subroutine stdlib_qlar2v + end subroutine stdlib_${ri}$lar2v - pure subroutine stdlib_qlarf( side, m, n, v, incv, tau, c, ldc, work ) + pure subroutine stdlib_${ri}$larf( side, m, n, v, incv, tau, c, ldc, work ) !! DLARF: applies a real elementary reflector H to a real m by n matrix !! C, from either the left or the right. H is represented in the form !! H = I - tau * v * v**T @@ -38127,11 +38128,11 @@ module stdlib_linalg_lapack_q ! Scalar Arguments character, intent(in) :: side integer(ilp), intent(in) :: incv, ldc, m, n - real(qp), intent(in) :: tau + real(${rk}$), intent(in) :: tau ! Array Arguments - real(qp), intent(inout) :: c(ldc,*) - real(qp), intent(in) :: v(*) - real(qp), intent(out) :: work(*) + real(${rk}$), intent(inout) :: c(ldc,*) + real(${rk}$), intent(in) :: v(*) + real(${rk}$), intent(out) :: work(*) ! ===================================================================== ! Local Scalars @@ -38161,38 +38162,38 @@ module stdlib_linalg_lapack_q end do if( applyleft ) then ! scan for the last non-zero column in c(1:lastv,:). - lastc = stdlib_ilaqlc(lastv, n, c, ldc) + lastc = stdlib_ila${ri}$lc(lastv, n, c, ldc) else ! scan for the last non-zero row in c(:,1:lastv). - lastc = stdlib_ilaqlr(m, lastv, c, ldc) + lastc = stdlib_ila${ri}$lr(m, lastv, c, ldc) end if end if - ! note that lastc.eq.0_qp renders the blas operations null; no special + ! note that lastc.eq.0_${rk}$ renders the blas operations null; no special ! case is needed at this level. if( applyleft ) then ! form h * c if( lastv>0 ) then ! w(1:lastc,1) := c(1:lastv,1:lastc)**t * v(1:lastv,1) - call stdlib_qgemv( 'TRANSPOSE', lastv, lastc, one, c, ldc, v, incv,zero, work, 1 & + call stdlib_${ri}$gemv( 'TRANSPOSE', lastv, lastc, one, c, ldc, v, incv,zero, work, 1 & ) ! c(1:lastv,1:lastc) := c(...) - v(1:lastv,1) * w(1:lastc,1)**t - call stdlib_qger( lastv, lastc, -tau, v, incv, work, 1, c, ldc ) + call stdlib_${ri}$ger( lastv, lastc, -tau, v, incv, work, 1, c, ldc ) end if else ! form c * h if( lastv>0 ) then ! w(1:lastc,1) := c(1:lastc,1:lastv) * v(1:lastv,1) - call stdlib_qgemv( 'NO TRANSPOSE', lastc, lastv, one, c, ldc,v, incv, zero, work,& + call stdlib_${ri}$gemv( 'NO TRANSPOSE', lastc, lastv, one, c, ldc,v, incv, zero, work,& 1 ) ! c(1:lastc,1:lastv) := c(...) - w(1:lastc,1) * v(1:lastv,1)**t - call stdlib_qger( lastc, lastv, -tau, work, 1, v, incv, c, ldc ) + call stdlib_${ri}$ger( lastc, lastv, -tau, work, 1, v, incv, c, ldc ) end if end if return - end subroutine stdlib_qlarf + end subroutine stdlib_${ri}$larf - pure subroutine stdlib_qlarfb( side, trans, direct, storev, m, n, k, v, ldv,t, ldt, c, ldc, & + pure subroutine stdlib_${ri}$larfb( side, trans, direct, storev, m, n, k, v, ldv,t, ldt, c, ldc, & !! DLARFB: applies a real block reflector H or its transpose H**T to a !! real m by n matrix C, from either the left or the right. work, ldwork ) @@ -38203,9 +38204,9 @@ module stdlib_linalg_lapack_q character, intent(in) :: direct, side, storev, trans integer(ilp), intent(in) :: k, ldc, ldt, ldv, ldwork, m, n ! Array Arguments - real(qp), intent(inout) :: c(ldc,*) - real(qp), intent(in) :: t(ldt,*), v(ldv,*) - real(qp), intent(out) :: work(ldwork,*) + real(${rk}$), intent(inout) :: c(ldc,*) + real(${rk}$), intent(in) :: t(ldt,*), v(ldv,*) + real(${rk}$), intent(out) :: work(ldwork,*) ! ===================================================================== ! Local Scalars @@ -38230,27 +38231,27 @@ module stdlib_linalg_lapack_q ! w := c**t * v = (c1**t * v1 + c2**t * v2) (stored in work) ! w := c1**t do j = 1, k - call stdlib_qcopy( n, c( j, 1 ), ldc, work( 1, j ), 1 ) + call stdlib_${ri}$copy( n, c( j, 1 ), ldc, work( 1, j ), 1 ) end do ! w := w * v1 - call stdlib_qtrmm( 'RIGHT', 'LOWER', 'NO TRANSPOSE', 'UNIT', n,k, one, v, ldv,& + call stdlib_${ri}$trmm( 'RIGHT', 'LOWER', 'NO TRANSPOSE', 'UNIT', n,k, one, v, ldv,& work, ldwork ) if( m>k ) then ! w := w + c2**t * v2 - call stdlib_qgemm( 'TRANSPOSE', 'NO TRANSPOSE', n, k, m-k,one, c( k+1, 1 ),& + call stdlib_${ri}$gemm( 'TRANSPOSE', 'NO TRANSPOSE', n, k, m-k,one, c( k+1, 1 ),& ldc, v( k+1, 1 ), ldv,one, work, ldwork ) end if ! w := w * t**t or w * t - call stdlib_qtrmm( 'RIGHT', 'UPPER', transt, 'NON-UNIT', n, k,one, t, ldt, & + call stdlib_${ri}$trmm( 'RIGHT', 'UPPER', transt, 'NON-UNIT', n, k,one, t, ldt, & work, ldwork ) ! c := c - v * w**t if( m>k ) then ! c2 := c2 - v2 * w**t - call stdlib_qgemm( 'NO TRANSPOSE', 'TRANSPOSE', m-k, n, k,-one, v( k+1, 1 )& + call stdlib_${ri}$gemm( 'NO TRANSPOSE', 'TRANSPOSE', m-k, n, k,-one, v( k+1, 1 )& , ldv, work, ldwork, one,c( k+1, 1 ), ldc ) end if ! w := w * v1**t - call stdlib_qtrmm( 'RIGHT', 'LOWER', 'TRANSPOSE', 'UNIT', n, k,one, v, ldv, & + call stdlib_${ri}$trmm( 'RIGHT', 'LOWER', 'TRANSPOSE', 'UNIT', n, k,one, v, ldv, & work, ldwork ) ! c1 := c1 - w**t do j = 1, k @@ -38263,27 +38264,27 @@ module stdlib_linalg_lapack_q ! w := c * v = (c1*v1 + c2*v2) (stored in work) ! w := c1 do j = 1, k - call stdlib_qcopy( m, c( 1, j ), 1, work( 1, j ), 1 ) + call stdlib_${ri}$copy( m, c( 1, j ), 1, work( 1, j ), 1 ) end do ! w := w * v1 - call stdlib_qtrmm( 'RIGHT', 'LOWER', 'NO TRANSPOSE', 'UNIT', m,k, one, v, ldv,& + call stdlib_${ri}$trmm( 'RIGHT', 'LOWER', 'NO TRANSPOSE', 'UNIT', m,k, one, v, ldv,& work, ldwork ) if( n>k ) then ! w := w + c2 * v2 - call stdlib_qgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', m, k, n-k,one, c( 1, k+& + call stdlib_${ri}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', m, k, n-k,one, c( 1, k+& 1 ), ldc, v( k+1, 1 ), ldv,one, work, ldwork ) end if ! w := w * t or w * t**t - call stdlib_qtrmm( 'RIGHT', 'UPPER', trans, 'NON-UNIT', m, k,one, t, ldt, & + call stdlib_${ri}$trmm( 'RIGHT', 'UPPER', trans, 'NON-UNIT', m, k,one, t, ldt, & work, ldwork ) ! c := c - w * v**t if( n>k ) then ! c2 := c2 - w * v2**t - call stdlib_qgemm( 'NO TRANSPOSE', 'TRANSPOSE', m, n-k, k,-one, work, & + call stdlib_${ri}$gemm( 'NO TRANSPOSE', 'TRANSPOSE', m, n-k, k,-one, work, & ldwork, v( k+1, 1 ), ldv, one,c( 1, k+1 ), ldc ) end if ! w := w * v1**t - call stdlib_qtrmm( 'RIGHT', 'LOWER', 'TRANSPOSE', 'UNIT', m, k,one, v, ldv, & + call stdlib_${ri}$trmm( 'RIGHT', 'LOWER', 'TRANSPOSE', 'UNIT', m, k,one, v, ldv, & work, ldwork ) ! c1 := c1 - w do j = 1, k @@ -38302,27 +38303,27 @@ module stdlib_linalg_lapack_q ! w := c**t * v = (c1**t * v1 + c2**t * v2) (stored in work) ! w := c2**t do j = 1, k - call stdlib_qcopy( n, c( m-k+j, 1 ), ldc, work( 1, j ), 1 ) + call stdlib_${ri}$copy( n, c( m-k+j, 1 ), ldc, work( 1, j ), 1 ) end do ! w := w * v2 - call stdlib_qtrmm( 'RIGHT', 'UPPER', 'NO TRANSPOSE', 'UNIT', n,k, one, v( m-k+& + call stdlib_${ri}$trmm( 'RIGHT', 'UPPER', 'NO TRANSPOSE', 'UNIT', n,k, one, v( m-k+& 1, 1 ), ldv, work, ldwork ) if( m>k ) then ! w := w + c1**t * v1 - call stdlib_qgemm( 'TRANSPOSE', 'NO TRANSPOSE', n, k, m-k,one, c, ldc, v, & + call stdlib_${ri}$gemm( 'TRANSPOSE', 'NO TRANSPOSE', n, k, m-k,one, c, ldc, v, & ldv, one, work, ldwork ) end if ! w := w * t**t or w * t - call stdlib_qtrmm( 'RIGHT', 'LOWER', transt, 'NON-UNIT', n, k,one, t, ldt, & + call stdlib_${ri}$trmm( 'RIGHT', 'LOWER', transt, 'NON-UNIT', n, k,one, t, ldt, & work, ldwork ) ! c := c - v * w**t if( m>k ) then ! c1 := c1 - v1 * w**t - call stdlib_qgemm( 'NO TRANSPOSE', 'TRANSPOSE', m-k, n, k,-one, v, ldv, & + call stdlib_${ri}$gemm( 'NO TRANSPOSE', 'TRANSPOSE', m-k, n, k,-one, v, ldv, & work, ldwork, one, c, ldc ) end if ! w := w * v2**t - call stdlib_qtrmm( 'RIGHT', 'UPPER', 'TRANSPOSE', 'UNIT', n, k,one, v( m-k+1, & + call stdlib_${ri}$trmm( 'RIGHT', 'UPPER', 'TRANSPOSE', 'UNIT', n, k,one, v( m-k+1, & 1 ), ldv, work, ldwork ) ! c2 := c2 - w**t do j = 1, k @@ -38335,27 +38336,27 @@ module stdlib_linalg_lapack_q ! w := c * v = (c1*v1 + c2*v2) (stored in work) ! w := c2 do j = 1, k - call stdlib_qcopy( m, c( 1, n-k+j ), 1, work( 1, j ), 1 ) + call stdlib_${ri}$copy( m, c( 1, n-k+j ), 1, work( 1, j ), 1 ) end do ! w := w * v2 - call stdlib_qtrmm( 'RIGHT', 'UPPER', 'NO TRANSPOSE', 'UNIT', m,k, one, v( n-k+& + call stdlib_${ri}$trmm( 'RIGHT', 'UPPER', 'NO TRANSPOSE', 'UNIT', m,k, one, v( n-k+& 1, 1 ), ldv, work, ldwork ) if( n>k ) then ! w := w + c1 * v1 - call stdlib_qgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', m, k, n-k,one, c, ldc, & + call stdlib_${ri}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', m, k, n-k,one, c, ldc, & v, ldv, one, work, ldwork ) end if ! w := w * t or w * t**t - call stdlib_qtrmm( 'RIGHT', 'LOWER', trans, 'NON-UNIT', m, k,one, t, ldt, & + call stdlib_${ri}$trmm( 'RIGHT', 'LOWER', trans, 'NON-UNIT', m, k,one, t, ldt, & work, ldwork ) ! c := c - w * v**t if( n>k ) then ! c1 := c1 - w * v1**t - call stdlib_qgemm( 'NO TRANSPOSE', 'TRANSPOSE', m, n-k, k,-one, work, & + call stdlib_${ri}$gemm( 'NO TRANSPOSE', 'TRANSPOSE', m, n-k, k,-one, work, & ldwork, v, ldv, one, c, ldc ) end if ! w := w * v2**t - call stdlib_qtrmm( 'RIGHT', 'UPPER', 'TRANSPOSE', 'UNIT', m, k,one, v( n-k+1, & + call stdlib_${ri}$trmm( 'RIGHT', 'UPPER', 'TRANSPOSE', 'UNIT', m, k,one, v( n-k+1, & 1 ), ldv, work, ldwork ) ! c2 := c2 - w do j = 1, k @@ -38375,27 +38376,27 @@ module stdlib_linalg_lapack_q ! w := c**t * v**t = (c1**t * v1**t + c2**t * v2**t) (stored in work) ! w := c1**t do j = 1, k - call stdlib_qcopy( n, c( j, 1 ), ldc, work( 1, j ), 1 ) + call stdlib_${ri}$copy( n, c( j, 1 ), ldc, work( 1, j ), 1 ) end do ! w := w * v1**t - call stdlib_qtrmm( 'RIGHT', 'UPPER', 'TRANSPOSE', 'UNIT', n, k,one, v, ldv, & + call stdlib_${ri}$trmm( 'RIGHT', 'UPPER', 'TRANSPOSE', 'UNIT', n, k,one, v, ldv, & work, ldwork ) if( m>k ) then ! w := w + c2**t * v2**t - call stdlib_qgemm( 'TRANSPOSE', 'TRANSPOSE', n, k, m-k, one,c( k+1, 1 ), & + call stdlib_${ri}$gemm( 'TRANSPOSE', 'TRANSPOSE', n, k, m-k, one,c( k+1, 1 ), & ldc, v( 1, k+1 ), ldv, one,work, ldwork ) end if ! w := w * t**t or w * t - call stdlib_qtrmm( 'RIGHT', 'UPPER', transt, 'NON-UNIT', n, k,one, t, ldt, & + call stdlib_${ri}$trmm( 'RIGHT', 'UPPER', transt, 'NON-UNIT', n, k,one, t, ldt, & work, ldwork ) ! c := c - v**t * w**t if( m>k ) then ! c2 := c2 - v2**t * w**t - call stdlib_qgemm( 'TRANSPOSE', 'TRANSPOSE', m-k, n, k, -one,v( 1, k+1 ), & + call stdlib_${ri}$gemm( 'TRANSPOSE', 'TRANSPOSE', m-k, n, k, -one,v( 1, k+1 ), & ldv, work, ldwork, one,c( k+1, 1 ), ldc ) end if ! w := w * v1 - call stdlib_qtrmm( 'RIGHT', 'UPPER', 'NO TRANSPOSE', 'UNIT', n,k, one, v, ldv,& + call stdlib_${ri}$trmm( 'RIGHT', 'UPPER', 'NO TRANSPOSE', 'UNIT', n,k, one, v, ldv,& work, ldwork ) ! c1 := c1 - w**t do j = 1, k @@ -38408,27 +38409,27 @@ module stdlib_linalg_lapack_q ! w := c * v**t = (c1*v1**t + c2*v2**t) (stored in work) ! w := c1 do j = 1, k - call stdlib_qcopy( m, c( 1, j ), 1, work( 1, j ), 1 ) + call stdlib_${ri}$copy( m, c( 1, j ), 1, work( 1, j ), 1 ) end do ! w := w * v1**t - call stdlib_qtrmm( 'RIGHT', 'UPPER', 'TRANSPOSE', 'UNIT', m, k,one, v, ldv, & + call stdlib_${ri}$trmm( 'RIGHT', 'UPPER', 'TRANSPOSE', 'UNIT', m, k,one, v, ldv, & work, ldwork ) if( n>k ) then ! w := w + c2 * v2**t - call stdlib_qgemm( 'NO TRANSPOSE', 'TRANSPOSE', m, k, n-k,one, c( 1, k+1 ),& + call stdlib_${ri}$gemm( 'NO TRANSPOSE', 'TRANSPOSE', m, k, n-k,one, c( 1, k+1 ),& ldc, v( 1, k+1 ), ldv,one, work, ldwork ) end if ! w := w * t or w * t**t - call stdlib_qtrmm( 'RIGHT', 'UPPER', trans, 'NON-UNIT', m, k,one, t, ldt, & + call stdlib_${ri}$trmm( 'RIGHT', 'UPPER', trans, 'NON-UNIT', m, k,one, t, ldt, & work, ldwork ) ! c := c - w * v if( n>k ) then ! c2 := c2 - w * v2 - call stdlib_qgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', m, n-k, k,-one, work, & + call stdlib_${ri}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', m, n-k, k,-one, work, & ldwork, v( 1, k+1 ), ldv, one,c( 1, k+1 ), ldc ) end if ! w := w * v1 - call stdlib_qtrmm( 'RIGHT', 'UPPER', 'NO TRANSPOSE', 'UNIT', m,k, one, v, ldv,& + call stdlib_${ri}$trmm( 'RIGHT', 'UPPER', 'NO TRANSPOSE', 'UNIT', m,k, one, v, ldv,& work, ldwork ) ! c1 := c1 - w do j = 1, k @@ -38446,27 +38447,27 @@ module stdlib_linalg_lapack_q ! w := c**t * v**t = (c1**t * v1**t + c2**t * v2**t) (stored in work) ! w := c2**t do j = 1, k - call stdlib_qcopy( n, c( m-k+j, 1 ), ldc, work( 1, j ), 1 ) + call stdlib_${ri}$copy( n, c( m-k+j, 1 ), ldc, work( 1, j ), 1 ) end do ! w := w * v2**t - call stdlib_qtrmm( 'RIGHT', 'LOWER', 'TRANSPOSE', 'UNIT', n, k,one, v( 1, m-k+& + call stdlib_${ri}$trmm( 'RIGHT', 'LOWER', 'TRANSPOSE', 'UNIT', n, k,one, v( 1, m-k+& 1 ), ldv, work, ldwork ) if( m>k ) then ! w := w + c1**t * v1**t - call stdlib_qgemm( 'TRANSPOSE', 'TRANSPOSE', n, k, m-k, one,c, ldc, v, ldv,& + call stdlib_${ri}$gemm( 'TRANSPOSE', 'TRANSPOSE', n, k, m-k, one,c, ldc, v, ldv,& one, work, ldwork ) end if ! w := w * t**t or w * t - call stdlib_qtrmm( 'RIGHT', 'LOWER', transt, 'NON-UNIT', n, k,one, t, ldt, & + call stdlib_${ri}$trmm( 'RIGHT', 'LOWER', transt, 'NON-UNIT', n, k,one, t, ldt, & work, ldwork ) ! c := c - v**t * w**t if( m>k ) then ! c1 := c1 - v1**t * w**t - call stdlib_qgemm( 'TRANSPOSE', 'TRANSPOSE', m-k, n, k, -one,v, ldv, work, & + call stdlib_${ri}$gemm( 'TRANSPOSE', 'TRANSPOSE', m-k, n, k, -one,v, ldv, work, & ldwork, one, c, ldc ) end if ! w := w * v2 - call stdlib_qtrmm( 'RIGHT', 'LOWER', 'NO TRANSPOSE', 'UNIT', n,k, one, v( 1, & + call stdlib_${ri}$trmm( 'RIGHT', 'LOWER', 'NO TRANSPOSE', 'UNIT', n,k, one, v( 1, & m-k+1 ), ldv, work, ldwork ) ! c2 := c2 - w**t do j = 1, k @@ -38479,27 +38480,27 @@ module stdlib_linalg_lapack_q ! w := c * v**t = (c1*v1**t + c2*v2**t) (stored in work) ! w := c2 do j = 1, k - call stdlib_qcopy( m, c( 1, n-k+j ), 1, work( 1, j ), 1 ) + call stdlib_${ri}$copy( m, c( 1, n-k+j ), 1, work( 1, j ), 1 ) end do ! w := w * v2**t - call stdlib_qtrmm( 'RIGHT', 'LOWER', 'TRANSPOSE', 'UNIT', m, k,one, v( 1, n-k+& + call stdlib_${ri}$trmm( 'RIGHT', 'LOWER', 'TRANSPOSE', 'UNIT', m, k,one, v( 1, n-k+& 1 ), ldv, work, ldwork ) if( n>k ) then ! w := w + c1 * v1**t - call stdlib_qgemm( 'NO TRANSPOSE', 'TRANSPOSE', m, k, n-k,one, c, ldc, v, & + call stdlib_${ri}$gemm( 'NO TRANSPOSE', 'TRANSPOSE', m, k, n-k,one, c, ldc, v, & ldv, one, work, ldwork ) end if ! w := w * t or w * t**t - call stdlib_qtrmm( 'RIGHT', 'LOWER', trans, 'NON-UNIT', m, k,one, t, ldt, & + call stdlib_${ri}$trmm( 'RIGHT', 'LOWER', trans, 'NON-UNIT', m, k,one, t, ldt, & work, ldwork ) ! c := c - w * v if( n>k ) then ! c1 := c1 - w * v1 - call stdlib_qgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', m, n-k, k,-one, work, & + call stdlib_${ri}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', m, n-k, k,-one, work, & ldwork, v, ldv, one, c, ldc ) end if ! w := w * v2 - call stdlib_qtrmm( 'RIGHT', 'LOWER', 'NO TRANSPOSE', 'UNIT', m,k, one, v( 1, & + call stdlib_${ri}$trmm( 'RIGHT', 'LOWER', 'NO TRANSPOSE', 'UNIT', m,k, one, v( 1, & n-k+1 ), ldv, work, ldwork ) ! c1 := c1 - w do j = 1, k @@ -38511,10 +38512,10 @@ module stdlib_linalg_lapack_q end if end if return - end subroutine stdlib_qlarfb + end subroutine stdlib_${ri}$larfb - pure subroutine stdlib_qlarfb_gett( ident, m, n, k, t, ldt, a, lda, b, ldb,work, ldwork ) + pure subroutine stdlib_${ri}$larfb_gett( ident, m, n, k, t, ldt, a, lda, b, ldb,work, ldwork ) !! DLARFB_GETT: applies a real Householder block reflector H from the !! left to a real (K+M)-by-N "triangular-pentagonal" matrix !! composed of two block matrices: an upper trapezoidal K-by-N matrix A @@ -38530,9 +38531,9 @@ module stdlib_linalg_lapack_q character, intent(in) :: ident integer(ilp), intent(in) :: k, lda, ldb, ldt, ldwork, m, n ! Array Arguments - real(qp), intent(inout) :: a(lda,*), b(ldb,*) - real(qp), intent(in) :: t(ldt,*) - real(qp), intent(out) :: work(ldwork,*) + real(${rk}$), intent(inout) :: a(lda,*), b(ldb,*) + real(${rk}$), intent(in) :: t(ldt,*) + real(${rk}$), intent(out) :: work(ldwork,*) ! ===================================================================== ! Local Scalars @@ -38551,34 +38552,34 @@ module stdlib_linalg_lapack_q ! col2_(1) compute w2: = a2. therefore, copy a2 = a(1:k, k+1:n) ! into w2=work(1:k, 1:n-k) column-by-column. do j = 1, n-k - call stdlib_qcopy( k, a( 1, k+j ), 1, work( 1, j ), 1 ) + call stdlib_${ri}$copy( k, a( 1, k+j ), 1, work( 1, j ), 1 ) end do if( lnotident ) then ! col2_(2) compute w2: = (v1**t) * w2 = (a1**t) * w2, ! v1 is not an identy matrix, but unit lower-triangular ! v1 stored in a1 (diagonal ones are not stored). - call stdlib_qtrmm( 'L', 'L', 'T', 'U', k, n-k, one, a, lda,work, ldwork ) + call stdlib_${ri}$trmm( 'L', 'L', 'T', 'U', k, n-k, one, a, lda,work, ldwork ) end if ! col2_(3) compute w2: = w2 + (v2**t) * b2 = w2 + (b1**t) * b2 ! v2 stored in b1. if( m>0 ) then - call stdlib_qgemm( 'T', 'N', k, n-k, m, one, b, ldb,b( 1, k+1 ), ldb, one, work, & + call stdlib_${ri}$gemm( 'T', 'N', k, n-k, m, one, b, ldb,b( 1, k+1 ), ldb, one, work, & ldwork ) end if ! col2_(4) compute w2: = t * w2, ! t is upper-triangular. - call stdlib_qtrmm( 'L', 'U', 'N', 'N', k, n-k, one, t, ldt,work, ldwork ) + call stdlib_${ri}$trmm( 'L', 'U', 'N', 'N', k, n-k, one, t, ldt,work, ldwork ) ! col2_(5) compute b2: = b2 - v2 * w2 = b2 - b1 * w2, ! v2 stored in b1. if( m>0 ) then - call stdlib_qgemm( 'N', 'N', m, n-k, k, -one, b, ldb,work, ldwork, one, b( 1, k+& + call stdlib_${ri}$gemm( 'N', 'N', m, n-k, k, -one, b, ldb,work, ldwork, one, b( 1, k+& 1 ), ldb ) end if if( lnotident ) then ! col2_(6) compute w2: = v1 * w2 = a1 * w2, ! v1 is not an identity matrix, but unit lower-triangular, ! v1 stored in a1 (diagonal ones are not stored). - call stdlib_qtrmm( 'L', 'L', 'N', 'U', k, n-k, one, a, lda,work, ldwork ) + call stdlib_${ri}$trmm( 'L', 'L', 'N', 'U', k, n-k, one, a, lda,work, ldwork ) end if ! col2_(7) compute a2: = a2 - w2 = ! = a(1:k, k+1:n-k) - work(1:k, 1:n-k), @@ -38598,7 +38599,7 @@ module stdlib_linalg_lapack_q ! a1 = a(1:k, 1:k) into the upper-triangular ! w1 = work(1:k, 1:k) column-by-column. do j = 1, k - call stdlib_qcopy( j, a( 1, j ), 1, work( 1, j ), 1 ) + call stdlib_${ri}$copy( j, a( 1, j ), 1, work( 1, j ), 1 ) end do ! set the subdiagonal elements of w1 to zero column-by-column. do j = 1, k - 1 @@ -38611,16 +38612,16 @@ module stdlib_linalg_lapack_q ! v1 is not an identity matrix, but unit lower-triangular ! v1 stored in a1 (diagonal ones are not stored), ! w1 is upper-triangular with zeroes below the diagonal. - call stdlib_qtrmm( 'L', 'L', 'T', 'U', k, k, one, a, lda,work, ldwork ) + call stdlib_${ri}$trmm( 'L', 'L', 'T', 'U', k, k, one, a, lda,work, ldwork ) end if ! col1_(3) compute w1: = t * w1, ! t is upper-triangular, ! w1 is upper-triangular with zeroes below the diagonal. - call stdlib_qtrmm( 'L', 'U', 'N', 'N', k, k, one, t, ldt,work, ldwork ) + call stdlib_${ri}$trmm( 'L', 'U', 'N', 'N', k, k, one, t, ldt,work, ldwork ) ! col1_(4) compute b1: = - v2 * w1 = - b1 * w1, ! v2 = b1, w1 is upper-triangular with zeroes below the diagonal. if( m>0 ) then - call stdlib_qtrmm( 'R', 'U', 'N', 'N', m, k, -one, work, ldwork,b, ldb ) + call stdlib_${ri}$trmm( 'R', 'U', 'N', 'N', m, k, -one, work, ldwork,b, ldb ) end if if( lnotident ) then ! col1_(5) compute w1: = v1 * w1 = a1 * w1, @@ -38628,7 +38629,7 @@ module stdlib_linalg_lapack_q ! v1 stored in a1 (diagonal ones are not stored), ! w1 is upper-triangular on input with zeroes below the diagonal, ! and square on output. - call stdlib_qtrmm( 'L', 'L', 'N', 'U', k, k, one, a, lda,work, ldwork ) + call stdlib_${ri}$trmm( 'L', 'L', 'N', 'U', k, k, one, a, lda,work, ldwork ) ! col1_(6) compute a1: = a1 - w1 = a(1:k, 1:k) - work(1:k, 1:k) ! column-by-column. a1 is upper-triangular on input. ! if ident, a1 is square on output, and w1 is square, @@ -38648,10 +38649,10 @@ module stdlib_linalg_lapack_q end do end do return - end subroutine stdlib_qlarfb_gett + end subroutine stdlib_${ri}$larfb_gett - pure subroutine stdlib_qlarfg( n, alpha, x, incx, tau ) + pure subroutine stdlib_${ri}$larfg( n, alpha, x, incx, tau ) !! DLARFG: generates a real elementary reflector H of order n, such !! that !! H * ( alpha ) = ( beta ), H**T * H = I. @@ -38670,15 +38671,15 @@ module stdlib_linalg_lapack_q ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments integer(ilp), intent(in) :: incx, n - real(qp), intent(inout) :: alpha - real(qp), intent(out) :: tau + real(${rk}$), intent(inout) :: alpha + real(${rk}$), intent(out) :: tau ! Array Arguments - real(qp), intent(inout) :: x(*) + real(${rk}$), intent(inout) :: x(*) ! ===================================================================== ! Local Scalars integer(ilp) :: j, knt - real(qp) :: beta, rsafmn, safmin, xnorm + real(${rk}$) :: beta, rsafmn, safmin, xnorm ! Intrinsic Functions intrinsic :: abs,sign ! Executable Statements @@ -38686,30 +38687,30 @@ module stdlib_linalg_lapack_q tau = zero return end if - xnorm = stdlib_qnrm2( n-1, x, incx ) + xnorm = stdlib_${ri}$nrm2( n-1, x, incx ) if( xnorm==zero ) then ! h = i tau = zero else ! general case - beta = -sign( stdlib_qlapy2( alpha, xnorm ), alpha ) - safmin = stdlib_qlamch( 'S' ) / stdlib_qlamch( 'E' ) + beta = -sign( stdlib_${ri}$lapy2( alpha, xnorm ), alpha ) + safmin = stdlib_${ri}$lamch( 'S' ) / stdlib_${ri}$lamch( 'E' ) knt = 0 if( abs( beta )= 0 if( alpha>=zero ) then @@ -38773,21 +38774,21 @@ module stdlib_linalg_lapack_q end if else ! general case - beta = sign( stdlib_qlapy2( alpha, xnorm ), alpha ) - smlnum = stdlib_qlamch( 'S' ) / stdlib_qlamch( 'E' ) + beta = sign( stdlib_${ri}$lapy2( alpha, xnorm ), alpha ) + smlnum = stdlib_${ri}$lamch( 'S' ) / stdlib_${ri}$lamch( 'E' ) knt = 0 if( abs( beta )1 ) then @@ -38923,7 +38924,7 @@ module stdlib_linalg_lapack_q end do j = max( lastv, prevlastv ) ! t(i+1:k,i) = -tau(i) * v(j:n-k+i,i+1:k)**t * v(j:n-k+i,i) - call stdlib_qgemv( 'TRANSPOSE', n-k+i-j, k-i, -tau( i ),v( j, i+1 ), & + call stdlib_${ri}$gemv( 'TRANSPOSE', n-k+i-j, k-i, -tau( i ),v( j, i+1 ), & ldv, v( j, i ), 1, one,t( i+1, i ), 1 ) else ! skip any leading zeros. @@ -38935,11 +38936,11 @@ module stdlib_linalg_lapack_q end do j = max( lastv, prevlastv ) ! t(i+1:k,i) = -tau(i) * v(i+1:k,j:n-k+i) * v(i,j:n-k+i)**t - call stdlib_qgemv( 'NO TRANSPOSE', k-i, n-k+i-j,-tau( i ), v( i+1, j ), & + call stdlib_${ri}$gemv( 'NO TRANSPOSE', k-i, n-k+i-j,-tau( i ), v( i+1, j ), & ldv, v( i, j ), ldv,one, t( i+1, i ), 1 ) end if ! t(i+1:k,i) := t(i+1:k,i+1:k) * t(i+1:k,i) - call stdlib_qtrmv( 'LOWER', 'NO TRANSPOSE', 'NON-UNIT', k-i,t( i+1, i+1 ), & + call stdlib_${ri}$trmv( 'LOWER', 'NO TRANSPOSE', 'NON-UNIT', k-i,t( i+1, i+1 ), & ldt, t( i+1, i ), 1 ) if( i>1 ) then prevlastv = min( prevlastv, lastv ) @@ -38952,10 +38953,10 @@ module stdlib_linalg_lapack_q end do end if return - end subroutine stdlib_qlarft + end subroutine stdlib_${ri}$larft - pure subroutine stdlib_qlarfx( side, m, n, v, tau, c, ldc, work ) + pure subroutine stdlib_${ri}$larfx( side, m, n, v, tau, c, ldc, work ) !! DLARFX: applies a real elementary reflector H to a real m by n !! matrix C, from either the left or the right. H is represented in the !! form @@ -38969,16 +38970,16 @@ module stdlib_linalg_lapack_q ! Scalar Arguments character, intent(in) :: side integer(ilp), intent(in) :: ldc, m, n - real(qp), intent(in) :: tau + real(${rk}$), intent(in) :: tau ! Array Arguments - real(qp), intent(inout) :: c(ldc,*) - real(qp), intent(in) :: v(*) - real(qp), intent(out) :: work(*) + real(${rk}$), intent(inout) :: c(ldc,*) + real(${rk}$), intent(in) :: v(*) + real(${rk}$), intent(out) :: work(*) ! ===================================================================== ! Local Scalars integer(ilp) :: j - real(qp) :: sum, t1, t10, t2, t3, t4, t5, t6, t7, t8, t9, v1, v10, v2, v3, v4, v5, v6, & + real(${rk}$) :: sum, t1, t10, t2, t3, t4, t5, t6, t7, t8, t9, v1, v10, v2, v3, v4, v5, v6, & v7, v8, v9 ! Executable Statements if( tau==zero )return @@ -38986,7 +38987,7 @@ module stdlib_linalg_lapack_q ! form h * c, where h has order m. go to ( 10, 30, 50, 70, 90, 110, 130, 150,170, 190 )m ! code for general m - call stdlib_qlarf( side, m, n, v, 1, tau, c, ldc, work ) + call stdlib_${ri}$larf( side, m, n, v, 1, tau, c, ldc, work ) go to 410 10 continue ! special code for 1 x 1 householder @@ -39221,7 +39222,7 @@ module stdlib_linalg_lapack_q ! form c * h, where h has order n. go to ( 210, 230, 250, 270, 290, 310, 330, 350,370, 390 )n ! code for general n - call stdlib_qlarf( side, m, n, v, 1, tau, c, ldc, work ) + call stdlib_${ri}$larf( side, m, n, v, 1, tau, c, ldc, work ) go to 410 210 continue ! special code for 1 x 1 householder @@ -39455,10 +39456,10 @@ module stdlib_linalg_lapack_q end if 410 continue return - end subroutine stdlib_qlarfx + end subroutine stdlib_${ri}$larfx - pure subroutine stdlib_qlarfy( uplo, n, v, incv, tau, c, ldc, work ) + pure subroutine stdlib_${ri}$larfy( uplo, n, v, incv, tau, c, ldc, work ) !! DLARFY: applies an elementary reflector, or Householder matrix, H, !! to an n x n symmetric matrix C, from both the left and the right. !! H is represented in the form @@ -39471,28 +39472,28 @@ module stdlib_linalg_lapack_q ! Scalar Arguments character, intent(in) :: uplo integer(ilp), intent(in) :: incv, ldc, n - real(qp), intent(in) :: tau + real(${rk}$), intent(in) :: tau ! Array Arguments - real(qp), intent(inout) :: c(ldc,*) - real(qp), intent(in) :: v(*) - real(qp), intent(out) :: work(*) + real(${rk}$), intent(inout) :: c(ldc,*) + real(${rk}$), intent(in) :: v(*) + real(${rk}$), intent(out) :: work(*) ! ===================================================================== ! Local Scalars - real(qp) :: alpha + real(${rk}$) :: alpha ! Executable Statements if( tau==zero )return ! form w:= c * v - call stdlib_qsymv( uplo, n, one, c, ldc, v, incv, zero, work, 1 ) - alpha = -half*tau*stdlib_qdot( n, work, 1, v, incv ) - call stdlib_qaxpy( n, alpha, v, incv, work, 1 ) + call stdlib_${ri}$symv( uplo, n, one, c, ldc, v, incv, zero, work, 1 ) + alpha = -half*tau*stdlib_${ri}$dot( n, work, 1, v, incv ) + call stdlib_${ri}$axpy( n, alpha, v, incv, work, 1 ) ! c := c - v * w' - w * v' - call stdlib_qsyr2( uplo, n, -tau, v, incv, work, 1, c, ldc ) + call stdlib_${ri}$syr2( uplo, n, -tau, v, incv, work, 1, c, ldc ) return - end subroutine stdlib_qlarfy + end subroutine stdlib_${ri}$larfy - pure subroutine stdlib_qlargv( n, x, incx, y, incy, c, incc ) + pure subroutine stdlib_${ri}$largv( n, x, incx, y, incy, c, incc ) !! DLARGV: generates a vector of real plane rotations, determined by !! elements of the real vectors x and y. For i = 1,2,...,n !! ( c(i) s(i) ) ( x(i) ) = ( a(i) ) @@ -39503,13 +39504,13 @@ module stdlib_linalg_lapack_q ! Scalar Arguments integer(ilp), intent(in) :: incc, incx, incy, n ! Array Arguments - real(qp), intent(out) :: c(*) - real(qp), intent(inout) :: x(*), y(*) + real(${rk}$), intent(out) :: c(*) + real(${rk}$), intent(inout) :: x(*), y(*) ! ===================================================================== ! Local Scalars integer(ilp) :: i, ic, ix, iy - real(qp) :: f, g, t, tt + real(${rk}$) :: f, g, t, tt ! Intrinsic Functions intrinsic :: abs,sqrt ! Executable Statements @@ -39543,10 +39544,10 @@ module stdlib_linalg_lapack_q ix = ix + incx end do loop_10 return - end subroutine stdlib_qlargv + end subroutine stdlib_${ri}$largv - pure subroutine stdlib_qlarnv( idist, iseed, n, x ) + pure subroutine stdlib_${ri}$larnv( idist, iseed, n, x ) !! DLARNV: returns a vector of n random real numbers from a uniform or !! normal distribution. ! -- lapack auxiliary routine -- @@ -39556,18 +39557,18 @@ module stdlib_linalg_lapack_q integer(ilp), intent(in) :: idist, n ! Array Arguments integer(ilp), intent(inout) :: iseed(4) - real(qp), intent(out) :: x(*) + real(${rk}$), intent(out) :: x(*) ! ===================================================================== ! Parameters integer(ilp), parameter :: lv = 128 - real(qp), parameter :: twopi = 6.28318530717958647692528676655900576839e+0_qp + real(${rk}$), parameter :: twopi = 6.28318530717958647692528676655900576839e+0_${rk}$ ! Local Scalars integer(ilp) :: i, il, il2, iv ! Local Arrays - real(qp) :: u(lv) + real(${rk}$) :: u(lv) ! Intrinsic Functions intrinsic :: cos,log,min,sqrt ! Executable Statements @@ -39578,9 +39579,9 @@ module stdlib_linalg_lapack_q else il2 = il end if - ! call stdlib_qlaruv to generate il2 numbers from a uniform (0,1) + ! call stdlib_${ri}$laruv to generate il2 numbers from a uniform (0,1) ! distribution (il2 <= lv) - call stdlib_qlaruv( iseed, il2, u ) + call stdlib_${ri}$laruv( iseed, il2, u ) if( idist==1 ) then ! copy generated numbers do i = 1, il @@ -39599,10 +39600,10 @@ module stdlib_linalg_lapack_q end if 40 continue return - end subroutine stdlib_qlarnv + end subroutine stdlib_${ri}$larnv - pure subroutine stdlib_qlarra( n, d, e, e2, spltol, tnrm,nsplit, isplit, info ) + pure subroutine stdlib_${ri}$larra( n, d, e, e2, spltol, tnrm,nsplit, isplit, info ) !! Compute the splitting points with threshold SPLTOL. !! DLARRA: sets any "small" off-diagonal elements to zero. ! -- lapack auxiliary routine -- @@ -39611,16 +39612,16 @@ module stdlib_linalg_lapack_q ! Scalar Arguments integer(ilp), intent(out) :: info, nsplit integer(ilp), intent(in) :: n - real(qp), intent(in) :: spltol, tnrm + real(${rk}$), intent(in) :: spltol, tnrm ! Array Arguments integer(ilp), intent(out) :: isplit(*) - real(qp), intent(in) :: d(*) - real(qp), intent(inout) :: e(*), e2(*) + real(${rk}$), intent(in) :: d(*) + real(${rk}$), intent(inout) :: e(*), e2(*) ! ===================================================================== ! Local Scalars integer(ilp) :: i - real(qp) :: eabs, tmp1 + real(${rk}$) :: eabs, tmp1 ! Intrinsic Functions intrinsic :: abs ! Executable Statements @@ -39657,10 +39658,10 @@ module stdlib_linalg_lapack_q endif isplit( nsplit ) = n return - end subroutine stdlib_qlarra + end subroutine stdlib_${ri}$larra - pure subroutine stdlib_qlarrb( n, d, lld, ifirst, ilast, rtol1,rtol2, offset, w, wgap, werr, & + pure subroutine stdlib_${ri}$larrb( n, d, lld, ifirst, ilast, rtol1,rtol2, offset, w, wgap, werr, & !! Given the relatively robust representation(RRR) L D L^T, DLARRB: !! does "limited" bisection to refine the eigenvalues of L D L^T, !! W( IFIRST-OFFSET ) through W( ILAST-OFFSET ), to more accuracy. Initial @@ -39676,18 +39677,18 @@ module stdlib_linalg_lapack_q ! Scalar Arguments integer(ilp), intent(in) :: ifirst, ilast, n, offset, twist integer(ilp), intent(out) :: info - real(qp), intent(in) :: pivmin, rtol1, rtol2, spdiam + real(${rk}$), intent(in) :: pivmin, rtol1, rtol2, spdiam ! Array Arguments integer(ilp), intent(out) :: iwork(*) - real(qp), intent(in) :: d(*), lld(*) - real(qp), intent(inout) :: w(*), werr(*), wgap(*) - real(qp), intent(out) :: work(*) + real(${rk}$), intent(in) :: d(*), lld(*) + real(${rk}$), intent(inout) :: w(*), werr(*), wgap(*) + real(${rk}$), intent(out) :: work(*) ! ===================================================================== integer(ilp) :: maxitr ! Local Scalars integer(ilp) :: i, i1, ii, ip, iter, k, negcnt, next, nint, olnint, prev, r - real(qp) :: back, cvrgd, gap, left, lgap, mid, mnwdth, rgap, right, tmp, width + real(${rk}$) :: back, cvrgd, gap, left, lgap, mid, mnwdth, rgap, right, tmp, width ! Intrinsic Functions intrinsic :: abs,max,min ! Executable Statements @@ -39725,7 +39726,7 @@ module stdlib_linalg_lapack_q ! do while( negcnt(left)>i-1 ) back = werr( ii ) 20 continue - negcnt = stdlib_qlaneg( n, d, lld, left, pivmin, r ) + negcnt = stdlib_${ri}$laneg( n, d, lld, left, pivmin, r ) if( negcnt>i-1 ) then left = left - back back = two*back @@ -39735,7 +39736,7 @@ module stdlib_linalg_lapack_q ! compute negcount from dstqds facto l+d+l+^t = l d l^t - right back = werr( ii ) 50 continue - negcnt = stdlib_qlaneg( n, d, lld, right, pivmin, r ) + negcnt = stdlib_${ri}$laneg( n, d, lld, right, pivmin, r ) if( negcnt= 2 ! compute local gerschgorin interval and use it as the initial - ! interval for stdlib_qlaebz + ! interval for stdlib_${ri}$laebz gu = d( ibegin ) gl = d( ibegin ) tmp1 = zero @@ -40217,7 +40218,7 @@ module stdlib_linalg_lapack_q ! find negcount of initial interval boundaries gl and gu work( n+1 ) = gl work( n+in+1 ) = gu - call stdlib_qlaebz( 1, 0, in, in, 1, nb, atoli, rtoli, pivmin,d( ibegin ), e( & + call stdlib_${ri}$laebz( 1, 0, in, in, 1, nb, atoli, rtoli, pivmin,d( ibegin ), e( & ibegin ), e2( ibegin ),idumma, work( n+1 ), work( n+2*in+1 ), im,iwork, w( m+1 ),& iblock( m+1 ), iinfo ) if( iinfo /= 0 ) then @@ -40230,7 +40231,7 @@ module stdlib_linalg_lapack_q ! compute eigenvalues itmax = int( ( log( gu-gl+pivmin )-log( pivmin ) ) /log( two ),KIND=ilp) + & 2 - call stdlib_qlaebz( 2, itmax, in, in, 1, nb, atoli, rtoli, pivmin,d( ibegin ), e(& + call stdlib_${ri}$laebz( 2, itmax, in, in, 1, nb, atoli, rtoli, pivmin,d( ibegin ), e(& ibegin ), e2( ibegin ),idumma, work( n+1 ), work( n+2*in+1 ), iout,iwork, w( m+& 1 ), iblock( m+1 ), iinfo ) if( iinfo /= 0 ) then @@ -40239,7 +40240,7 @@ module stdlib_linalg_lapack_q end if ! copy eigenvalues into w and iblock ! use -jblk for block number for unconverged eigenvalues. - ! loop over the number of output intervals from stdlib_qlaebz + ! loop over the number of output intervals from stdlib_${ri}$laebz do j = 1, iout ! eigenvalue approximation is middle point of interval tmp1 = half*( work( j+n )+work( j+in+n ) ) @@ -40394,10 +40395,10 @@ module stdlib_linalg_lapack_q if( ncnvrg )info = info + 1 if( toofew )info = info + 2 return - end subroutine stdlib_qlarrd + end subroutine stdlib_${ri}$larrd - pure subroutine stdlib_qlarre( range, n, vl, vu, il, iu, d, e, e2,rtol1, rtol2, spltol, & + pure subroutine stdlib_${ri}$larre( range, n, vl, vu, il, iu, d, e, e2,rtol1, rtol2, spltol, & !! To find the desired eigenvalues of a given real symmetric !! tridiagonal matrix T, DLARRE: sets any "small" off-diagonal !! elements to zero, and for each unreduced block T_i, it finds @@ -40419,21 +40420,21 @@ module stdlib_linalg_lapack_q character, intent(in) :: range integer(ilp), intent(in) :: il, iu, n integer(ilp), intent(out) :: info, m, nsplit - real(qp), intent(out) :: pivmin - real(qp), intent(in) :: rtol1, rtol2, spltol - real(qp), intent(inout) :: vl, vu + real(${rk}$), intent(out) :: pivmin + real(${rk}$), intent(in) :: rtol1, rtol2, spltol + real(${rk}$), intent(inout) :: vl, vu ! Array Arguments integer(ilp), intent(out) :: iblock(*), isplit(*), iwork(*), indexw(*) - real(qp), intent(inout) :: d(*), e(*), e2(*) - real(qp), intent(out) :: gers(*), w(*), werr(*), wgap(*), work(*) + real(${rk}$), intent(inout) :: d(*), e(*), e2(*) + real(${rk}$), intent(out) :: gers(*), w(*), werr(*), wgap(*), work(*) ! ===================================================================== ! Parameters - real(qp), parameter :: hndrd = 100.0_qp - real(qp), parameter :: pert = 8.0_qp - real(qp), parameter :: fourth = one/four - real(qp), parameter :: fac = half - real(qp), parameter :: maxgrowth = 64.0_qp - real(qp), parameter :: fudge = 2.0_qp + real(${rk}$), parameter :: hndrd = 100.0_${rk}$ + real(${rk}$), parameter :: pert = 8.0_${rk}$ + real(${rk}$), parameter :: fourth = one/four + real(${rk}$), parameter :: fac = half + real(${rk}$), parameter :: maxgrowth = 64.0_${rk}$ + real(${rk}$), parameter :: fudge = 2.0_${rk}$ integer(ilp), parameter :: maxtry = 6 integer(ilp), parameter :: allrng = 1 integer(ilp), parameter :: indrng = 2 @@ -40444,7 +40445,7 @@ module stdlib_linalg_lapack_q logical(lk) :: forceb, norep, usedqd integer(ilp) :: cnt, cnt1, cnt2, i, ibegin, idum, iend, iinfo, in, indl, indu, irange, & j, jblk, mb, mm, wbegin, wend - real(qp) :: avgap, bsrtol, clwdth, dmax, dpivot, eabs, emax, eold, eps, gl, gu, isleft,& + real(${rk}$) :: avgap, bsrtol, clwdth, dmax, dpivot, eabs, emax, eold, eps, gl, gu, isleft,& isrght, rtl, rtol, s1, s2, safmin, sgndef, sigma, spdiam, tau, tmp, tmp1 ! Local Arrays integer(ilp) :: iseed(4) @@ -40466,8 +40467,8 @@ module stdlib_linalg_lapack_q end if m = 0 ! get machine constants - safmin = stdlib_qlamch( 'S' ) - eps = stdlib_qlamch( 'P' ) + safmin = stdlib_${ri}$lamch( 'S' ) + eps = stdlib_${ri}$lamch( 'P' ) ! set parameters rtl = sqrt(eps) bsrtol = sqrt(eps) @@ -40517,7 +40518,7 @@ module stdlib_linalg_lapack_q ! estimate that is wrong by at most a factor of sqrt(2) spdiam = gu - gl ! compute splitting points - call stdlib_qlarra( n, d, e, e2, spltol, spdiam,nsplit, isplit, iinfo ) + call stdlib_${ri}$larra( n, d, e, e2, spltol, spdiam,nsplit, isplit, iinfo ) ! can force use of bisection instead of faster dqds. ! option left in the code for future multisection work. forceb = .false. @@ -40529,13 +40530,13 @@ module stdlib_linalg_lapack_q vl = gl vu = gu else - ! we call stdlib_qlarrd to find crude approximations to the eigenvalues + ! we call stdlib_${ri}$larrd to find crude approximations to the eigenvalues ! in the desired range. in case irange = indrng, we also obtain the ! interval (vl,vu] that contains all the wanted eigenvalues. ! an interval [left,right] has converged if ! right-left1) then - call stdlib_qlarrc( 'T', in, s1, s2, d(ibegin),e(ibegin), pivmin, cnt, cnt1, & + call stdlib_${ri}$larrc( 'T', in, s1, s2, d(ibegin),e(ibegin), pivmin, cnt, cnt1, & cnt2, iinfo) endif if(mb==1) then @@ -40727,7 +40728,7 @@ module stdlib_linalg_lapack_q else if(mb>1) then clwdth = w(wend) + werr(wend) - w(wbegin) - werr(wbegin) - avgap = abs(clwdth / real(wend-wbegin,KIND=qp)) + avgap = abs(clwdth / real(wend-wbegin,KIND=${rk}$)) if( sgndef==one ) then tau = half*max(wgap(wbegin),avgap) tau = max(tau,werr(wbegin)) @@ -40800,8 +40801,8 @@ module stdlib_linalg_lapack_q ! store the shift. e( iend ) = sigma ! store d and l. - call stdlib_qcopy( in, work, 1, d( ibegin ), 1 ) - call stdlib_qcopy( in-1, work( in+1 ), 1, e( ibegin ), 1 ) + call stdlib_${ri}$copy( in, work, 1, d( ibegin ), 1 ) + call stdlib_${ri}$copy( in-1, work( in+1 ), 1, e( ibegin ), 1 ) if(mb>1 ) then ! perturb each entry of the base representation by a small ! (but random) relative amount to overcome difficulties with @@ -40809,7 +40810,7 @@ module stdlib_linalg_lapack_q do i = 1, 4 iseed( i ) = 1 end do - call stdlib_qlarnv(2, iseed, 2*in-1, work(1)) + call stdlib_${ri}$larnv(2, iseed, 2*in-1, work(1)) do i = 1,in-1 d(ibegin+i-1) = d(ibegin+i-1)*(one+eps*pert*work(i)) e(ibegin+i-1) = e(ibegin+i-1)*(one+eps*pert*work(in+i)) @@ -40817,34 +40818,34 @@ module stdlib_linalg_lapack_q d(iend) = d(iend)*(one+eps*four*work(in)) endif ! don't update the gerschgorin intervals because keeping track - ! of the updates would be too much work in stdlib_qlarrv. + ! of the updates would be too much work in stdlib_${ri}$larrv. ! we update w instead and use it to locate the proper gerschgorin ! intervals. ! compute the required eigenvalues of l d l' by bisection or dqds if ( .not.usedqd ) then - ! if stdlib_qlarrd has been used, shift the eigenvalue approximations + ! if stdlib_${ri}$larrd has been used, shift the eigenvalue approximations ! according to their representation. this is necessary for - ! a uniform stdlib_qlarrv since dqds computes eigenvalues of the - ! shifted representation. in stdlib_qlarrv, w will always hold the + ! a uniform stdlib_${ri}$larrv since dqds computes eigenvalues of the + ! shifted representation. in stdlib_${ri}$larrv, w will always hold the ! unshifted eigenvalue approximation. do j=wbegin,wend w(j) = w(j) - sigma werr(j) = werr(j) + abs(w(j)) * eps end do - ! call stdlib_qlarrb to reduce eigenvalue error of the approximations - ! from stdlib_qlarrd + ! call stdlib_${ri}$larrb to reduce eigenvalue error of the approximations + ! from stdlib_${ri}$larrd do i = ibegin, iend-1 work( i ) = d( i ) * e( i )**2 end do ! use bisection to find ev from indl to indu - call stdlib_qlarrb(in, d(ibegin), work(ibegin),indl, indu, rtol1, rtol2, indl-1,& + call stdlib_${ri}$larrb(in, d(ibegin), work(ibegin),indl, indu, rtol1, rtol2, indl-1,& w(wbegin), wgap(wbegin), werr(wbegin),work( 2*n+1 ), iwork, pivmin, spdiam,in, & iinfo ) if( iinfo /= 0 ) then info = -4 return end if - ! stdlib_qlarrb computes all gaps correctly except for the last one + ! stdlib_${ri}$larrb computes all gaps correctly except for the last one ! record distance to vu/gu wgap( wend ) = max( zero,( vu-sigma ) - ( w( wend ) + werr( wend ) ) ) do i = indl, indu @@ -40860,11 +40861,11 @@ module stdlib_linalg_lapack_q ! might be lost when the shift of the rrr is subtracted to obtain ! the eigenvalues of t. however, t is not guaranteed to define its ! eigenvalues to high relative accuracy anyway. - ! set rtol to the order of the tolerance used in stdlib_qlasq2 + ! set rtol to the order of the tolerance used in stdlib_${ri}$lasq2 ! this is an estimated error, the worst case bound is 4*n*eps ! which is usually too large and requires unnecessary work to be ! done by bisection when computing the eigenvectors - rtol = log(real(in,KIND=qp)) * four * eps + rtol = log(real(in,KIND=${rk}$)) * four * eps j = ibegin do i = 1, in - 1 work( 2*i-1 ) = abs( d( j ) ) @@ -40873,7 +40874,7 @@ module stdlib_linalg_lapack_q end do work( 2*in-1 ) = abs( d( iend ) ) work( 2*in ) = zero - call stdlib_qlasq2( in, work, iinfo ) + call stdlib_${ri}$lasq2( in, work, iinfo ) if( iinfo /= 0 ) then ! if iinfo = -5 then an index is part of a tight cluster ! and should be changed. the index is in iwork(1) and the @@ -40905,7 +40906,7 @@ module stdlib_linalg_lapack_q end do end if do i = m - mb + 1, m - ! the value of rtol below should be the tolerance in stdlib_qlasq2 + ! the value of rtol below should be the tolerance in stdlib_${ri}$lasq2 werr( i ) = rtol * abs( w(i) ) end do do i = m - mb + 1, m - 1 @@ -40919,10 +40920,10 @@ module stdlib_linalg_lapack_q wbegin = wend + 1 end do loop_170 return - end subroutine stdlib_qlarre + end subroutine stdlib_${ri}$larre - pure subroutine stdlib_qlarrf( n, d, l, ld, clstrt, clend,w, wgap, werr,spdiam, clgapl, & + pure subroutine stdlib_${ri}$larrf( n, d, l, ld, clstrt, clend,w, wgap, werr,spdiam, clgapl, & !! Given the initial representation L D L^T and its cluster of close !! eigenvalues (in a relative measure), W( CLSTRT ), W( CLSTRT+1 ), ... !! W( CLEND ), DLARRF: finds a new relatively robust representation @@ -40935,17 +40936,17 @@ module stdlib_linalg_lapack_q ! Scalar Arguments integer(ilp), intent(in) :: clstrt, clend, n integer(ilp), intent(out) :: info - real(qp), intent(in) :: clgapl, clgapr, pivmin, spdiam - real(qp), intent(out) :: sigma + real(${rk}$), intent(in) :: clgapl, clgapr, pivmin, spdiam + real(${rk}$), intent(out) :: sigma ! Array Arguments - real(qp), intent(in) :: d(*), l(*), ld(*), w(*), werr(*) - real(qp), intent(out) :: dplus(*), lplus(*), work(*) - real(qp), intent(inout) :: wgap(*) + real(${rk}$), intent(in) :: d(*), l(*), ld(*), w(*), werr(*) + real(${rk}$), intent(out) :: dplus(*), lplus(*), work(*) + real(${rk}$), intent(inout) :: wgap(*) ! ===================================================================== ! Parameters - real(qp), parameter :: quart = 0.25_qp - real(qp), parameter :: maxgrowth1 = 8._qp - real(qp), parameter :: maxgrowth2 = 8._qp + real(${rk}$), parameter :: quart = 0.25_${rk}$ + real(${rk}$), parameter :: maxgrowth1 = 8._${rk}$ + real(${rk}$), parameter :: maxgrowth2 = 8._${rk}$ integer(ilp), parameter :: ktrymax = 1 integer(ilp), parameter :: sleft = 1 integer(ilp), parameter :: sright = 2 @@ -40953,7 +40954,7 @@ module stdlib_linalg_lapack_q ! Local Scalars logical(lk) :: dorrr1, forcer, nofail, sawnan1, sawnan2, tryrrr1 integer(ilp) :: i, indx, ktry, shift - real(qp) :: avgap, bestshift, clwdth, eps, fact, fail, fail2, growthbound, ldelta, & + real(${rk}$) :: avgap, bestshift, clwdth, eps, fact, fail, fail2, growthbound, ldelta, & ldmax, lsigma, max1, max2, mingap, oldp, prod, rdelta, rdmax, rrr1, rrr2, rsigma, s, & smlgrowth, tmp, znm2 ! Intrinsic Functions @@ -40964,8 +40965,8 @@ module stdlib_linalg_lapack_q if( n<=0 ) then return end if - fact = real(2**ktrymax,KIND=qp) - eps = stdlib_qlamch( 'PRECISION' ) + fact = real(2**ktrymax,KIND=${rk}$) + eps = stdlib_${ri}$lamch( 'PRECISION' ) shift = 0 forcer = .false. ! note that we cannot guarantee that for any of the shifts tried, @@ -40983,7 +40984,7 @@ module stdlib_linalg_lapack_q nofail = .false. ! compute the average gap length of the cluster clwdth = abs(w(clend)-w(clstrt)) + werr(clend) + werr(clstrt) - avgap = clwdth / real(clend-clstrt,KIND=qp) + avgap = clwdth / real(clend-clstrt,KIND=${rk}$) mingap = min(clgapl, clgapr) ! initial values for shifts to both ends of cluster lsigma = min(w( clstrt ),w( clend )) - werr( clstrt ) @@ -40997,10 +40998,10 @@ module stdlib_linalg_lapack_q ldelta = max(avgap,wgap( clstrt ))/fact rdelta = max(avgap,wgap( clend-1 ))/fact ! initialize the record of the best representation found - s = stdlib_qlamch( 'S' ) + s = stdlib_${ri}$lamch( 'S' ) smlgrowth = one / s - fail = real(n-1,KIND=qp)*mingap/(spdiam*eps) - fail2 = real(n-1,KIND=qp)*mingap/(spdiam*sqrt(eps)) + fail = real(n-1,KIND=${rk}$)*mingap/(spdiam*eps) + fail2 = real(n-1,KIND=${rk}$)*mingap/(spdiam*sqrt(eps)) bestshift = lsigma ! while (ktry <= ktrymax) ktry = 0 @@ -41035,7 +41036,7 @@ module stdlib_linalg_lapack_q endif max1 = max( max1,abs(dplus(i+1)) ) end do - sawnan1 = sawnan1 .or. stdlib_qisnan( max1 ) + sawnan1 = sawnan1 .or. stdlib_${ri}$isnan( max1 ) if( forcer .or.(max1<=growthbound .and. .not.sawnan1 ) ) then sigma = lsigma shift = sleft @@ -41063,7 +41064,7 @@ module stdlib_linalg_lapack_q endif max2 = max( max2,abs(work(i+1)) ) end do - sawnan2 = sawnan2 .or. stdlib_qisnan( max2 ) + sawnan2 = sawnan2 .or. stdlib_${ri}$isnan( max2 ) if( forcer .or.(max2<=growthbound .and. .not.sawnan2 ) ) then sigma = rsigma shift = sright @@ -41095,7 +41096,7 @@ module stdlib_linalg_lapack_q ! we may still accept the representation, if it passes a ! refined test for rrr. this test supposes that no nan occurred. ! moreover, we use the refined rrr test only for isolated clusters. - if((clwdth1) then @@ -41856,7 +41857,7 @@ module stdlib_linalg_lapack_q p = indexw( wbegin-1+newlst ) endif offset = indexw( wbegin ) - 1 - call stdlib_qlarrb( in, d(ibegin),work( indlld+ibegin-1 ),p,p,rqtol, & + call stdlib_${ri}$larrb( in, d(ibegin),work( indlld+ibegin-1 ),p,p,rqtol, & rqtol, offset,work(wbegin),wgap(wbegin),werr(wbegin),work( indwrk ),& iwork( iindwk ), pivmin, spdiam,in, iinfo ) end do @@ -41872,13 +41873,13 @@ module stdlib_linalg_lapack_q endif ! compute rrr of child cluster. ! note that the new rrr is stored in z - ! stdlib_qlarrf needs lwork = 2*n - call stdlib_qlarrf( in, d( ibegin ), l( ibegin ),work(indld+ibegin-1),& + ! stdlib_${ri}$larrf needs lwork = 2*n + call stdlib_${ri}$larrf( in, d( ibegin ), l( ibegin ),work(indld+ibegin-1),& newfst, newlst, work(wbegin),wgap(wbegin), werr(wbegin),spdiam, lgap, & rgap, pivmin, tau,z(ibegin, newftt),z(ibegin, newftt+1),work( indwrk ), & iinfo ) if( iinfo==0 ) then - ! a new rrr for the cluster was found by stdlib_qlarrf + ! a new rrr for the cluster was found by stdlib_${ri}$larrf ! update shift and store it ssigma = sigma + tau z( iend, newftt+1 ) = ssigma @@ -41909,7 +41910,7 @@ module stdlib_linalg_lapack_q else ! compute eigenvector of singleton iter = 0 - tol = four * log(real(in,KIND=qp)) * eps + tol = four * log(real(in,KIND=${rk}$)) * eps k = newfst windex = wbegin + k - 1 windmn = max(windex - 1,1) @@ -41988,7 +41989,7 @@ module stdlib_linalg_lapack_q usedbs = .true. itmp1 = iwork( iindr+windex ) offset = indexw( wbegin ) - 1 - call stdlib_qlarrb( in, d(ibegin),work(indlld+ibegin-1),indeig,& + call stdlib_${ri}$larrb( in, d(ibegin),work(indlld+ibegin-1),indeig,& indeig,zero, two*eps, offset,work(wbegin),wgap(wbegin),werr(wbegin),& work( indwrk ),iwork( iindwk ), pivmin, spdiam,itmp1, iinfo ) if( iinfo/=0 ) then @@ -42001,7 +42002,7 @@ module stdlib_linalg_lapack_q iwork( iindr+windex ) = 0 endif ! given lambda, compute the eigenvector. - call stdlib_qlar1v( in, 1, in, lambda, d( ibegin ),l( ibegin ), work(& + call stdlib_${ri}$lar1v( in, 1, in, lambda, d( ibegin ),l( ibegin ), work(& indld+ibegin-1),work(indlld+ibegin-1),pivmin, gaptol, z( ibegin, windex & ),.not.usedbs, negcnt, ztz, mingma,iwork( iindr+windex ), isuppz( & 2*windex-1 ),nrminv, resid, rqcorr, work( indwrk ) ) @@ -42088,7 +42089,7 @@ module stdlib_linalg_lapack_q endif if (stp2ii) then ! improve error angle by second step - call stdlib_qlar1v( in, 1, in, lambda,d( ibegin ), l( ibegin ),& + call stdlib_${ri}$lar1v( in, 1, in, lambda,d( ibegin ), l( ibegin ),& work(indld+ibegin-1),work(indlld+ibegin-1),pivmin, gaptol, z( & ibegin, windex ),.not.usedbs, negcnt, ztz, mingma,iwork( iindr+& windex ),isuppz( 2*windex-1 ),nrminv, resid, rqcorr, work( indwrk & @@ -42114,7 +42115,7 @@ module stdlib_linalg_lapack_q z( ii, windex ) = zero end do endif - call stdlib_qscal( zto-zfrom+1, nrminv,z( zfrom, windex ), 1 ) + call stdlib_${ri}$scal( zto-zfrom+1, nrminv,z( zfrom, windex ), 1 ) 125 continue ! update w w( windex ) = lambda+sigma @@ -42149,10 +42150,10 @@ module stdlib_linalg_lapack_q wbegin = wend + 1 end do loop_170 return - end subroutine stdlib_qlarrv + end subroutine stdlib_${ri}$larrv - pure subroutine stdlib_qlartg( f, g, c, s, r ) + pure subroutine stdlib_${ri}$lartg( f, g, c, s, r ) !! DLARTG: generates a plane rotation so that !! [ C S ] . [ F ] = [ R ] !! [ -S C ] [ G ] [ 0 ] @@ -42180,10 +42181,10 @@ module stdlib_linalg_lapack_q ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! february 2021 ! Scalar Arguments - real(qp), intent(out) :: c, r, s - real(qp), intent(in) :: f, g + real(${rk}$), intent(out) :: c, r, s + real(${rk}$), intent(in) :: f, g ! Local Scalars - real(qp) :: d, f1, fs, g1, gs, p, u, uu + real(${rk}$) :: d, f1, fs, g1, gs, p, u, uu ! Intrinsic Functions intrinsic :: abs,sign,sqrt ! Executable Statements @@ -42216,10 +42217,10 @@ module stdlib_linalg_lapack_q r = sign( d, f )*u end if return - end subroutine stdlib_qlartg + end subroutine stdlib_${ri}$lartg - pure subroutine stdlib_qlartgp( f, g, cs, sn, r ) + pure subroutine stdlib_${ri}$lartgp( f, g, cs, sn, r ) !! DLARTGP: generates a plane rotation so that !! [ CS SN ] . [ F ] = [ R ] where CS**2 + SN**2 = 1. !! [ -SN CS ] [ G ] [ 0 ] @@ -42233,8 +42234,8 @@ module stdlib_linalg_lapack_q ! -- lapack is a software package provided by univ. of tennessee, -- ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments - real(qp), intent(out) :: cs, r, sn - real(qp), intent(in) :: f, g + real(${rk}$), intent(out) :: cs, r, sn + real(${rk}$), intent(in) :: f, g ! ===================================================================== @@ -42242,7 +42243,7 @@ module stdlib_linalg_lapack_q ! Local Scalars ! logical first integer(ilp) :: count, i - real(qp) :: eps, f1, g1, safmin, safmn2, safmx2, scale + real(${rk}$) :: eps, f1, g1, safmin, safmn2, safmx2, scale ! Intrinsic Functions intrinsic :: abs,int,log,max,sign,sqrt ! Save Statement @@ -42251,9 +42252,9 @@ module stdlib_linalg_lapack_q ! data first / .true. / ! Executable Statements ! if( first ) then - safmin = stdlib_qlamch( 'S' ) - eps = stdlib_qlamch( 'E' ) - safmn2 = stdlib_qlamch( 'B' )**int( log( safmin / eps ) /log( stdlib_qlamch( 'B' ) )& + safmin = stdlib_${ri}$lamch( 'S' ) + eps = stdlib_${ri}$lamch( 'E' ) + safmn2 = stdlib_${ri}$lamch( 'B' )**int( log( safmin / eps ) /log( stdlib_${ri}$lamch( 'B' ) )& / two,KIND=ilp) safmx2 = one / safmn2 ! first = .false. @@ -42310,10 +42311,10 @@ module stdlib_linalg_lapack_q end if end if return - end subroutine stdlib_qlartgp + end subroutine stdlib_${ri}$lartgp - pure subroutine stdlib_qlartgs( x, y, sigma, cs, sn ) + pure subroutine stdlib_${ri}$lartgs( x, y, sigma, cs, sn ) !! DLARTGS: generates a plane rotation designed to introduce a bulge in !! Golub-Reinsch-style implicit QR iteration for the bidiagonal SVD !! problem. X and Y are the top-row entries, and SIGMA is the shift. @@ -42326,13 +42327,13 @@ module stdlib_linalg_lapack_q ! -- lapack is a software package provided by univ. of tennessee, -- ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments - real(qp), intent(out) :: cs, sn - real(qp), intent(in) :: sigma, x, y + real(${rk}$), intent(out) :: cs, sn + real(${rk}$), intent(in) :: sigma, x, y ! =================================================================== ! Local Scalars - real(qp) :: r, s, thresh, w, z - thresh = stdlib_qlamch('E') + real(${rk}$) :: r, s, thresh, w, z + thresh = stdlib_${ri}$lamch('E') ! compute the first column of b**t*b - sigma^2*i, up to a scale ! factor. if( (sigma == zero .and. abs(x) < thresh) .or.(abs(x) == sigma .and. y == zero) ) & @@ -42360,16 +42361,16 @@ module stdlib_linalg_lapack_q w = s * y end if ! generate the rotation. - ! call stdlib_qlartgp( z, w, cs, sn, r ) might seem more natural; + ! call stdlib_${ri}$lartgp( z, w, cs, sn, r ) might seem more natural; ! reordering the arguments ensures that if z = 0 then the rotation ! is by pi/2. - call stdlib_qlartgp( w, z, sn, cs, r ) + call stdlib_${ri}$lartgp( w, z, sn, cs, r ) return - ! end stdlib_qlartgs - end subroutine stdlib_qlartgs + ! end stdlib_${ri}$lartgs + end subroutine stdlib_${ri}$lartgs - pure subroutine stdlib_qlartv( n, x, incx, y, incy, c, s, incc ) + pure subroutine stdlib_${ri}$lartv( n, x, incx, y, incy, c, s, incc ) !! DLARTV: applies a vector of real plane rotations to elements of the !! real vectors x and y. For i = 1,2,...,n !! ( x(i) ) := ( c(i) s(i) ) ( x(i) ) @@ -42380,12 +42381,12 @@ module stdlib_linalg_lapack_q ! Scalar Arguments integer(ilp), intent(in) :: incc, incx, incy, n ! Array Arguments - real(qp), intent(in) :: c(*), s(*) - real(qp), intent(inout) :: x(*), y(*) + real(${rk}$), intent(in) :: c(*), s(*) + real(${rk}$), intent(inout) :: x(*), y(*) ! ===================================================================== ! Local Scalars integer(ilp) :: i, ic, ix, iy - real(qp) :: xi, yi + real(${rk}$) :: xi, yi ! Executable Statements ix = 1 iy = 1 @@ -42400,10 +42401,10 @@ module stdlib_linalg_lapack_q ic = ic + incc end do return - end subroutine stdlib_qlartv + end subroutine stdlib_${ri}$lartv - pure subroutine stdlib_qlaruv( iseed, n, x ) + pure subroutine stdlib_${ri}$laruv( iseed, n, x ) !! DLARUV: returns a vector of n random real numbers from a uniform (0,1) !! distribution (n <= 128). !! This is an auxiliary routine called by DLARNV and ZLARNV. @@ -42414,12 +42415,12 @@ module stdlib_linalg_lapack_q integer(ilp), intent(in) :: n ! Array Arguments integer(ilp), intent(inout) :: iseed(4) - real(qp), intent(out) :: x(n) + real(${rk}$), intent(out) :: x(n) ! ===================================================================== ! Parameters integer(ilp), parameter :: lv = 128 integer(ilp), parameter :: ipw2 = 4096 - real(qp), parameter :: r = one/ipw2 + real(${rk}$), parameter :: r = one/ipw2 @@ -42577,18 +42578,18 @@ module stdlib_linalg_lapack_q it2 = it2 - ipw2*it1 it1 = it1 + i1*mm( i, 4 ) + i2*mm( i, 3 ) + i3*mm( i, 2 ) +i4*mm( i, 1 ) it1 = mod( it1, ipw2 ) - ! convert 48-bit integer to a realnumber in the interval (0,1,KIND=qp) - x( i ) = r*( real( it1,KIND=qp)+r*( real( it2,KIND=qp)+r*( real( it3,KIND=qp)+& - r*real( it4,KIND=qp) ) ) ) - if (x( i )==1.0_qp) then + ! convert 48-bit integer to a realnumber in the interval (0,1,KIND=${rk}$) + x( i ) = r*( real( it1,KIND=${rk}$)+r*( real( it2,KIND=${rk}$)+r*( real( it3,KIND=${rk}$)+& + r*real( it4,KIND=${rk}$) ) ) ) + if (x( i )==1.0_${rk}$) then ! if a real number has n bits of precision, and the first ! n bits of the 48-bit integer above happen to be all 1 (which ! will occur about once every 2**n calls), then x( i ) will ! be rounded to exactly one. - ! since x( i ) is not supposed to return exactly 0.0_qp or 1.0_qp, + ! since x( i ) is not supposed to return exactly 0.0_${rk}$ or 1.0_${rk}$, ! the statistically correct thing to do in this situation is ! simply to iterate again. - ! n.b. the case x( i ) = 0.0_qp should not be possible. + ! n.b. the case x( i ) = 0.0_${rk}$ should not be possible. i1 = i1 + 2 i2 = i2 + 2 i3 = i3 + 2 @@ -42602,10 +42603,10 @@ module stdlib_linalg_lapack_q iseed( 3 ) = it3 iseed( 4 ) = it4 return - end subroutine stdlib_qlaruv + end subroutine stdlib_${ri}$laruv - pure subroutine stdlib_qlarz( side, m, n, l, v, incv, tau, c, ldc, work ) + pure subroutine stdlib_${ri}$larz( side, m, n, l, v, incv, tau, c, ldc, work ) !! DLARZ: applies a real elementary reflector H to a real M-by-N !! matrix C, from either the left or the right. H is represented in the !! form @@ -42619,11 +42620,11 @@ module stdlib_linalg_lapack_q ! Scalar Arguments character, intent(in) :: side integer(ilp), intent(in) :: incv, l, ldc, m, n - real(qp), intent(in) :: tau + real(${rk}$), intent(in) :: tau ! Array Arguments - real(qp), intent(inout) :: c(ldc,*) - real(qp), intent(in) :: v(*) - real(qp), intent(out) :: work(*) + real(${rk}$), intent(inout) :: c(ldc,*) + real(${rk}$), intent(in) :: v(*) + real(${rk}$), intent(out) :: work(*) ! ===================================================================== ! Executable Statements @@ -42631,36 +42632,36 @@ module stdlib_linalg_lapack_q ! form h * c if( tau/=zero ) then ! w( 1:n ) = c( 1, 1:n ) - call stdlib_qcopy( n, c, ldc, work, 1 ) + call stdlib_${ri}$copy( n, c, ldc, work, 1 ) ! w( 1:n ) = w( 1:n ) + c( m-l+1:m, 1:n )**t * v( 1:l ) - call stdlib_qgemv( 'TRANSPOSE', l, n, one, c( m-l+1, 1 ), ldc, v,incv, one, work,& + call stdlib_${ri}$gemv( 'TRANSPOSE', l, n, one, c( m-l+1, 1 ), ldc, v,incv, one, work,& 1 ) ! c( 1, 1:n ) = c( 1, 1:n ) - tau * w( 1:n ) - call stdlib_qaxpy( n, -tau, work, 1, c, ldc ) + call stdlib_${ri}$axpy( n, -tau, work, 1, c, ldc ) ! c( m-l+1:m, 1:n ) = c( m-l+1:m, 1:n ) - ... ! tau * v( 1:l ) * w( 1:n )**t - call stdlib_qger( l, n, -tau, v, incv, work, 1, c( m-l+1, 1 ),ldc ) + call stdlib_${ri}$ger( l, n, -tau, v, incv, work, 1, c( m-l+1, 1 ),ldc ) end if else ! form c * h if( tau/=zero ) then ! w( 1:m ) = c( 1:m, 1 ) - call stdlib_qcopy( m, c, 1, work, 1 ) + call stdlib_${ri}$copy( m, c, 1, work, 1 ) ! w( 1:m ) = w( 1:m ) + c( 1:m, n-l+1:n, 1:n ) * v( 1:l ) - call stdlib_qgemv( 'NO TRANSPOSE', m, l, one, c( 1, n-l+1 ), ldc,v, incv, one, & + call stdlib_${ri}$gemv( 'NO TRANSPOSE', m, l, one, c( 1, n-l+1 ), ldc,v, incv, one, & work, 1 ) ! c( 1:m, 1 ) = c( 1:m, 1 ) - tau * w( 1:m ) - call stdlib_qaxpy( m, -tau, work, 1, c, 1 ) + call stdlib_${ri}$axpy( m, -tau, work, 1, c, 1 ) ! c( 1:m, n-l+1:n ) = c( 1:m, n-l+1:n ) - ... ! tau * w( 1:m ) * v( 1:l )**t - call stdlib_qger( m, l, -tau, work, 1, v, incv, c( 1, n-l+1 ),ldc ) + call stdlib_${ri}$ger( m, l, -tau, work, 1, v, incv, c( 1, n-l+1 ),ldc ) end if end if return - end subroutine stdlib_qlarz + end subroutine stdlib_${ri}$larz - pure subroutine stdlib_qlarzb( side, trans, direct, storev, m, n, k, l, v,ldv, t, ldt, c, & + pure subroutine stdlib_${ri}$larzb( side, trans, direct, storev, m, n, k, l, v,ldv, t, ldt, c, & !! DLARZB: applies a real block reflector H or its transpose H**T to !! a real distributed M-by-N C from the left or the right. !! Currently, only STOREV = 'R' and DIRECT = 'B' are supported. @@ -42672,8 +42673,8 @@ module stdlib_linalg_lapack_q character, intent(in) :: direct, side, storev, trans integer(ilp), intent(in) :: k, l, ldc, ldt, ldv, ldwork, m, n ! Array Arguments - real(qp), intent(inout) :: c(ldc,*), t(ldt,*), v(ldv,*) - real(qp), intent(out) :: work(ldwork,*) + real(${rk}$), intent(inout) :: c(ldc,*), t(ldt,*), v(ldv,*) + real(${rk}$), intent(out) :: work(ldwork,*) ! ===================================================================== ! Local Scalars @@ -42702,14 +42703,14 @@ module stdlib_linalg_lapack_q ! form h * c or h**t * c ! w( 1:n, 1:k ) = c( 1:k, 1:n )**t do j = 1, k - call stdlib_qcopy( n, c( j, 1 ), ldc, work( 1, j ), 1 ) + call stdlib_${ri}$copy( n, c( j, 1 ), ldc, work( 1, j ), 1 ) end do ! w( 1:n, 1:k ) = w( 1:n, 1:k ) + ... ! c( m-l+1:m, 1:n )**t * v( 1:k, 1:l )**t - if( l>0 )call stdlib_qgemm( 'TRANSPOSE', 'TRANSPOSE', n, k, l, one,c( m-l+1, 1 ), & + if( l>0 )call stdlib_${ri}$gemm( 'TRANSPOSE', 'TRANSPOSE', n, k, l, one,c( m-l+1, 1 ), & ldc, v, ldv, one, work, ldwork ) ! w( 1:n, 1:k ) = w( 1:n, 1:k ) * t**t or w( 1:m, 1:k ) * t - call stdlib_qtrmm( 'RIGHT', 'LOWER', transt, 'NON-UNIT', n, k, one, t,ldt, work, & + call stdlib_${ri}$trmm( 'RIGHT', 'LOWER', transt, 'NON-UNIT', n, k, one, t,ldt, work, & ldwork ) ! c( 1:k, 1:n ) = c( 1:k, 1:n ) - w( 1:n, 1:k )**t do j = 1, n @@ -42719,20 +42720,20 @@ module stdlib_linalg_lapack_q end do ! c( m-l+1:m, 1:n ) = c( m-l+1:m, 1:n ) - ... ! v( 1:k, 1:l )**t * w( 1:n, 1:k )**t - if( l>0 )call stdlib_qgemm( 'TRANSPOSE', 'TRANSPOSE', l, n, k, -one, v, ldv,work, & + if( l>0 )call stdlib_${ri}$gemm( 'TRANSPOSE', 'TRANSPOSE', l, n, k, -one, v, ldv,work, & ldwork, one, c( m-l+1, 1 ), ldc ) else if( stdlib_lsame( side, 'R' ) ) then ! form c * h or c * h**t ! w( 1:m, 1:k ) = c( 1:m, 1:k ) do j = 1, k - call stdlib_qcopy( m, c( 1, j ), 1, work( 1, j ), 1 ) + call stdlib_${ri}$copy( m, c( 1, j ), 1, work( 1, j ), 1 ) end do ! w( 1:m, 1:k ) = w( 1:m, 1:k ) + ... ! c( 1:m, n-l+1:n ) * v( 1:k, 1:l )**t - if( l>0 )call stdlib_qgemm( 'NO TRANSPOSE', 'TRANSPOSE', m, k, l, one,c( 1, n-l+1 ),& + if( l>0 )call stdlib_${ri}$gemm( 'NO TRANSPOSE', 'TRANSPOSE', m, k, l, one,c( 1, n-l+1 ),& ldc, v, ldv, one, work, ldwork ) ! w( 1:m, 1:k ) = w( 1:m, 1:k ) * t or w( 1:m, 1:k ) * t**t - call stdlib_qtrmm( 'RIGHT', 'LOWER', trans, 'NON-UNIT', m, k, one, t,ldt, work, & + call stdlib_${ri}$trmm( 'RIGHT', 'LOWER', trans, 'NON-UNIT', m, k, one, t,ldt, work, & ldwork ) ! c( 1:m, 1:k ) = c( 1:m, 1:k ) - w( 1:m, 1:k ) do j = 1, k @@ -42742,14 +42743,14 @@ module stdlib_linalg_lapack_q end do ! c( 1:m, n-l+1:n ) = c( 1:m, n-l+1:n ) - ... ! w( 1:m, 1:k ) * v( 1:k, 1:l ) - if( l>0 )call stdlib_qgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', m, l, k, -one,work, & + if( l>0 )call stdlib_${ri}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', m, l, k, -one,work, & ldwork, v, ldv, one, c( 1, n-l+1 ), ldc ) end if return - end subroutine stdlib_qlarzb + end subroutine stdlib_${ri}$larzb - pure subroutine stdlib_qlarzt( direct, storev, n, k, v, ldv, tau, t, ldt ) + pure subroutine stdlib_${ri}$larzt( direct, storev, n, k, v, ldv, tau, t, ldt ) !! DLARZT: forms the triangular factor T of a real block reflector !! H of order > n, which is defined as a product of k elementary !! reflectors. @@ -42769,9 +42770,9 @@ module stdlib_linalg_lapack_q character, intent(in) :: direct, storev integer(ilp), intent(in) :: k, ldt, ldv, n ! Array Arguments - real(qp), intent(out) :: t(ldt,*) - real(qp), intent(in) :: tau(*) - real(qp), intent(inout) :: v(ldv,*) + real(${rk}$), intent(out) :: t(ldt,*) + real(${rk}$), intent(in) :: tau(*) + real(${rk}$), intent(inout) :: v(ldv,*) ! ===================================================================== ! Local Scalars @@ -42798,20 +42799,20 @@ module stdlib_linalg_lapack_q ! general case if( in ) then - z( 1 ) = stdlib_qlapy2( z1, z( m ) ) + z( 1 ) = stdlib_${ri}$lapy2( z1, z( m ) ) if( z( 1 )<=tol ) then c = one s = zero @@ -43549,10 +43550,10 @@ module stdlib_linalg_lapack_q end if end if ! move the rest of the updating row to z. - call stdlib_qcopy( k-1, u2( 2, 1 ), 1, z( 2 ), 1 ) + call stdlib_${ri}$copy( k-1, u2( 2, 1 ), 1, z( 2 ), 1 ) ! determine the first column of u2, the first row of vt2 and the ! last row of vt. - call stdlib_qlaset( 'A', n, 1, zero, zero, u2, ldu2 ) + call stdlib_${ri}$laset( 'A', n, 1, zero, zero, u2, ldu2 ) u2( nlp1, 1 ) = one if( m>n ) then do i = 1, nlp1 @@ -43564,27 +43565,27 @@ module stdlib_linalg_lapack_q vt( m, i ) = c*vt( m, i ) end do else - call stdlib_qcopy( m, vt( nlp1, 1 ), ldvt, vt2( 1, 1 ), ldvt2 ) + call stdlib_${ri}$copy( m, vt( nlp1, 1 ), ldvt, vt2( 1, 1 ), ldvt2 ) end if if( m>n ) then - call stdlib_qcopy( m, vt( m, 1 ), ldvt, vt2( m, 1 ), ldvt2 ) + call stdlib_${ri}$copy( m, vt( m, 1 ), ldvt, vt2( m, 1 ), ldvt2 ) end if ! the deflated singular values and their corresponding vectors go ! into the back of d, u, and v respectively. if( n>k ) then - call stdlib_qcopy( n-k, dsigma( k+1 ), 1, d( k+1 ), 1 ) - call stdlib_qlacpy( 'A', n, n-k, u2( 1, k+1 ), ldu2, u( 1, k+1 ),ldu ) - call stdlib_qlacpy( 'A', n-k, m, vt2( k+1, 1 ), ldvt2, vt( k+1, 1 ),ldvt ) + call stdlib_${ri}$copy( n-k, dsigma( k+1 ), 1, d( k+1 ), 1 ) + call stdlib_${ri}$lacpy( 'A', n, n-k, u2( 1, k+1 ), ldu2, u( 1, k+1 ),ldu ) + call stdlib_${ri}$lacpy( 'A', n-k, m, vt2( k+1, 1 ), ldvt2, vt( k+1, 1 ),ldvt ) end if - ! copy ctot into coltyp for referencing in stdlib_qlasd3. + ! copy ctot into coltyp for referencing in stdlib_${ri}$lasd3. do j = 1, 4 coltyp( j ) = ctot( j ) end do return - end subroutine stdlib_qlasd2 + end subroutine stdlib_${ri}$lasd2 - pure subroutine stdlib_qlasd3( nl, nr, sqre, k, d, q, ldq, dsigma, u, ldu, u2,ldu2, vt, ldvt,& + pure subroutine stdlib_${ri}$lasd3( nl, nr, sqre, k, d, q, ldq, dsigma, u, ldu, u2,ldu2, vt, ldvt,& !! DLASD3: finds all the square roots of the roots of the secular !! equation, as defined by the values in D and Z. It makes the !! appropriate calls to DLASD4 and then updates the singular @@ -43605,14 +43606,14 @@ module stdlib_linalg_lapack_q integer(ilp), intent(in) :: k, ldq, ldu, ldu2, ldvt, ldvt2, nl, nr, sqre ! Array Arguments integer(ilp), intent(in) :: ctot(*), idxc(*) - real(qp), intent(out) :: d(*), q(ldq,*), u(ldu,*), vt(ldvt,*) - real(qp), intent(inout) :: dsigma(*), vt2(ldvt2,*), z(*) - real(qp), intent(in) :: u2(ldu2,*) + real(${rk}$), intent(out) :: d(*), q(ldq,*), u(ldu,*), vt(ldvt,*) + real(${rk}$), intent(inout) :: dsigma(*), vt2(ldvt2,*), z(*) + real(${rk}$), intent(in) :: u2(ldu2,*) ! ===================================================================== ! Local Scalars integer(ilp) :: ctemp, i, j, jc, ktemp, m, n, nlp1, nlp2, nrp1 - real(qp) :: rho, temp + real(${rk}$) :: rho, temp ! Intrinsic Functions intrinsic :: abs,sign,sqrt ! Executable Statements @@ -43649,9 +43650,9 @@ module stdlib_linalg_lapack_q ! quick return if possible if( k==1 ) then d( 1 ) = abs( z( 1 ) ) - call stdlib_qcopy( m, vt2( 1, 1 ), ldvt2, vt( 1, 1 ), ldvt ) + call stdlib_${ri}$copy( m, vt2( 1, 1 ), ldvt2, vt( 1, 1 ), ldvt ) if( z( 1 )>zero ) then - call stdlib_qcopy( n, u2( 1, 1 ), 1, u( 1, 1 ), 1 ) + call stdlib_${ri}$copy( n, u2( 1, 1 ), 1, u( 1, 1 ), 1 ) else do i = 1, n u( i, 1 ) = -u2( i, 1 ) @@ -43676,17 +43677,17 @@ module stdlib_linalg_lapack_q ! 2*dsigma(i) to prevent optimizing compilers from eliminating ! this code. do i = 1, k - dsigma( i ) = stdlib_qlamc3( dsigma( i ), dsigma( i ) ) - dsigma( i ) + dsigma( i ) = stdlib_${ri}$lamc3( dsigma( i ), dsigma( i ) ) - dsigma( i ) end do ! keep a copy of z. - call stdlib_qcopy( k, z, 1, q, 1 ) + call stdlib_${ri}$copy( k, z, 1, q, 1 ) ! normalize z. - rho = stdlib_qnrm2( k, z, 1 ) - call stdlib_qlascl( 'G', 0, 0, rho, one, k, 1, z, k, info ) + rho = stdlib_${ri}$nrm2( k, z, 1 ) + call stdlib_${ri}$lascl( 'G', 0, 0, rho, one, k, 1, z, k, info ) rho = rho*rho ! find the new singular values. do j = 1, k - call stdlib_qlasd4( k, j, dsigma, z, u( 1, j ), rho, d( j ),vt( 1, j ), info ) + call stdlib_${ri}$lasd4( k, j, dsigma, z, u( 1, j ), rho, d( j ),vt( 1, j ), info ) ! if the zero finder fails, report the convergence failure. if( info/=0 ) then @@ -43715,7 +43716,7 @@ module stdlib_linalg_lapack_q vt( j, i ) = z( j ) / u( j, i ) / vt( j, i ) u( j, i ) = dsigma( j )*vt( j, i ) end do - temp = stdlib_qnrm2( k, u( 1, i ), 1 ) + temp = stdlib_${ri}$nrm2( k, u( 1, i ), 1 ) q( 1, i ) = u( 1, i ) / temp do j = 2, k jc = idxc( j ) @@ -43724,33 +43725,33 @@ module stdlib_linalg_lapack_q end do ! update the left singular vector matrix. if( k==2 ) then - call stdlib_qgemm( 'N', 'N', n, k, k, one, u2, ldu2, q, ldq, zero, u,ldu ) + call stdlib_${ri}$gemm( 'N', 'N', n, k, k, one, u2, ldu2, q, ldq, zero, u,ldu ) go to 100 end if if( ctot( 1 )>0 ) then - call stdlib_qgemm( 'N', 'N', nl, k, ctot( 1 ), one, u2( 1, 2 ), ldu2,q( 2, 1 ), ldq,& + call stdlib_${ri}$gemm( 'N', 'N', nl, k, ctot( 1 ), one, u2( 1, 2 ), ldu2,q( 2, 1 ), ldq,& zero, u( 1, 1 ), ldu ) if( ctot( 3 )>0 ) then ktemp = 2 + ctot( 1 ) + ctot( 2 ) - call stdlib_qgemm( 'N', 'N', nl, k, ctot( 3 ), one, u2( 1, ktemp ),ldu2, q( & + call stdlib_${ri}$gemm( 'N', 'N', nl, k, ctot( 3 ), one, u2( 1, ktemp ),ldu2, q( & ktemp, 1 ), ldq, one, u( 1, 1 ), ldu ) end if else if( ctot( 3 )>0 ) then ktemp = 2 + ctot( 1 ) + ctot( 2 ) - call stdlib_qgemm( 'N', 'N', nl, k, ctot( 3 ), one, u2( 1, ktemp ),ldu2, q( ktemp, & + call stdlib_${ri}$gemm( 'N', 'N', nl, k, ctot( 3 ), one, u2( 1, ktemp ),ldu2, q( ktemp, & 1 ), ldq, zero, u( 1, 1 ), ldu ) else - call stdlib_qlacpy( 'F', nl, k, u2, ldu2, u, ldu ) + call stdlib_${ri}$lacpy( 'F', nl, k, u2, ldu2, u, ldu ) end if - call stdlib_qcopy( k, q( 1, 1 ), ldq, u( nlp1, 1 ), ldu ) + call stdlib_${ri}$copy( k, q( 1, 1 ), ldq, u( nlp1, 1 ), ldu ) ktemp = 2 + ctot( 1 ) ctemp = ctot( 2 ) + ctot( 3 ) - call stdlib_qgemm( 'N', 'N', nr, k, ctemp, one, u2( nlp2, ktemp ), ldu2,q( ktemp, 1 ), & + call stdlib_${ri}$gemm( 'N', 'N', nr, k, ctemp, one, u2( nlp2, ktemp ), ldu2,q( ktemp, 1 ), & ldq, zero, u( nlp2, 1 ), ldu ) ! generate the right singular vectors. 100 continue do i = 1, k - temp = stdlib_qnrm2( k, vt( 1, i ), 1 ) + temp = stdlib_${ri}$nrm2( k, vt( 1, i ), 1 ) q( i, 1 ) = vt( 1, i ) / temp do j = 2, k jc = idxc( j ) @@ -43759,15 +43760,15 @@ module stdlib_linalg_lapack_q end do ! update the right singular vector matrix. if( k==2 ) then - call stdlib_qgemm( 'N', 'N', k, m, k, one, q, ldq, vt2, ldvt2, zero,vt, ldvt ) + call stdlib_${ri}$gemm( 'N', 'N', k, m, k, one, q, ldq, vt2, ldvt2, zero,vt, ldvt ) return end if ktemp = 1 + ctot( 1 ) - call stdlib_qgemm( 'N', 'N', k, nlp1, ktemp, one, q( 1, 1 ), ldq,vt2( 1, 1 ), ldvt2, & + call stdlib_${ri}$gemm( 'N', 'N', k, nlp1, ktemp, one, q( 1, 1 ), ldq,vt2( 1, 1 ), ldvt2, & zero, vt( 1, 1 ), ldvt ) ktemp = 2 + ctot( 1 ) + ctot( 2 ) - if( ktemp<=ldvt2 )call stdlib_qgemm( 'N', 'N', k, nlp1, ctot( 3 ), one, q( 1, ktemp ),& + if( ktemp<=ldvt2 )call stdlib_${ri}$gemm( 'N', 'N', k, nlp1, ctot( 3 ), one, q( 1, ktemp ),& ldq, vt2( ktemp, 1 ), ldvt2, one, vt( 1, 1 ),ldvt ) ktemp = ctot( 1 ) + 1 nrp1 = nr + sqre @@ -43780,13 +43781,13 @@ module stdlib_linalg_lapack_q end do end if ctemp = 1 + ctot( 2 ) + ctot( 3 ) - call stdlib_qgemm( 'N', 'N', k, nrp1, ctemp, one, q( 1, ktemp ), ldq,vt2( ktemp, nlp2 )& + call stdlib_${ri}$gemm( 'N', 'N', k, nrp1, ctemp, one, q( 1, ktemp ), ldq,vt2( ktemp, nlp2 )& , ldvt2, zero, vt( 1, nlp2 ), ldvt ) return - end subroutine stdlib_qlasd3 + end subroutine stdlib_${ri}$lasd3 - pure subroutine stdlib_qlasd4( n, i, d, z, delta, rho, sigma, work, info ) + pure subroutine stdlib_${ri}$lasd4( n, i, d, z, delta, rho, sigma, work, info ) !! This subroutine computes the square root of the I-th updated !! eigenvalue of a positive symmetric rank-one modification to !! a positive diagonal matrix whose entries are given as the squares @@ -43804,11 +43805,11 @@ module stdlib_linalg_lapack_q ! Scalar Arguments integer(ilp), intent(in) :: i, n integer(ilp), intent(out) :: info - real(qp), intent(in) :: rho - real(qp), intent(out) :: sigma + real(${rk}$), intent(in) :: rho + real(${rk}$), intent(out) :: sigma ! Array Arguments - real(qp), intent(in) :: d(*), z(*) - real(qp), intent(out) :: delta(*), work(*) + real(${rk}$), intent(in) :: d(*), z(*) + real(${rk}$), intent(out) :: delta(*), work(*) ! ===================================================================== ! Parameters integer(ilp), parameter :: maxit = 400 @@ -43817,11 +43818,11 @@ module stdlib_linalg_lapack_q ! Local Scalars logical(lk) :: orgati, swtch, swtch3, geomavg integer(ilp) :: ii, iim1, iip1, ip1, iter, j, niter - real(qp) :: a, b, c, delsq, delsq2, sq2, dphi, dpsi, dtiim, dtiip, dtipsq, dtisq, & + real(${rk}$) :: a, b, c, delsq, delsq2, sq2, dphi, dpsi, dtiim, dtiip, dtipsq, dtisq, & dtnsq, dtnsq1, dw, eps, erretm, eta, phi, prew, psi, rhoinv, sglb, sgub, tau, tau2, & temp, temp1, temp2, w ! Local Arrays - real(qp) :: dd(3), zz(3) + real(${rk}$) :: dd(3), zz(3) ! Intrinsic Functions intrinsic :: abs,max,min,sqrt ! Executable Statements @@ -43837,11 +43838,11 @@ module stdlib_linalg_lapack_q return end if if( n==2 ) then - call stdlib_qlasd5( i, d, z, delta, rho, sigma, work ) + call stdlib_${ri}$lasd5( i, d, z, delta, rho, sigma, work ) return end if ! compute machine epsilon - eps = stdlib_qlamch( 'EPSILON' ) + eps = stdlib_${ri}$lamch( 'EPSILON' ) rhoinv = one / rho tau2= zero ! the case i = n @@ -44213,9 +44214,9 @@ module stdlib_linalg_lapack_q dd( 1 ) = dtiim dd( 2 ) = delta( ii )*work( ii ) dd( 3 ) = dtiip - call stdlib_qlaed6( niter, orgati, c, dd, zz, w, eta, info ) + call stdlib_${ri}$laed6( niter, orgati, c, dd, zz, w, eta, info ) if( info/=0 ) then - ! if info is not 0, i.e., stdlib_qlaed6 failed, switch back + ! if info is not 0, i.e., stdlib_${ri}$laed6 failed, switch back ! to 2 pole interpolation. swtch3 = .false. info = 0 @@ -44399,9 +44400,9 @@ module stdlib_linalg_lapack_q dd( 1 ) = dtiim dd( 2 ) = delta( ii )*work( ii ) dd( 3 ) = dtiip - call stdlib_qlaed6( niter, orgati, c, dd, zz, w, eta, info ) + call stdlib_${ri}$laed6( niter, orgati, c, dd, zz, w, eta, info ) if( info/=0 ) then - ! if info is not 0, i.e., stdlib_qlaed6 failed, switch + ! if info is not 0, i.e., stdlib_${ri}$laed6 failed, switch ! back to two pole interpolation swtch3 = .false. info = 0 @@ -44511,10 +44512,10 @@ module stdlib_linalg_lapack_q end if 240 continue return - end subroutine stdlib_qlasd4 + end subroutine stdlib_${ri}$lasd4 - pure subroutine stdlib_qlasd5( i, d, z, delta, rho, dsigma, work ) + pure subroutine stdlib_${ri}$lasd5( i, d, z, delta, rho, dsigma, work ) !! This subroutine computes the square root of the I-th eigenvalue !! of a positive symmetric rank-one modification of a 2-by-2 diagonal !! matrix @@ -44528,15 +44529,15 @@ module stdlib_linalg_lapack_q ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments integer(ilp), intent(in) :: i - real(qp), intent(out) :: dsigma - real(qp), intent(in) :: rho + real(${rk}$), intent(out) :: dsigma + real(${rk}$), intent(in) :: rho ! Array Arguments - real(qp), intent(in) :: d(2), z(2) - real(qp), intent(out) :: delta(2), work(2) + real(${rk}$), intent(in) :: d(2), z(2) + real(${rk}$), intent(out) :: delta(2), work(2) ! ===================================================================== ! Local Scalars - real(qp) :: b, c, del, delsq, tau, w + real(${rk}$) :: b, c, del, delsq, tau, w ! Intrinsic Functions intrinsic :: abs,sqrt ! Executable Statements @@ -44606,10 +44607,10 @@ module stdlib_linalg_lapack_q ! delta( 2 ) = delta( 2 ) / temp end if return - end subroutine stdlib_qlasd5 + end subroutine stdlib_${ri}$lasd5 - pure subroutine stdlib_qlasd6( icompq, nl, nr, sqre, d, vf, vl, alpha, beta,idxq, perm, & + pure subroutine stdlib_${ri}$lasd6( icompq, nl, nr, sqre, d, vf, vl, alpha, beta,idxq, perm, & !! DLASD6: computes the SVD of an updated upper bidiagonal matrix B !! obtained by merging two smaller ones by appending a row. This !! routine is used only for the problem which requires all singular @@ -44653,19 +44654,19 @@ module stdlib_linalg_lapack_q ! Scalar Arguments integer(ilp), intent(out) :: givptr, info, k integer(ilp), intent(in) :: icompq, ldgcol, ldgnum, nl, nr, sqre - real(qp), intent(inout) :: alpha, beta - real(qp), intent(out) :: c, s + real(${rk}$), intent(inout) :: alpha, beta + real(${rk}$), intent(out) :: c, s ! Array Arguments integer(ilp), intent(out) :: givcol(ldgcol,*), iwork(*), perm(*) integer(ilp), intent(inout) :: idxq(*) - real(qp), intent(inout) :: d(*), vf(*), vl(*) - real(qp), intent(out) :: difl(*), difr(*), givnum(ldgnum,*), poles(ldgnum,*), work(*), & + real(${rk}$), intent(inout) :: d(*), vf(*), vl(*) + real(${rk}$), intent(out) :: difl(*), difr(*), givnum(ldgnum,*), poles(ldgnum,*), work(*), & z(*) ! ===================================================================== ! Local Scalars integer(ilp) :: i, idx, idxc, idxp, isigma, ivfw, ivlw, iw, m, n, n1, n2 - real(qp) :: orgnrm + real(${rk}$) :: orgnrm ! Intrinsic Functions intrinsic :: abs,max ! Executable Statements @@ -44692,7 +44693,7 @@ module stdlib_linalg_lapack_q end if ! the following values are for bookkeeping purposes only. they are ! integer pointers which indicate the portion of the workspace - ! used by a particular array in stdlib_qlasd7 and stdlib_qlasd8. + ! used by a particular array in stdlib_${ri}$lasd7 and stdlib_${ri}$lasd8. isigma = 1 iw = isigma + n ivfw = iw + m @@ -44708,15 +44709,15 @@ module stdlib_linalg_lapack_q orgnrm = abs( d( i ) ) end if end do - call stdlib_qlascl( 'G', 0, 0, orgnrm, one, n, 1, d, n, info ) + call stdlib_${ri}$lascl( 'G', 0, 0, orgnrm, one, n, 1, d, n, info ) alpha = alpha / orgnrm beta = beta / orgnrm ! sort and deflate singular values. - call stdlib_qlasd7( icompq, nl, nr, sqre, k, d, z, work( iw ), vf,work( ivfw ), vl, & + call stdlib_${ri}$lasd7( icompq, nl, nr, sqre, k, d, z, work( iw ), vf,work( ivfw ), vl, & work( ivlw ), alpha, beta,work( isigma ), iwork( idx ), iwork( idxp ), idxq,perm, & givptr, givcol, ldgcol, givnum, ldgnum, c, s,info ) ! solve secular equation, compute difl, difr, and update vf, vl. - call stdlib_qlasd8( icompq, k, d, z, vf, vl, difl, difr, ldgnum,work( isigma ), work( & + call stdlib_${ri}$lasd8( icompq, k, d, z, vf, vl, difl, difr, ldgnum,work( isigma ), work( & iw ), info ) ! report the possible convergence failure. if( info/=0 ) then @@ -44724,20 +44725,20 @@ module stdlib_linalg_lapack_q end if ! save the poles if icompq = 1. if( icompq==1 ) then - call stdlib_qcopy( k, d, 1, poles( 1, 1 ), 1 ) - call stdlib_qcopy( k, work( isigma ), 1, poles( 1, 2 ), 1 ) + call stdlib_${ri}$copy( k, d, 1, poles( 1, 1 ), 1 ) + call stdlib_${ri}$copy( k, work( isigma ), 1, poles( 1, 2 ), 1 ) end if ! unscale. - call stdlib_qlascl( 'G', 0, 0, one, orgnrm, n, 1, d, n, info ) + call stdlib_${ri}$lascl( 'G', 0, 0, one, orgnrm, n, 1, d, n, info ) ! prepare the idxq sorting permutation. n1 = k n2 = n - k - call stdlib_qlamrg( n1, n2, d, 1, -1, idxq ) + call stdlib_${ri}$lamrg( n1, n2, d, 1, -1, idxq ) return - end subroutine stdlib_qlasd6 + end subroutine stdlib_${ri}$lasd6 - pure subroutine stdlib_qlasd7( icompq, nl, nr, sqre, k, d, z, zw, vf, vfw, vl,vlw, alpha, & + pure subroutine stdlib_${ri}$lasd7( icompq, nl, nr, sqre, k, d, z, zw, vf, vfw, vl,vlw, alpha, & !! DLASD7: merges the two sets of singular values together into a single !! sorted set. Then it tries to deflate the size of the problem. There !! are two ways in which deflation can occur: when two or more singular @@ -44753,19 +44754,19 @@ module stdlib_linalg_lapack_q ! Scalar Arguments integer(ilp), intent(out) :: givptr, info, k integer(ilp), intent(in) :: icompq, ldgcol, ldgnum, nl, nr, sqre - real(qp), intent(in) :: alpha, beta - real(qp), intent(out) :: c, s + real(${rk}$), intent(in) :: alpha, beta + real(${rk}$), intent(out) :: c, s ! Array Arguments integer(ilp), intent(out) :: givcol(ldgcol,*), idx(*), idxp(*), perm(*) integer(ilp), intent(inout) :: idxq(*) - real(qp), intent(inout) :: d(*), vf(*), vl(*) - real(qp), intent(out) :: dsigma(*), givnum(ldgnum,*), vfw(*), vlw(*), z(*), zw(*) + real(${rk}$), intent(inout) :: d(*), vf(*), vl(*) + real(${rk}$), intent(out) :: dsigma(*), givnum(ldgnum,*), vfw(*), vlw(*), z(*), zw(*) ! ===================================================================== ! Local Scalars integer(ilp) :: i, idxi, idxj, idxjp, j, jp, jprev, k2, m, n, nlp1, nlp2 - real(qp) :: eps, hlftol, tau, tol, z1 + real(${rk}$) :: eps, hlftol, tau, tol, z1 ! Intrinsic Functions intrinsic :: abs,max ! Executable Statements @@ -44824,7 +44825,7 @@ module stdlib_linalg_lapack_q vfw( i ) = vf( idxq( i ) ) vlw( i ) = vl( idxq( i ) ) end do - call stdlib_qlamrg( nl, nr, dsigma( 2 ), 1, 1, idx( 2 ) ) + call stdlib_${ri}$lamrg( nl, nr, dsigma( 2 ), 1, 1, idx( 2 ) ) do i = 2, n idxi = 1 + idx( i ) d( i ) = dsigma( idxi ) @@ -44833,7 +44834,7 @@ module stdlib_linalg_lapack_q vl( i ) = vlw( idxi ) end do ! calculate the allowable deflation tolerance - eps = stdlib_qlamch( 'EPSILON' ) + eps = stdlib_${ri}$lamch( 'EPSILON' ) tol = max( abs( alpha ), abs( beta ) ) tol = eight*eight*eps*max( abs( d( n ) ), tol ) ! there are 2 kinds of deflation -- first a value in the z-vector @@ -44881,7 +44882,7 @@ module stdlib_linalg_lapack_q c = z( j ) ! find sqrt(a**2+b**2) without overflow or ! destructive underflow. - tau = stdlib_qlapy2( c, s ) + tau = stdlib_${ri}$lapy2( c, s ) z( j ) = tau z( jprev ) = zero c = c / tau @@ -44902,8 +44903,8 @@ module stdlib_linalg_lapack_q givnum( givptr, 2 ) = c givnum( givptr, 1 ) = s end if - call stdlib_qrot( 1, vf( jprev ), 1, vf( j ), 1, c, s ) - call stdlib_qrot( 1, vl( jprev ), 1, vl( j ), 1, c, s ) + call stdlib_${ri}$rot( 1, vf( jprev ), 1, vf( j ), 1, c, s ) + call stdlib_${ri}$rot( 1, vl( jprev ), 1, vl( j ), 1, c, s ) k2 = k2 - 1 idxp( k2 ) = jprev jprev = j @@ -44943,14 +44944,14 @@ module stdlib_linalg_lapack_q end if ! the deflated singular values go back into the last n - k slots of ! d. - call stdlib_qcopy( n-k, dsigma( k+1 ), 1, d( k+1 ), 1 ) + call stdlib_${ri}$copy( n-k, dsigma( k+1 ), 1, d( k+1 ), 1 ) ! determine dsigma(1), dsigma(2), z(1), vf(1), vl(1), vf(m), and ! vl(m). dsigma( 1 ) = zero hlftol = tol / two if( abs( dsigma( 2 ) )<=hlftol )dsigma( 2 ) = hlftol if( m>n ) then - z( 1 ) = stdlib_qlapy2( z1, z( m ) ) + z( 1 ) = stdlib_${ri}$lapy2( z1, z( m ) ) if( z( 1 )<=tol ) then c = one s = zero @@ -44959,8 +44960,8 @@ module stdlib_linalg_lapack_q c = z1 / z( 1 ) s = -z( m ) / z( 1 ) end if - call stdlib_qrot( 1, vf( m ), 1, vf( 1 ), 1, c, s ) - call stdlib_qrot( 1, vl( m ), 1, vl( 1 ), 1, c, s ) + call stdlib_${ri}$rot( 1, vf( m ), 1, vf( 1 ), 1, c, s ) + call stdlib_${ri}$rot( 1, vl( m ), 1, vl( 1 ), 1, c, s ) else if( abs( z1 )<=tol ) then z( 1 ) = tol @@ -44969,14 +44970,14 @@ module stdlib_linalg_lapack_q end if end if ! restore z, vf, and vl. - call stdlib_qcopy( k-1, zw( 2 ), 1, z( 2 ), 1 ) - call stdlib_qcopy( n-1, vfw( 2 ), 1, vf( 2 ), 1 ) - call stdlib_qcopy( n-1, vlw( 2 ), 1, vl( 2 ), 1 ) + call stdlib_${ri}$copy( k-1, zw( 2 ), 1, z( 2 ), 1 ) + call stdlib_${ri}$copy( n-1, vfw( 2 ), 1, vf( 2 ), 1 ) + call stdlib_${ri}$copy( n-1, vlw( 2 ), 1, vl( 2 ), 1 ) return - end subroutine stdlib_qlasd7 + end subroutine stdlib_${ri}$lasd7 - pure subroutine stdlib_qlasd8( icompq, k, d, z, vf, vl, difl, difr, lddifr,dsigma, work, & + pure subroutine stdlib_${ri}$lasd8( icompq, k, d, z, vf, vl, difl, difr, lddifr,dsigma, work, & !! DLASD8: finds the square roots of the roots of the secular equation, !! as defined by the values in DSIGMA and Z. It makes the appropriate !! calls to DLASD4, and stores, for each element in D, the distance @@ -44992,13 +44993,13 @@ module stdlib_linalg_lapack_q integer(ilp), intent(in) :: icompq, k, lddifr integer(ilp), intent(out) :: info ! Array Arguments - real(qp), intent(out) :: d(*), difl(*), difr(lddifr,*), work(*) - real(qp), intent(inout) :: dsigma(*), vf(*), vl(*), z(*) + real(${rk}$), intent(out) :: d(*), difl(*), difr(lddifr,*), work(*) + real(${rk}$), intent(inout) :: dsigma(*), vf(*), vl(*), z(*) ! ===================================================================== ! Local Scalars integer(ilp) :: i, iwk1, iwk2, iwk2i, iwk3, iwk3i, j - real(qp) :: diflj, difrj, dj, dsigj, dsigjp, rho, temp + real(${rk}$) :: diflj, difrj, dj, dsigj, dsigjp, rho, temp ! Intrinsic Functions intrinsic :: abs,sign,sqrt ! Executable Statements @@ -45042,7 +45043,7 @@ module stdlib_linalg_lapack_q ! 2*dlambda(i) to prevent optimizing compilers from eliminating ! this code. do i = 1, k - dsigma( i ) = stdlib_qlamc3( dsigma( i ), dsigma( i ) ) - dsigma( i ) + dsigma( i ) = stdlib_${ri}$lamc3( dsigma( i ), dsigma( i ) ) - dsigma( i ) end do ! book keeping. iwk1 = 1 @@ -45051,15 +45052,15 @@ module stdlib_linalg_lapack_q iwk2i = iwk2 - 1 iwk3i = iwk3 - 1 ! normalize z. - rho = stdlib_qnrm2( k, z, 1 ) - call stdlib_qlascl( 'G', 0, 0, rho, one, k, 1, z, k, info ) + rho = stdlib_${ri}$nrm2( k, z, 1 ) + call stdlib_${ri}$lascl( 'G', 0, 0, rho, one, k, 1, z, k, info ) rho = rho*rho ! initialize work(iwk3). - call stdlib_qlaset( 'A', k, 1, one, one, work( iwk3 ), k ) + call stdlib_${ri}$laset( 'A', k, 1, one, one, work( iwk3 ), k ) ! compute the updated singular values, the arrays difl, difr, ! and the updated z. do j = 1, k - call stdlib_qlasd4( k, j, dsigma, z, work( iwk1 ), rho, d( j ),work( iwk2 ), info ) + call stdlib_${ri}$lasd4( k, j, dsigma, z, work( iwk1 ), rho, d( j ),work( iwk2 ), info ) ! if the root finder fails, report the convergence failure. if( info/=0 ) then @@ -45092,27 +45093,27 @@ module stdlib_linalg_lapack_q end if work( j ) = -z( j ) / diflj / ( dsigma( j )+dj ) do i = 1, j - 1 - work( i ) = z( i ) / ( stdlib_qlamc3( dsigma( i ), dsigj )-diflj )/ ( dsigma( i )& + work( i ) = z( i ) / ( stdlib_${ri}$lamc3( dsigma( i ), dsigj )-diflj )/ ( dsigma( i )& +dj ) end do do i = j + 1, k - work( i ) = z( i ) / ( stdlib_qlamc3( dsigma( i ), dsigjp )+difrj )/ ( dsigma( i & + work( i ) = z( i ) / ( stdlib_${ri}$lamc3( dsigma( i ), dsigjp )+difrj )/ ( dsigma( i & )+dj ) end do - temp = stdlib_qnrm2( k, work, 1 ) - work( iwk2i+j ) = stdlib_qdot( k, work, 1, vf, 1 ) / temp - work( iwk3i+j ) = stdlib_qdot( k, work, 1, vl, 1 ) / temp + temp = stdlib_${ri}$nrm2( k, work, 1 ) + work( iwk2i+j ) = stdlib_${ri}$dot( k, work, 1, vf, 1 ) / temp + work( iwk3i+j ) = stdlib_${ri}$dot( k, work, 1, vl, 1 ) / temp if( icompq==1 ) then difr( j, 2 ) = temp end if end do - call stdlib_qcopy( k, work( iwk2 ), 1, vf, 1 ) - call stdlib_qcopy( k, work( iwk3 ), 1, vl, 1 ) + call stdlib_${ri}$copy( k, work( iwk2 ), 1, vf, 1 ) + call stdlib_${ri}$copy( k, work( iwk3 ), 1, vl, 1 ) return - end subroutine stdlib_qlasd8 + end subroutine stdlib_${ri}$lasd8 - pure subroutine stdlib_qlasda( icompq, smlsiz, n, sqre, d, e, u, ldu, vt, k,difl, difr, z, & + pure subroutine stdlib_${ri}$lasda( icompq, smlsiz, n, sqre, d, e, u, ldu, vt, k,difl, difr, z, & !! Using a divide and conquer approach, DLASDA: computes the singular !! value decomposition (SVD) of a real upper bidiagonal N-by-M matrix !! B with diagonal D and offdiagonal E, where M = N + SQRE. The @@ -45131,16 +45132,16 @@ module stdlib_linalg_lapack_q ! Array Arguments integer(ilp), intent(out) :: givcol(ldgcol,*), givptr(*), iwork(*), k(*), perm(ldgcol,& *) - real(qp), intent(out) :: c(*), difl(ldu,*), difr(ldu,*), givnum(ldu,*), poles(ldu,*), & + real(${rk}$), intent(out) :: c(*), difl(ldu,*), difr(ldu,*), givnum(ldu,*), poles(ldu,*), & s(*), u(ldu,*), vt(ldu,*), work(*), z(ldu,*) - real(qp), intent(inout) :: d(*), e(*) + real(${rk}$), intent(inout) :: d(*), e(*) ! ===================================================================== ! Local Scalars integer(ilp) :: i, i1, ic, idxq, idxqi, im1, inode, itemp, iwk, j, lf, ll, lvl, lvl2, & m, ncc, nd, ndb1, ndiml, ndimr, nl, nlf, nlp1, nlvl, nr, nrf, nrp1, nru, nwork1, & nwork2, smlszp, sqrei, vf, vfi, vl, vli - real(qp) :: alpha, beta + real(${rk}$) :: alpha, beta ! Executable Statements ! test the input parameters. info = 0 @@ -45162,13 +45163,13 @@ module stdlib_linalg_lapack_q return end if m = n + sqre - ! if the input matrix is too small, call stdlib_qlasdq to find the svd. + ! if the input matrix is too small, call stdlib_${ri}$lasdq to find the svd. if( n<=smlsiz ) then if( icompq==0 ) then - call stdlib_qlasdq( 'U', sqre, n, 0, 0, 0, d, e, vt, ldu, u, ldu,u, ldu, work, & + call stdlib_${ri}$lasdq( 'U', sqre, n, 0, 0, 0, d, e, vt, ldu, u, ldu,u, ldu, work, & info ) else - call stdlib_qlasdq( 'U', sqre, n, m, n, 0, d, e, vt, ldu, u, ldu,u, ldu, work, & + call stdlib_${ri}$lasdq( 'U', sqre, n, m, n, 0, d, e, vt, ldu, u, ldu,u, ldu, work, & info ) end if return @@ -45186,10 +45187,10 @@ module stdlib_linalg_lapack_q vl = vf + m nwork1 = vl + m nwork2 = nwork1 + smlszp*smlszp - call stdlib_qlasdt( n, nlvl, nd, iwork( inode ), iwork( ndiml ),iwork( ndimr ), smlsiz & + call stdlib_${ri}$lasdt( n, nlvl, nd, iwork( inode ), iwork( ndiml ),iwork( ndimr ), smlsiz & ) ! for the nodes on bottom level of the tree, solve - ! their subproblems by stdlib_qlasdq. + ! their subproblems by stdlib_${ri}$lasdq. ndb1 = ( nd+1 ) / 2 loop_30: do i = ndb1, nd ! ic : center row of each node @@ -45209,20 +45210,20 @@ module stdlib_linalg_lapack_q vli = vl + nlf - 1 sqrei = 1 if( icompq==0 ) then - call stdlib_qlaset( 'A', nlp1, nlp1, zero, one, work( nwork1 ),smlszp ) - call stdlib_qlasdq( 'U', sqrei, nl, nlp1, nru, ncc, d( nlf ),e( nlf ), work( & + call stdlib_${ri}$laset( 'A', nlp1, nlp1, zero, one, work( nwork1 ),smlszp ) + call stdlib_${ri}$lasdq( 'U', sqrei, nl, nlp1, nru, ncc, d( nlf ),e( nlf ), work( & nwork1 ), smlszp,work( nwork2 ), nl, work( nwork2 ), nl,work( nwork2 ), info ) itemp = nwork1 + nl*smlszp - call stdlib_qcopy( nlp1, work( nwork1 ), 1, work( vfi ), 1 ) - call stdlib_qcopy( nlp1, work( itemp ), 1, work( vli ), 1 ) + call stdlib_${ri}$copy( nlp1, work( nwork1 ), 1, work( vfi ), 1 ) + call stdlib_${ri}$copy( nlp1, work( itemp ), 1, work( vli ), 1 ) else - call stdlib_qlaset( 'A', nl, nl, zero, one, u( nlf, 1 ), ldu ) - call stdlib_qlaset( 'A', nlp1, nlp1, zero, one, vt( nlf, 1 ), ldu ) - call stdlib_qlasdq( 'U', sqrei, nl, nlp1, nl, ncc, d( nlf ),e( nlf ), vt( nlf, 1 & + call stdlib_${ri}$laset( 'A', nl, nl, zero, one, u( nlf, 1 ), ldu ) + call stdlib_${ri}$laset( 'A', nlp1, nlp1, zero, one, vt( nlf, 1 ), ldu ) + call stdlib_${ri}$lasdq( 'U', sqrei, nl, nlp1, nl, ncc, d( nlf ),e( nlf ), vt( nlf, 1 & ), ldu, u( nlf, 1 ), ldu,u( nlf, 1 ), ldu, work( nwork1 ), info ) - call stdlib_qcopy( nlp1, vt( nlf, 1 ), 1, work( vfi ), 1 ) - call stdlib_qcopy( nlp1, vt( nlf, nlp1 ), 1, work( vli ), 1 ) + call stdlib_${ri}$copy( nlp1, vt( nlf, 1 ), 1, work( vfi ), 1 ) + call stdlib_${ri}$copy( nlp1, vt( nlf, nlp1 ), 1, work( vli ), 1 ) end if if( info/=0 ) then return @@ -45240,20 +45241,20 @@ module stdlib_linalg_lapack_q vli = vli + nlp1 nrp1 = nr + sqrei if( icompq==0 ) then - call stdlib_qlaset( 'A', nrp1, nrp1, zero, one, work( nwork1 ),smlszp ) - call stdlib_qlasdq( 'U', sqrei, nr, nrp1, nru, ncc, d( nrf ),e( nrf ), work( & + call stdlib_${ri}$laset( 'A', nrp1, nrp1, zero, one, work( nwork1 ),smlszp ) + call stdlib_${ri}$lasdq( 'U', sqrei, nr, nrp1, nru, ncc, d( nrf ),e( nrf ), work( & nwork1 ), smlszp,work( nwork2 ), nr, work( nwork2 ), nr,work( nwork2 ), info ) itemp = nwork1 + ( nrp1-1 )*smlszp - call stdlib_qcopy( nrp1, work( nwork1 ), 1, work( vfi ), 1 ) - call stdlib_qcopy( nrp1, work( itemp ), 1, work( vli ), 1 ) + call stdlib_${ri}$copy( nrp1, work( nwork1 ), 1, work( vfi ), 1 ) + call stdlib_${ri}$copy( nrp1, work( itemp ), 1, work( vli ), 1 ) else - call stdlib_qlaset( 'A', nr, nr, zero, one, u( nrf, 1 ), ldu ) - call stdlib_qlaset( 'A', nrp1, nrp1, zero, one, vt( nrf, 1 ), ldu ) - call stdlib_qlasdq( 'U', sqrei, nr, nrp1, nr, ncc, d( nrf ),e( nrf ), vt( nrf, 1 & + call stdlib_${ri}$laset( 'A', nr, nr, zero, one, u( nrf, 1 ), ldu ) + call stdlib_${ri}$laset( 'A', nrp1, nrp1, zero, one, vt( nrf, 1 ), ldu ) + call stdlib_${ri}$lasdq( 'U', sqrei, nr, nrp1, nr, ncc, d( nrf ),e( nrf ), vt( nrf, 1 & ), ldu, u( nrf, 1 ), ldu,u( nrf, 1 ), ldu, work( nwork1 ), info ) - call stdlib_qcopy( nrp1, vt( nrf, 1 ), 1, work( vfi ), 1 ) - call stdlib_qcopy( nrp1, vt( nrf, nrp1 ), 1, work( vli ), 1 ) + call stdlib_${ri}$copy( nrp1, vt( nrf, 1 ), 1, work( vfi ), 1 ) + call stdlib_${ri}$copy( nrp1, vt( nrf, nrp1 ), 1, work( vli ), 1 ) end if if( info/=0 ) then return @@ -45293,13 +45294,13 @@ module stdlib_linalg_lapack_q alpha = d( ic ) beta = e( ic ) if( icompq==0 ) then - call stdlib_qlasd6( icompq, nl, nr, sqrei, d( nlf ),work( vfi ), work( vli ), & + call stdlib_${ri}$lasd6( icompq, nl, nr, sqrei, d( nlf ),work( vfi ), work( vli ), & alpha, beta,iwork( idxqi ), perm, givptr( 1 ), givcol,ldgcol, givnum, ldu, & poles, difl, difr, z,k( 1 ), c( 1 ), s( 1 ), work( nwork1 ),iwork( iwk ), & info ) else j = j - 1 - call stdlib_qlasd6( icompq, nl, nr, sqrei, d( nlf ),work( vfi ), work( vli ), & + call stdlib_${ri}$lasd6( icompq, nl, nr, sqrei, d( nlf ),work( vfi ), work( vli ), & alpha, beta,iwork( idxqi ), perm( nlf, lvl ),givptr( j ), givcol( nlf, lvl2 ),& ldgcol,givnum( nlf, lvl2 ), ldu,poles( nlf, lvl2 ), difl( nlf, lvl ),difr( & nlf, lvl2 ), z( nlf, lvl ), k( j ),c( j ), s( j ), work( nwork1 ),iwork( iwk & @@ -45311,10 +45312,10 @@ module stdlib_linalg_lapack_q end do loop_40 end do loop_50 return - end subroutine stdlib_qlasda + end subroutine stdlib_${ri}$lasda - pure subroutine stdlib_qlasdq( uplo, sqre, n, ncvt, nru, ncc, d, e, vt, ldvt,u, ldu, c, ldc, & + pure subroutine stdlib_${ri}$lasdq( uplo, sqre, n, ncvt, nru, ncc, d, e, vt, ldvt,u, ldu, c, ldc, & !! DLASDQ: computes the singular value decomposition (SVD) of a real !! (upper or lower) bidiagonal matrix with diagonal D and offdiagonal !! E, accumulating the transformations if desired. Letting B denote @@ -45336,14 +45337,14 @@ module stdlib_linalg_lapack_q integer(ilp), intent(out) :: info integer(ilp), intent(in) :: ldc, ldu, ldvt, n, ncc, ncvt, nru, sqre ! Array Arguments - real(qp), intent(inout) :: c(ldc,*), d(*), e(*), u(ldu,*), vt(ldvt,*) - real(qp), intent(out) :: work(*) + real(${rk}$), intent(inout) :: c(ldc,*), d(*), e(*), u(ldu,*), vt(ldvt,*) + real(${rk}$), intent(out) :: work(*) ! ===================================================================== ! Local Scalars logical(lk) :: rotate integer(ilp) :: i, isub, iuplo, j, np1, sqre1 - real(qp) :: cs, r, smin, sn + real(${rk}$) :: cs, r, smin, sn ! Intrinsic Functions intrinsic :: max ! Executable Statements @@ -45384,7 +45385,7 @@ module stdlib_linalg_lapack_q ! bidiagonal. the rotations are on the right. if( ( iuplo==1 ) .and. ( sqre1==1 ) ) then do i = 1, n - 1 - call stdlib_qlartg( d( i ), e( i ), cs, sn, r ) + call stdlib_${ri}$lartg( d( i ), e( i ), cs, sn, r ) d( i ) = r e( i ) = sn*d( i+1 ) d( i+1 ) = cs*d( i+1 ) @@ -45393,7 +45394,7 @@ module stdlib_linalg_lapack_q work( n+i ) = sn end if end do - call stdlib_qlartg( d( n ), e( n ), cs, sn, r ) + call stdlib_${ri}$lartg( d( n ), e( n ), cs, sn, r ) d( n ) = r e( n ) = zero if( rotate ) then @@ -45403,14 +45404,14 @@ module stdlib_linalg_lapack_q iuplo = 2 sqre1 = 0 ! update singular vectors if desired. - if( ncvt>0 )call stdlib_qlasr( 'L', 'V', 'F', np1, ncvt, work( 1 ),work( np1 ), vt, & + if( ncvt>0 )call stdlib_${ri}$lasr( 'L', 'V', 'F', np1, ncvt, work( 1 ),work( np1 ), vt, & ldvt ) end if ! if matrix lower bidiagonal, rotate to be upper bidiagonal ! by applying givens rotations on the left. if( iuplo==2 ) then do i = 1, n - 1 - call stdlib_qlartg( d( i ), e( i ), cs, sn, r ) + call stdlib_${ri}$lartg( d( i ), e( i ), cs, sn, r ) d( i ) = r e( i ) = sn*d( i+1 ) d( i+1 ) = cs*d( i+1 ) @@ -45422,7 +45423,7 @@ module stdlib_linalg_lapack_q ! if matrix (n+1)-by-n lower bidiagonal, one additional ! rotation is needed. if( sqre1==1 ) then - call stdlib_qlartg( d( n ), e( n ), cs, sn, r ) + call stdlib_${ri}$lartg( d( n ), e( n ), cs, sn, r ) d( n ) = r if( rotate ) then work( n ) = cs @@ -45432,26 +45433,26 @@ module stdlib_linalg_lapack_q ! update singular vectors if desired. if( nru>0 ) then if( sqre1==0 ) then - call stdlib_qlasr( 'R', 'V', 'F', nru, n, work( 1 ),work( np1 ), u, ldu ) + call stdlib_${ri}$lasr( 'R', 'V', 'F', nru, n, work( 1 ),work( np1 ), u, ldu ) else - call stdlib_qlasr( 'R', 'V', 'F', nru, np1, work( 1 ),work( np1 ), u, ldu ) + call stdlib_${ri}$lasr( 'R', 'V', 'F', nru, np1, work( 1 ),work( np1 ), u, ldu ) end if end if if( ncc>0 ) then if( sqre1==0 ) then - call stdlib_qlasr( 'L', 'V', 'F', n, ncc, work( 1 ),work( np1 ), c, ldc ) + call stdlib_${ri}$lasr( 'L', 'V', 'F', n, ncc, work( 1 ),work( np1 ), c, ldc ) else - call stdlib_qlasr( 'L', 'V', 'F', np1, ncc, work( 1 ),work( np1 ), c, ldc ) + call stdlib_${ri}$lasr( 'L', 'V', 'F', np1, ncc, work( 1 ),work( np1 ), c, ldc ) end if end if end if - ! call stdlib_qbdsqr to compute the svd of the reduced real + ! call stdlib_${ri}$bdsqr to compute the svd of the reduced real ! n-by-n upper bidiagonal matrix. - call stdlib_qbdsqr( 'U', n, ncvt, nru, ncc, d, e, vt, ldvt, u, ldu, c,ldc, work, info ) + call stdlib_${ri}$bdsqr( 'U', n, ncvt, nru, ncc, d, e, vt, ldvt, u, ldu, c,ldc, work, info ) ! sort the singular values into ascending order (insertion sort on ! singular values, but only one transposition per singular vector) @@ -45469,17 +45470,17 @@ module stdlib_linalg_lapack_q ! swap singular values and vectors. d( isub ) = d( i ) d( i ) = smin - if( ncvt>0 )call stdlib_qswap( ncvt, vt( isub, 1 ), ldvt, vt( i, 1 ), ldvt ) + if( ncvt>0 )call stdlib_${ri}$swap( ncvt, vt( isub, 1 ), ldvt, vt( i, 1 ), ldvt ) - if( nru>0 )call stdlib_qswap( nru, u( 1, isub ), 1, u( 1, i ), 1 ) - if( ncc>0 )call stdlib_qswap( ncc, c( isub, 1 ), ldc, c( i, 1 ), ldc ) + if( nru>0 )call stdlib_${ri}$swap( nru, u( 1, isub ), 1, u( 1, i ), 1 ) + if( ncc>0 )call stdlib_${ri}$swap( ncc, c( isub, 1 ), ldc, c( i, 1 ), ldc ) end if end do return - end subroutine stdlib_qlasdq + end subroutine stdlib_${ri}$lasdq - pure subroutine stdlib_qlasdt( n, lvl, nd, inode, ndiml, ndimr, msub ) + pure subroutine stdlib_${ri}$lasdt( n, lvl, nd, inode, ndiml, ndimr, msub ) !! DLASDT: creates a tree of subproblems for bidiagonal divide and !! conquer. ! -- lapack auxiliary routine -- @@ -45494,13 +45495,13 @@ module stdlib_linalg_lapack_q ! Local Scalars integer(ilp) :: i, il, ir, llst, maxn, ncrnt, nlvl - real(qp) :: temp + real(${rk}$) :: temp ! Intrinsic Functions intrinsic :: real,int,log,max ! Executable Statements ! find the number of levels on the tree. maxn = max( 1, n ) - temp = log( real( maxn,KIND=qp) / real( msub+1,KIND=qp) ) / log( two ) + temp = log( real( maxn,KIND=${rk}$) / real( msub+1,KIND=${rk}$) ) / log( two ) lvl = int( temp,KIND=ilp) + 1 i = n / 2 inode( 1 ) = i + 1 @@ -45527,10 +45528,10 @@ module stdlib_linalg_lapack_q end do nd = llst*2 - 1 return - end subroutine stdlib_qlasdt + end subroutine stdlib_${ri}$lasdt - pure subroutine stdlib_qlaset( uplo, m, n, alpha, beta, a, lda ) + pure subroutine stdlib_${ri}$laset( uplo, m, n, alpha, beta, a, lda ) !! DLASET: initializes an m-by-n matrix A to BETA on the diagonal and !! ALPHA on the offdiagonals. ! -- lapack auxiliary routine -- @@ -45539,9 +45540,9 @@ module stdlib_linalg_lapack_q ! Scalar Arguments character, intent(in) :: uplo integer(ilp), intent(in) :: lda, m, n - real(qp), intent(in) :: alpha, beta + real(${rk}$), intent(in) :: alpha, beta ! Array Arguments - real(qp), intent(out) :: a(lda,*) + real(${rk}$), intent(out) :: a(lda,*) ! ===================================================================== ! Local Scalars integer(ilp) :: i, j @@ -45577,10 +45578,10 @@ module stdlib_linalg_lapack_q a( i, i ) = beta end do return - end subroutine stdlib_qlaset + end subroutine stdlib_${ri}$laset - pure subroutine stdlib_qlasq1( n, d, e, work, info ) + pure subroutine stdlib_${ri}$lasq1( n, d, e, work, info ) !! DLASQ1: computes the singular values of a real N-by-N bidiagonal !! matrix with diagonal D and off-diagonal E. The singular values !! are computed to high relative accuracy, in the absence of @@ -45598,13 +45599,13 @@ module stdlib_linalg_lapack_q integer(ilp), intent(out) :: info integer(ilp), intent(in) :: n ! Array Arguments - real(qp), intent(inout) :: d(*), e(*) - real(qp), intent(out) :: work(*) + real(${rk}$), intent(inout) :: d(*), e(*) + real(${rk}$), intent(out) :: work(*) ! ===================================================================== ! Local Scalars integer(ilp) :: i, iinfo - real(qp) :: eps, scale, safmin, sigmn, sigmx + real(${rk}$) :: eps, scale, safmin, sigmn, sigmx ! Intrinsic Functions intrinsic :: abs,max,sqrt ! Executable Statements @@ -45619,7 +45620,7 @@ module stdlib_linalg_lapack_q d( 1 ) = abs( d( 1 ) ) return else if( n==2 ) then - call stdlib_qlas2( d( 1 ), e( 1 ), d( 2 ), sigmn, sigmx ) + call stdlib_${ri}$las2( d( 1 ), e( 1 ), d( 2 ), sigmn, sigmx ) d( 1 ) = sigmx d( 2 ) = sigmn return @@ -45633,7 +45634,7 @@ module stdlib_linalg_lapack_q d( n ) = abs( d( n ) ) ! early return if sigmx is zero (matrix is already diagonal). if( sigmx==zero ) then - call stdlib_qlasrt( 'D', n, d, iinfo ) + call stdlib_${ri}$lasrt( 'D', n, d, iinfo ) return end if do i = 1, n @@ -45641,23 +45642,23 @@ module stdlib_linalg_lapack_q end do ! copy d and e into work (in the z format) and scale (squaring the ! input data makes scaling by a power of the radix pointless). - eps = stdlib_qlamch( 'PRECISION' ) - safmin = stdlib_qlamch( 'SAFE MINIMUM' ) + eps = stdlib_${ri}$lamch( 'PRECISION' ) + safmin = stdlib_${ri}$lamch( 'SAFE MINIMUM' ) scale = sqrt( eps / safmin ) - call stdlib_qcopy( n, d, 1, work( 1 ), 2 ) - call stdlib_qcopy( n-1, e, 1, work( 2 ), 2 ) - call stdlib_qlascl( 'G', 0, 0, sigmx, scale, 2*n-1, 1, work, 2*n-1,iinfo ) + call stdlib_${ri}$copy( n, d, 1, work( 1 ), 2 ) + call stdlib_${ri}$copy( n-1, e, 1, work( 2 ), 2 ) + call stdlib_${ri}$lascl( 'G', 0, 0, sigmx, scale, 2*n-1, 1, work, 2*n-1,iinfo ) ! compute the q's and e's. do i = 1, 2*n - 1 work( i ) = work( i )**2 end do work( 2*n ) = zero - call stdlib_qlasq2( n, work, info ) + call stdlib_${ri}$lasq2( n, work, info ) if( info==0 ) then do i = 1, n d( i ) = sqrt( work( i ) ) end do - call stdlib_qlascl( 'G', 0, 0, scale, sigmx, n, 1, d, n, iinfo ) + call stdlib_${ri}$lascl( 'G', 0, 0, scale, sigmx, n, 1, d, n, iinfo ) else if( info==2 ) then ! maximum number of iterations exceeded. move data from work ! into d and e so the calling subroutine can try to finish @@ -45665,14 +45666,14 @@ module stdlib_linalg_lapack_q d( i ) = sqrt( work( 2*i-1 ) ) e( i ) = sqrt( work( 2*i ) ) end do - call stdlib_qlascl( 'G', 0, 0, scale, sigmx, n, 1, d, n, iinfo ) - call stdlib_qlascl( 'G', 0, 0, scale, sigmx, n, 1, e, n, iinfo ) + call stdlib_${ri}$lascl( 'G', 0, 0, scale, sigmx, n, 1, d, n, iinfo ) + call stdlib_${ri}$lascl( 'G', 0, 0, scale, sigmx, n, 1, e, n, iinfo ) end if return - end subroutine stdlib_qlasq1 + end subroutine stdlib_${ri}$lasq1 - pure subroutine stdlib_qlasq2( n, z, info ) + pure subroutine stdlib_${ri}$lasq2( n, z, info ) !! DLASQ2: computes all the eigenvalues of the symmetric positive !! definite tridiagonal matrix associated with the qd array Z to high !! relative accuracy are computed to high relative accuracy, in the @@ -45693,28 +45694,28 @@ module stdlib_linalg_lapack_q integer(ilp), intent(out) :: info integer(ilp), intent(in) :: n ! Array Arguments - real(qp), intent(inout) :: z(*) + real(${rk}$), intent(inout) :: z(*) ! ===================================================================== ! Parameters - real(qp), parameter :: cbias = 1.50_qp - real(qp), parameter :: hundrd = 100.0_qp + real(${rk}$), parameter :: cbias = 1.50_${rk}$ + real(${rk}$), parameter :: hundrd = 100.0_${rk}$ ! Local Scalars logical(lk) :: ieee integer(ilp) :: i0, i1, i4, iinfo, ipn4, iter, iwhila, iwhilb, k, kmin, n0, n1, nbig, & ndiv, nfail, pp, splt, ttype - real(qp) :: d, dee, deemin, desig, dmin, dmin1, dmin2, dn, dn1, dn2, e, emax, emin, & + real(${rk}$) :: d, dee, deemin, desig, dmin, dmin1, dmin2, dn, dn1, dn2, e, emax, emin, & eps, g, oldemn, qmax, qmin, s, safmin, sigma, t, tau, temp, tol, tol2, trace, zmax, & tempe, tempq ! Intrinsic Functions intrinsic :: abs,real,max,min,sqrt ! Executable Statements ! test the input arguments. - ! (in case stdlib_qlasq2 is not called by stdlib_qlasq1) + ! (in case stdlib_${ri}$lasq2 is not called by stdlib_${ri}$lasq1) info = 0 - eps = stdlib_qlamch( 'PRECISION' ) - safmin = stdlib_qlamch( 'SAFE MINIMUM' ) + eps = stdlib_${ri}$lamch( 'PRECISION' ) + safmin = stdlib_${ri}$lamch( 'SAFE MINIMUM' ) tol = eps*hundrd tol2 = tol**2 if( n<0 ) then @@ -45802,7 +45803,7 @@ module stdlib_linalg_lapack_q do k = 2, n z( k ) = z( 2*k-1 ) end do - call stdlib_qlasrt( 'D', n, z, iinfo ) + call stdlib_${ri}$lasrt( 'D', n, z, iinfo ) z( 2*n-1 ) = d return end if @@ -45877,7 +45878,7 @@ module stdlib_linalg_lapack_q ! prepare for the next iteration on k. pp = 1 - pp end do loop_80 - ! initialise variables to pass to stdlib_qlasq3. + ! initialise variables to pass to stdlib_${ri}$lasq3. ttype = 0 dmin1 = zero dmin2 = zero @@ -45962,13 +45963,13 @@ module stdlib_linalg_lapack_q ! now i0:n0 is unreduced. ! pp = 0 for ping, pp = 1 for pong. ! pp = 2 indicates that flipping was applied to the z array and - ! and that the tests for deflation upon entry in stdlib_qlasq3 + ! and that the tests for deflation upon entry in stdlib_${ri}$lasq3 ! should not be performed. nbig = 100*( n0-i0+1 ) loop_140: do iwhilb = 1, nbig if( i0>n0 )go to 150 ! while submatrix unfinished take a good dqds step. - call stdlib_qlasq3( i0, n0, z, pp, dmin, sigma, desig, qmax, nfail,iter, ndiv, & + call stdlib_${ri}$lasq3( i0, n0, z, pp, dmin, sigma, desig, qmax, nfail,iter, ndiv, & ieee, ttype, dmin1, dmin2, dn, dn1,dn2, g, tau ) pp = 1 - pp ! when emin is very small check for splits. @@ -46045,7 +46046,7 @@ module stdlib_linalg_lapack_q z( k ) = z( 4*k-3 ) end do ! sort and compute sum of eigenvalues. - call stdlib_qlasrt( 'D', n, z, iinfo ) + call stdlib_${ri}$lasrt( 'D', n, z, iinfo ) e = zero do k = n, 1, -1 e = e + z( k ) @@ -46053,14 +46054,14 @@ module stdlib_linalg_lapack_q ! store trace, sum(eigenvalues) and information on performance. z( 2*n+1 ) = trace z( 2*n+2 ) = e - z( 2*n+3 ) = real( iter,KIND=qp) - z( 2*n+4 ) = real( ndiv,KIND=qp) / real( n**2,KIND=qp) - z( 2*n+5 ) = hundrd*nfail / real( iter,KIND=qp) + z( 2*n+3 ) = real( iter,KIND=${rk}$) + z( 2*n+4 ) = real( ndiv,KIND=${rk}$) / real( n**2,KIND=${rk}$) + z( 2*n+5 ) = hundrd*nfail / real( iter,KIND=${rk}$) return - end subroutine stdlib_qlasq2 + end subroutine stdlib_${ri}$lasq2 - pure subroutine stdlib_qlasq3( i0, n0, z, pp, dmin, sigma, desig, qmax, nfail,iter, ndiv, & + pure subroutine stdlib_${ri}$lasq3( i0, n0, z, pp, dmin, sigma, desig, qmax, nfail,iter, ndiv, & !! DLASQ3: checks for deflation, computes a shift (TAU) and calls dqds. !! In case of failure it changes shifts, and tries again until output !! is positive. @@ -46072,26 +46073,26 @@ module stdlib_linalg_lapack_q logical(lk), intent(in) :: ieee integer(ilp), intent(in) :: i0 integer(ilp), intent(inout) :: iter, n0, ndiv, nfail, pp - real(qp), intent(inout) :: desig, dmin1, dmin2, dn, dn1, dn2, g, qmax, tau - real(qp), intent(out) :: dmin, sigma + real(${rk}$), intent(inout) :: desig, dmin1, dmin2, dn, dn1, dn2, g, qmax, tau + real(${rk}$), intent(out) :: dmin, sigma ! Array Arguments - real(qp), intent(inout) :: z(*) + real(${rk}$), intent(inout) :: z(*) ! ===================================================================== ! Parameters - real(qp), parameter :: cbias = 1.50_qp - real(qp), parameter :: qurtr = 0.250_qp - real(qp), parameter :: hundrd = 100.0_qp + real(${rk}$), parameter :: cbias = 1.50_${rk}$ + real(${rk}$), parameter :: qurtr = 0.250_${rk}$ + real(${rk}$), parameter :: hundrd = 100.0_${rk}$ ! Local Scalars integer(ilp) :: ipn4, j4, n0in, nn integer(ilp), intent(inout) :: ttype - real(qp) :: eps, s, t, temp, tol, tol2 + real(${rk}$) :: eps, s, t, temp, tol, tol2 ! Intrinsic Functions intrinsic :: abs,max,min,sqrt ! Executable Statements n0in = n0 - eps = stdlib_qlamch( 'PRECISION' ) + eps = stdlib_${ri}$lamch( 'PRECISION' ) tol = eps*hundrd tol2 = tol**2 ! check for deflation. @@ -46164,11 +46165,11 @@ module stdlib_linalg_lapack_q end if end if ! choose a shift. - call stdlib_qlasq4( i0, n0, z, pp, n0in, dmin, dmin1, dmin2, dn, dn1,dn2, tau, ttype, & + call stdlib_${ri}$lasq4( i0, n0, z, pp, n0in, dmin, dmin1, dmin2, dn, dn1,dn2, tau, ttype, & g ) ! call dqds until dmin > 0. 70 continue - call stdlib_qlasq5( i0, n0, z, pp, tau, sigma, dmin, dmin1, dmin2, dn,dn1, dn2, ieee, & + call stdlib_${ri}$lasq5( i0, n0, z, pp, tau, sigma, dmin, dmin1, dmin2, dn,dn1, dn2, ieee, & eps ) ndiv = ndiv + ( n0-i0+2 ) iter = iter + 1 @@ -46198,7 +46199,7 @@ module stdlib_linalg_lapack_q ttype = ttype - 12 end if go to 70 - else if( stdlib_qisnan( dmin ) ) then + else if( stdlib_${ri}$isnan( dmin ) ) then ! nan. if( tau==zero ) then go to 80 @@ -46212,7 +46213,7 @@ module stdlib_linalg_lapack_q end if ! risk of underflow. 80 continue - call stdlib_qlasq6( i0, n0, z, pp, dmin, dmin1, dmin2, dn, dn1, dn2 ) + call stdlib_${ri}$lasq6( i0, n0, z, pp, dmin, dmin1, dmin2, dn, dn1, dn2 ) ndiv = ndiv + ( n0-i0+2 ) iter = iter + 1 tau = zero @@ -46227,10 +46228,10 @@ module stdlib_linalg_lapack_q end if sigma = t return - end subroutine stdlib_qlasq3 + end subroutine stdlib_${ri}$lasq3 - pure subroutine stdlib_qlasq4( i0, n0, z, pp, n0in, dmin, dmin1, dmin2, dn,dn1, dn2, tau, & + pure subroutine stdlib_${ri}$lasq4( i0, n0, z, pp, n0in, dmin, dmin1, dmin2, dn,dn1, dn2, tau, & !! DLASQ4: computes an approximation TAU to the smallest eigenvalue !! using values of d from the previous transform. ttype, g ) @@ -46240,24 +46241,24 @@ module stdlib_linalg_lapack_q ! Scalar Arguments integer(ilp), intent(in) :: i0, n0, n0in, pp integer(ilp), intent(out) :: ttype - real(qp), intent(in) :: dmin, dmin1, dmin2, dn, dn1, dn2 - real(qp), intent(inout) :: g - real(qp), intent(out) :: tau + real(${rk}$), intent(in) :: dmin, dmin1, dmin2, dn, dn1, dn2 + real(${rk}$), intent(inout) :: g + real(${rk}$), intent(out) :: tau ! Array Arguments - real(qp), intent(in) :: z(*) + real(${rk}$), intent(in) :: z(*) ! ===================================================================== ! Parameters - real(qp), parameter :: cnst1 = 0.5630_qp - real(qp), parameter :: cnst2 = 1.010_qp - real(qp), parameter :: cnst3 = 1.050_qp - real(qp), parameter :: qurtr = 0.250_qp - real(qp), parameter :: third = 0.3330_qp - real(qp), parameter :: hundrd = 100.0_qp + real(${rk}$), parameter :: cnst1 = 0.5630_${rk}$ + real(${rk}$), parameter :: cnst2 = 1.010_${rk}$ + real(${rk}$), parameter :: cnst3 = 1.050_${rk}$ + real(${rk}$), parameter :: qurtr = 0.250_${rk}$ + real(${rk}$), parameter :: third = 0.3330_${rk}$ + real(${rk}$), parameter :: hundrd = 100.0_${rk}$ ! Local Scalars integer(ilp) :: i4, nn, np - real(qp) :: a2, b1, b2, gam, gap1, gap2, s + real(${rk}$) :: a2, b1, b2, gam, gap1, gap2, s ! Intrinsic Functions intrinsic :: max,min,sqrt ! Executable Statements @@ -46435,10 +46436,10 @@ module stdlib_linalg_lapack_q end if tau = s return - end subroutine stdlib_qlasq4 + end subroutine stdlib_${ri}$lasq4 - pure subroutine stdlib_qlasq5( i0, n0, z, pp, tau, sigma, dmin, dmin1, dmin2,dn, dnm1, dnm2, & + pure subroutine stdlib_${ri}$lasq5( i0, n0, z, pp, tau, sigma, dmin, dmin1, dmin2,dn, dnm1, dnm2, & !! DLASQ5: computes one dqds transform in ping-pong form, one !! version for IEEE machines another for non IEEE machines. ieee, eps ) @@ -46448,16 +46449,16 @@ module stdlib_linalg_lapack_q ! Scalar Arguments logical(lk), intent(in) :: ieee integer(ilp), intent(in) :: i0, n0, pp - real(qp), intent(out) :: dmin, dmin1, dmin2, dn, dnm1, dnm2 - real(qp), intent(inout) :: tau - real(qp), intent(in) :: sigma, eps + real(${rk}$), intent(out) :: dmin, dmin1, dmin2, dn, dnm1, dnm2 + real(${rk}$), intent(inout) :: tau + real(${rk}$), intent(in) :: sigma, eps ! Array Arguments - real(qp), intent(inout) :: z(*) + real(${rk}$), intent(inout) :: z(*) ! ===================================================================== ! Local Scalars integer(ilp) :: j4, j4p2 - real(qp) :: d, emin, temp, dthresh + real(${rk}$) :: d, emin, temp, dthresh ! Intrinsic Functions intrinsic :: min ! Executable Statements @@ -46663,10 +46664,10 @@ module stdlib_linalg_lapack_q z( j4+2 ) = dn z( 4*n0-pp ) = emin return - end subroutine stdlib_qlasq5 + end subroutine stdlib_${ri}$lasq5 - pure subroutine stdlib_qlasq6( i0, n0, z, pp, dmin, dmin1, dmin2, dn,dnm1, dnm2 ) + pure subroutine stdlib_${ri}$lasq6( i0, n0, z, pp, dmin, dmin1, dmin2, dn,dnm1, dnm2 ) !! DLASQ6: computes one dqd (shift equal to zero) transform in !! ping-pong form, with protection against underflow and overflow. ! -- lapack computational routine -- @@ -46674,19 +46675,19 @@ module stdlib_linalg_lapack_q ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments integer(ilp), intent(in) :: i0, n0, pp - real(qp), intent(out) :: dmin, dmin1, dmin2, dn, dnm1, dnm2 + real(${rk}$), intent(out) :: dmin, dmin1, dmin2, dn, dnm1, dnm2 ! Array Arguments - real(qp), intent(inout) :: z(*) + real(${rk}$), intent(inout) :: z(*) ! ===================================================================== ! Local Scalars integer(ilp) :: j4, j4p2 - real(qp) :: d, emin, safmin, temp + real(${rk}$) :: d, emin, safmin, temp ! Intrinsic Functions intrinsic :: min ! Executable Statements if( ( n0-i0-1 )<=0 )return - safmin = stdlib_qlamch( 'SAFE MINIMUM' ) + safmin = stdlib_${ri}$lamch( 'SAFE MINIMUM' ) j4 = 4*i0 + pp - 3 emin = z( j4+4 ) d = z( j4 ) @@ -46773,10 +46774,10 @@ module stdlib_linalg_lapack_q z( j4+2 ) = dn z( 4*n0-pp ) = emin return - end subroutine stdlib_qlasq6 + end subroutine stdlib_${ri}$lasq6 - pure subroutine stdlib_qlasr( side, pivot, direct, m, n, c, s, a, lda ) + pure subroutine stdlib_${ri}$lasr( side, pivot, direct, m, n, c, s, a, lda ) !! DLASR: applies a sequence of plane rotations to a real matrix A, !! from either the left or the right. !! When SIDE = 'L', the transformation takes the form @@ -46835,13 +46836,13 @@ module stdlib_linalg_lapack_q character, intent(in) :: direct, pivot, side integer(ilp), intent(in) :: lda, m, n ! Array Arguments - real(qp), intent(inout) :: a(lda,*) - real(qp), intent(in) :: c(*), s(*) + real(${rk}$), intent(inout) :: a(lda,*) + real(${rk}$), intent(in) :: c(*), s(*) ! ===================================================================== ! Local Scalars integer(ilp) :: i, info, j - real(qp) :: ctemp, stemp, temp + real(${rk}$) :: ctemp, stemp, temp ! Intrinsic Functions intrinsic :: max ! Executable Statements @@ -47032,10 +47033,10 @@ module stdlib_linalg_lapack_q end if end if return - end subroutine stdlib_qlasr + end subroutine stdlib_${ri}$lasr - pure subroutine stdlib_qlasrt( id, n, d, info ) + pure subroutine stdlib_${ri}$lasrt( id, n, d, info ) !! Sort the numbers in D in increasing order (if ID = 'I') or !! in decreasing order (if ID = 'D' ). !! Use Quick Sort, reverting to Insertion sort on arrays of @@ -47048,14 +47049,14 @@ module stdlib_linalg_lapack_q integer(ilp), intent(out) :: info integer(ilp), intent(in) :: n ! Array Arguments - real(qp), intent(inout) :: d(*) + real(${rk}$), intent(inout) :: d(*) ! ===================================================================== ! Parameters integer(ilp), parameter :: select = 20 ! Local Scalars integer(ilp) :: dir, endd, i, j, start, stkpnt - real(qp) :: d1, d2, d3, dmnmx, tmp + real(${rk}$) :: d1, d2, d3, dmnmx, tmp ! Local Arrays integer(ilp) :: stack(2,32) ! Executable Statements @@ -47206,10 +47207,10 @@ module stdlib_linalg_lapack_q end if if( stkpnt>0 )go to 10 return - end subroutine stdlib_qlasrt + end subroutine stdlib_${ri}$lasrt - pure subroutine stdlib_qlassq( n, x, incx, scl, sumsq ) + pure subroutine stdlib_${ri}$lassq( n, x, incx, scl, sumsq ) !! DLASSQ: returns the values scl and smsq such that !! ( scl**2 )*smsq = x( 1 )**2 +...+ x( n )**2 + ( scale**2 )*sumsq, !! where x( i ) = X( 1 + ( i - 1 )*INCX ). The value of sumsq is @@ -47233,13 +47234,13 @@ module stdlib_linalg_lapack_q ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments integer(ilp), intent(in) :: incx, n - real(qp), intent(inout) :: scl, sumsq + real(${rk}$), intent(inout) :: scl, sumsq ! Array Arguments - real(qp), intent(in) :: x(*) + real(${rk}$), intent(in) :: x(*) ! Local Scalars integer(ilp) :: i, ix logical(lk) :: notbig - real(qp) :: abig, amed, asml, ax, ymax, ymin + real(${rk}$) :: abig, amed, asml, ax, ymax, ymin ! quick return if possible if( ieee_is_nan(scl) .or. ieee_is_nan(sumsq) ) return if( sumsq == zero ) scl = one @@ -47321,10 +47322,10 @@ module stdlib_linalg_lapack_q sumsq = amed end if return - end subroutine stdlib_qlassq + end subroutine stdlib_${ri}$lassq - pure subroutine stdlib_qlasv2( f, g, h, ssmin, ssmax, snr, csr, snl, csl ) + pure subroutine stdlib_${ri}$lasv2( f, g, h, ssmin, ssmax, snr, csr, snl, csl ) !! DLASV2: computes the singular value decomposition of a 2-by-2 !! triangular matrix !! [ F G ] @@ -47338,8 +47339,8 @@ module stdlib_linalg_lapack_q ! -- lapack is a software package provided by univ. of tennessee, -- ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments - real(qp), intent(out) :: csl, csr, snl, snr, ssmax, ssmin - real(qp), intent(in) :: f, g, h + real(${rk}$), intent(out) :: csl, csr, snl, snr, ssmax, ssmin + real(${rk}$), intent(in) :: f, g, h ! ===================================================================== @@ -47349,7 +47350,7 @@ module stdlib_linalg_lapack_q ! Local Scalars logical(lk) :: gasmal, swap integer(ilp) :: pmax - real(qp) :: a, clt, crt, d, fa, ft, ga, gt, ha, ht, l, m, mm, r, s, slt, srt, t, temp, & + real(${rk}$) :: a, clt, crt, d, fa, ft, ga, gt, ha, ht, l, m, mm, r, s, slt, srt, t, temp, & tsign, tt ! Intrinsic Functions intrinsic :: abs,sign,sqrt @@ -47388,7 +47389,7 @@ module stdlib_linalg_lapack_q gasmal = .true. if( ga>fa ) then pmax = 2 - if( ( fa / ga )=n).or.(nb<=m).or.(nb>=n)) then - call stdlib_qgelqt( m, n, mb, a, lda, t, ldt, work, info) + call stdlib_${ri}$gelqt( m, n, mb, a, lda, t, ldt, work, info) return end if kk = mod((n-m),(nb-m)) ii=n-kk+1 ! compute the lq factorization of the first block a(1:m,1:nb) - call stdlib_qgelqt( m, nb, mb, a(1,1), lda, t, ldt, work, info) + call stdlib_${ri}$gelqt( m, nb, mb, a(1,1), lda, t, ldt, work, info) ctr = 1 do i = nb+1, ii-nb+m , (nb-m) ! compute the qr factorization of the current block a(1:m,i:i+nb-m) - call stdlib_qtplqt( m, nb-m, 0, mb, a(1,1), lda, a( 1, i ),lda, t(1, ctr * m + 1),& + call stdlib_${ri}$tplqt( m, nb-m, 0, mb, a(1,1), lda, a( 1, i ),lda, t(1, ctr * m + 1),& ldt, work, info ) ctr = ctr + 1 end do ! compute the qr factorization of the last block a(1:m,ii:n) if (ii<=n) then - call stdlib_qtplqt( m, kk, 0, mb, a(1,1), lda, a( 1, ii ),lda, t(1, ctr * m + 1), & + call stdlib_${ri}$tplqt( m, kk, 0, mb, a(1,1), lda, a( 1, ii ),lda, t(1, ctr * m + 1), & ldt,work, info ) end if work( 1 ) = m * mb return - end subroutine stdlib_qlaswlq + end subroutine stdlib_${ri}$laswlq - pure subroutine stdlib_qlaswp( n, a, lda, k1, k2, ipiv, incx ) + pure subroutine stdlib_${ri}$laswp( n, a, lda, k1, k2, ipiv, incx ) !! DLASWP: performs a series of row interchanges on the matrix A. !! One row interchange is initiated for each of rows K1 through K2 of A. ! -- lapack auxiliary routine -- @@ -47563,11 +47564,11 @@ module stdlib_linalg_lapack_q integer(ilp), intent(in) :: incx, k1, k2, lda, n ! Array Arguments integer(ilp), intent(in) :: ipiv(*) - real(qp), intent(inout) :: a(lda,*) + real(${rk}$), intent(inout) :: a(lda,*) ! ===================================================================== ! Local Scalars integer(ilp) :: i, i1, i2, inc, ip, ix, ix0, j, k, n32 - real(qp) :: temp + real(${rk}$) :: temp ! Executable Statements ! interchange row i with row ipiv(k1+(i-k1)*abs(incx)) for each of rows ! k1 through k2. @@ -47617,10 +47618,10 @@ module stdlib_linalg_lapack_q end do end if return - end subroutine stdlib_qlaswp + end subroutine stdlib_${ri}$laswp - pure subroutine stdlib_qlasy2( ltranl, ltranr, isgn, n1, n2, tl, ldtl, tr,ldtr, b, ldb, & + pure subroutine stdlib_${ri}$lasy2( ltranl, ltranr, isgn, n1, n2, tl, ldtl, tr,ldtr, b, ldb, & !! DLASY2: solves for the N1 by N2 matrix X, 1 <= N1,N2 <= 2, in !! op(TL)*X + ISGN*X*op(TR) = SCALE*B, !! where TL is N1 by N1, TR is N2 by N2, B is N1 by N2, and ISGN = 1 or @@ -47633,22 +47634,22 @@ module stdlib_linalg_lapack_q logical(lk), intent(in) :: ltranl, ltranr integer(ilp), intent(out) :: info integer(ilp), intent(in) :: isgn, ldb, ldtl, ldtr, ldx, n1, n2 - real(qp), intent(out) :: scale, xnorm + real(${rk}$), intent(out) :: scale, xnorm ! Array Arguments - real(qp), intent(in) :: b(ldb,*), tl(ldtl,*), tr(ldtr,*) - real(qp), intent(out) :: x(ldx,*) + real(${rk}$), intent(in) :: b(ldb,*), tl(ldtl,*), tr(ldtr,*) + real(${rk}$), intent(out) :: x(ldx,*) ! ===================================================================== ! Local Scalars logical(lk) :: bswap, xswap integer(ilp) :: i, ip, ipiv, ipsv, j, jp, jpsv, k - real(qp) :: bet, eps, gam, l21, sgn, smin, smlnum, tau1, temp, u11, u12, u22, & + real(${rk}$) :: bet, eps, gam, l21, sgn, smin, smlnum, tau1, temp, u11, u12, u22, & xmax ! Local Arrays logical(lk) :: bswpiv(4), xswpiv(4) integer(ilp) :: jpiv(4), locl21(4), locu12(4), locu22(4) - real(qp) :: btmp(4), t16(4,4), tmp(4), x2(2) + real(${rk}$) :: btmp(4), t16(4,4), tmp(4), x2(2) ! Intrinsic Functions intrinsic :: abs,max ! Data Statements @@ -47663,8 +47664,8 @@ module stdlib_linalg_lapack_q ! quick return if possible if( n1==0 .or. n2==0 )return ! set constants to control overflow - eps = stdlib_qlamch( 'P' ) - smlnum = stdlib_qlamch( 'S' ) / eps + eps = stdlib_${ri}$lamch( 'P' ) + smlnum = stdlib_${ri}$lamch( 'S' ) / eps sgn = isgn k = n1 + n1 + n2 - 2 go to ( 10, 20, 30, 50 )k @@ -47721,7 +47722,7 @@ module stdlib_linalg_lapack_q 40 continue ! solve 2 by 2 system using complete pivoting. ! set pivots less than smin to smin. - ipiv = stdlib_iqamax( 4, tmp, 1 ) + ipiv = stdlib_i${ri}$amax( 4, tmp, 1 ) u11 = tmp( ipiv ) if( abs( u11 )<=smin ) then info = 1 @@ -47778,7 +47779,7 @@ module stdlib_linalg_lapack_q 2 ) ) ) smin = max( eps*smin, smlnum ) btmp( 1 ) = zero - call stdlib_qcopy( 16, btmp, 0, t16, 1 ) + call stdlib_${ri}$copy( 16, btmp, 0, t16, 1 ) t16( 1, 1 ) = tl( 1, 1 ) + sgn*tr( 1, 1 ) t16( 2, 2 ) = tl( 2, 2 ) + sgn*tr( 1, 1 ) t16( 3, 3 ) = tl( 1, 1 ) + sgn*tr( 2, 2 ) @@ -47822,12 +47823,12 @@ module stdlib_linalg_lapack_q end do end do if( ipsv/=i ) then - call stdlib_qswap( 4, t16( ipsv, 1 ), 4, t16( i, 1 ), 4 ) + call stdlib_${ri}$swap( 4, t16( ipsv, 1 ), 4, t16( i, 1 ), 4 ) temp = btmp( i ) btmp( i ) = btmp( ipsv ) btmp( ipsv ) = temp end if - if( jpsv/=i )call stdlib_qswap( 4, t16( 1, jpsv ), 1, t16( 1, i ), 1 ) + if( jpsv/=i )call stdlib_${ri}$swap( 4, t16( 1, jpsv ), 1, t16( 1, i ), 1 ) jpiv( i ) = jpsv if( abs( t16( i, i ) )1 ) then - imax = stdlib_iqamax( k-1, w( 1, kw ), 1 ) + imax = stdlib_i${ri}$amax( k-1, w( 1, kw ), 1 ) colmax = abs( w( imax, kw ) ) else colmax = zero @@ -47956,17 +47957,17 @@ module stdlib_linalg_lapack_q kp = k else ! copy column imax to column kw-1 of w and update it - call stdlib_qcopy( imax, a( 1, imax ), 1, w( 1, kw-1 ), 1 ) - call stdlib_qcopy( k-imax, a( imax, imax+1 ), lda,w( imax+1, kw-1 ), 1 ) + call stdlib_${ri}$copy( imax, a( 1, imax ), 1, w( 1, kw-1 ), 1 ) + call stdlib_${ri}$copy( k-imax, a( imax, imax+1 ), lda,w( imax+1, kw-1 ), 1 ) - if( k1 ) then - jmax = stdlib_iqamax( imax-1, w( 1, kw-1 ), 1 ) + jmax = stdlib_i${ri}$amax( imax-1, w( 1, kw-1 ), 1 ) rowmax = max( rowmax, abs( w( jmax, kw-1 ) ) ) end if if( absakk>=alpha*colmax*( colmax / rowmax ) ) then @@ -47977,7 +47978,7 @@ module stdlib_linalg_lapack_q ! pivot block kp = imax ! copy column kw-1 of w to column kw of w - call stdlib_qcopy( k, w( 1, kw-1 ), 1, w( 1, kw ), 1 ) + call stdlib_${ri}$copy( k, w( 1, kw-1 ), 1, w( 1, kw ), 1 ) else ! interchange rows and columns k-1 and imax, use 2-by-2 ! pivot block @@ -47998,14 +47999,14 @@ module stdlib_linalg_lapack_q ! (or k and k-1 for 2-by-2 pivot) of a, since these columns ! will be later overwritten. a( kp, kp ) = a( kk, kk ) - call stdlib_qcopy( kk-1-kp, a( kp+1, kk ), 1, a( kp, kp+1 ),lda ) - if( kp>1 )call stdlib_qcopy( kp-1, a( 1, kk ), 1, a( 1, kp ), 1 ) + call stdlib_${ri}$copy( kk-1-kp, a( kp+1, kk ), 1, a( kp, kp+1 ),lda ) + if( kp>1 )call stdlib_${ri}$copy( kp-1, a( 1, kk ), 1, a( 1, kp ), 1 ) ! interchange rows kk and kp in last k+1 to n columns of a ! (columns k (or k and k-1 for 2-by-2 pivot) of a will be ! later overwritten). interchange rows kk and kp ! in last kkw to nb columns of w. - if( k=nb .and. nbn )go to 90 ! copy column k of a to column k of w and update it - call stdlib_qcopy( n-k+1, a( k, k ), 1, w( k, k ), 1 ) - call stdlib_qgemv( 'NO TRANSPOSE', n-k+1, k-1, -one, a( k, 1 ), lda,w( k, 1 ), ldw, & + call stdlib_${ri}$copy( n-k+1, a( k, k ), 1, w( k, k ), 1 ) + call stdlib_${ri}$gemv( 'NO TRANSPOSE', n-k+1, k-1, -one, a( k, 1 ), lda,w( k, 1 ), ldw, & one, w( k, k ), 1 ) kstep = 1 ! determine rows and columns to be interchanged and whether @@ -48137,7 +48138,7 @@ module stdlib_linalg_lapack_q ! column k, and colmax is its absolute value. ! determine both colmax and imax. if( k=alpha*colmax*( colmax / rowmax ) ) then @@ -48172,7 +48173,7 @@ module stdlib_linalg_lapack_q ! pivot block kp = imax ! copy column k+1 of w to column k of w - call stdlib_qcopy( n-k+1, w( k, k+1 ), 1, w( k, k ), 1 ) + call stdlib_${ri}$copy( n-k+1, w( k, k+1 ), 1, w( k, k ), 1 ) else ! interchange rows and columns k+1 and imax, use 2-by-2 ! pivot block @@ -48191,15 +48192,15 @@ module stdlib_linalg_lapack_q ! (or k and k+1 for 2-by-2 pivot) of a, since these columns ! will be later overwritten. a( kp, kp ) = a( kk, kk ) - call stdlib_qcopy( kp-kk-1, a( kk+1, kk ), 1, a( kp, kk+1 ),lda ) - if( kp1 )call stdlib_qswap( k-1, a( kk, 1 ), lda, a( kp, 1 ), lda ) - call stdlib_qswap( kk, w( kk, 1 ), ldw, w( kp, 1 ), ldw ) + if( k>1 )call stdlib_${ri}$swap( k-1, a( kk, 1 ), lda, a( kp, 1 ), lda ) + call stdlib_${ri}$swap( kk, w( kk, 1 ), ldw, w( kp, 1 ), ldw ) end if if( kstep==1 ) then ! 1-by-1 pivot block d(k): column k of w now holds @@ -48211,10 +48212,10 @@ module stdlib_linalg_lapack_q ! and not stored) ! a(k,k) := d(k,k) = w(k,k) ! a(k+1:n,k) := l(k+1:n,k) = w(k+1:n,k)/d(k,k) - call stdlib_qcopy( n-k+1, w( k, k ), 1, a( k, k ), 1 ) + call stdlib_${ri}$copy( n-k+1, w( k, k ), 1, a( k, k ), 1 ) if( k=1 )call stdlib_qswap( j, a( jp, 1 ), lda, a( jj, 1 ), lda ) + if( jp/=jj .and. j>=1 )call stdlib_${ri}$swap( j, a( jp, 1 ), lda, a( jj, 1 ), lda ) if( j>1 )go to 120 ! set kb to the number of columns factorized kb = k - 1 end if return - end subroutine stdlib_qlasyf + end subroutine stdlib_${ri}$lasyf - pure subroutine stdlib_qlasyf_aa( uplo, j1, m, nb, a, lda, ipiv,h, ldh, work ) + pure subroutine stdlib_${ri}$lasyf_aa( uplo, j1, m, nb, a, lda, ipiv,h, ldh, work ) !! DLATRF_AA factorizes a panel of a real symmetric matrix A using !! the Aasen's algorithm. The panel consists of a set of NB rows of A !! when UPLO is U, or a set of NB columns when UPLO is L. @@ -48336,13 +48337,13 @@ module stdlib_linalg_lapack_q integer(ilp), intent(in) :: m, nb, j1, lda, ldh ! Array Arguments integer(ilp), intent(out) :: ipiv(*) - real(qp), intent(inout) :: a(lda,*), h(ldh,*) - real(qp), intent(out) :: work(*) + real(${rk}$), intent(inout) :: a(lda,*), h(ldh,*) + real(${rk}$), intent(out) :: work(*) ! ===================================================================== ! Local Scalars integer(ilp) :: j, k, k1, i1, i2, mj - real(qp) :: piv, alpha + real(${rk}$) :: piv, alpha ! Intrinsic Functions intrinsic :: max ! Executable Statements @@ -48357,7 +48358,7 @@ module stdlib_linalg_lapack_q 10 continue if ( j>min(m, nb) )go to 20 ! k is the column to be factorized - ! when being called from stdlib_qsytrf_aa, + ! when being called from stdlib_${ri}$sytrf_aa, ! > for the first block column, j1 is 1, hence j1+j-1 is j, ! > for the rest of the columns, j1 is 2, and j1+j-1 is j+1, k = j1+j-1 @@ -48375,16 +48376,16 @@ module stdlib_linalg_lapack_q ! columns ! > for the rest of the columns, k is j+1, skipping only the ! first column - call stdlib_qgemv( 'NO TRANSPOSE', mj, j-k1,-one, h( j, k1 ), ldh,a( 1, j ), 1,& + call stdlib_${ri}$gemv( 'NO TRANSPOSE', mj, j-k1,-one, h( j, k1 ), ldh,a( 1, j ), 1,& one, h( j, j ), 1 ) end if ! copy h(i:m, i) into work - call stdlib_qcopy( mj, h( j, j ), 1, work( 1 ), 1 ) + call stdlib_${ri}$copy( mj, h( j, j ), 1, work( 1 ), 1 ) if( j>k1 ) then ! compute work := work - l(j-1, j:m) * t(j-1,j), ! where a(j-1, j) stores t(j-1, j) and a(j-2, j:m) stores u(j-1, j:m) alpha = -a( k-1, j ) - call stdlib_qaxpy( mj, alpha, a( k-2, j ), lda, work( 1 ), 1 ) + call stdlib_${ri}$axpy( mj, alpha, a( k-2, j ), lda, work( 1 ), 1 ) end if ! set a(j, j) = t(j, j) a( k, j ) = work( 1 ) @@ -48393,10 +48394,10 @@ module stdlib_linalg_lapack_q ! where a(j, j) stores t(j, j) and a(j-1, (j+1):m) stores u(j, (j+1):m) if( k>1 ) then alpha = -a( k, j ) - call stdlib_qaxpy( m-j, alpha, a( k-1, j+1 ), lda,work( 2 ), 1 ) + call stdlib_${ri}$axpy( m-j, alpha, a( k-1, j+1 ), lda,work( 2 ), 1 ) endif ! find max(|work(2:m)|) - i2 = stdlib_iqamax( m-j, work( 2 ), 1 ) + 1 + i2 = stdlib_i${ri}$amax( m-j, work( 2 ), 1 ) + 1 piv = work( i2 ) ! apply symmetric pivot if( (i2/=2) .and. (piv/=0) ) then @@ -48407,22 +48408,22 @@ module stdlib_linalg_lapack_q ! swap a(i1, i1+1:m) with a(i1+1:m, i2) i1 = i1+j-1 i2 = i2+j-1 - call stdlib_qswap( i2-i1-1, a( j1+i1-1, i1+1 ), lda,a( j1+i1, i2 ), 1 ) + call stdlib_${ri}$swap( i2-i1-1, a( j1+i1-1, i1+1 ), lda,a( j1+i1, i2 ), 1 ) ! swap a(i1, i2+1:m) with a(i2, i2+1:m) - if( i2(k1-1) ) then ! swap l(1:i1-1, i1) with l(1:i1-1, i2), ! skipping the first column - call stdlib_qswap( i1-k1+1, a( 1, i1 ), 1,a( 1, i2 ), 1 ) + call stdlib_${ri}$swap( i1-k1+1, a( 1, i1 ), 1,a( 1, i2 ), 1 ) end if else ipiv( j+1 ) = j+1 @@ -48431,17 +48432,17 @@ module stdlib_linalg_lapack_q a( k, j+1 ) = work( 2 ) if( jmin( m, nb ) )go to 40 ! k is the column to be factorized - ! when being called from stdlib_qsytrf_aa, + ! when being called from stdlib_${ri}$sytrf_aa, ! > for the first block column, j1 is 1, hence j1+j-1 is j, ! > for the rest of the columns, j1 is 2, and j1+j-1 is j+1, k = j1+j-1 @@ -48473,16 +48474,16 @@ module stdlib_linalg_lapack_q ! columns ! > for the rest of the columns, k is j+1, skipping only the ! first column - call stdlib_qgemv( 'NO TRANSPOSE', mj, j-k1,-one, h( j, k1 ), ldh,a( j, 1 ), lda,& + call stdlib_${ri}$gemv( 'NO TRANSPOSE', mj, j-k1,-one, h( j, k1 ), ldh,a( j, 1 ), lda,& one, h( j, j ), 1 ) end if ! copy h(j:m, j) into work - call stdlib_qcopy( mj, h( j, j ), 1, work( 1 ), 1 ) + call stdlib_${ri}$copy( mj, h( j, j ), 1, work( 1 ), 1 ) if( j>k1 ) then ! compute work := work - l(j:m, j-1) * t(j-1,j), ! where a(j-1, j) = t(j-1, j) and a(j, j-2) = l(j, j-1) alpha = -a( j, k-1 ) - call stdlib_qaxpy( mj, alpha, a( j, k-2 ), 1, work( 1 ), 1 ) + call stdlib_${ri}$axpy( mj, alpha, a( j, k-2 ), 1, work( 1 ), 1 ) end if ! set a(j, j) = t(j, j) a( j, k ) = work( 1 ) @@ -48491,10 +48492,10 @@ module stdlib_linalg_lapack_q ! where a(j, j) = t(j, j) and a((j+1):m, j-1) = l((j+1):m, j) if( k>1 ) then alpha = -a( j, k ) - call stdlib_qaxpy( m-j, alpha, a( j+1, k-1 ), 1,work( 2 ), 1 ) + call stdlib_${ri}$axpy( m-j, alpha, a( j+1, k-1 ), 1,work( 2 ), 1 ) endif ! find max(|work(2:m)|) - i2 = stdlib_iqamax( m-j, work( 2 ), 1 ) + 1 + i2 = stdlib_i${ri}$amax( m-j, work( 2 ), 1 ) + 1 piv = work( i2 ) ! apply symmetric pivot if( (i2/=2) .and. (piv/=0) ) then @@ -48505,22 +48506,22 @@ module stdlib_linalg_lapack_q ! swap a(i1+1:m, i1) with a(i2, i1+1:m) i1 = i1+j-1 i2 = i2+j-1 - call stdlib_qswap( i2-i1-1, a( i1+1, j1+i1-1 ), 1,a( i2, j1+i1 ), lda ) + call stdlib_${ri}$swap( i2-i1-1, a( i1+1, j1+i1-1 ), 1,a( i2, j1+i1 ), lda ) ! swap a(i2+1:m, i1) with a(i2+1:m, i2) - if( i2(k1-1) ) then ! swap l(1:i1-1, i1) with l(1:i1-1, i2), ! skipping the first column - call stdlib_qswap( i1-k1+1, a( i1, 1 ), lda,a( i2, 1 ), lda ) + call stdlib_${ri}$swap( i1-k1+1, a( i1, 1 ), lda,a( i2, 1 ), lda ) end if else ipiv( j+1 ) = j+1 @@ -48529,17 +48530,17 @@ module stdlib_linalg_lapack_q a( j+1, k ) = work( 2 ) if( j1 ) then - imax = stdlib_iqamax( k-1, w( 1, kw ), 1 ) + imax = stdlib_i${ri}$amax( k-1, w( 1, kw ), 1 ) colmax = abs( w( imax, kw ) ) else colmax = zero @@ -48629,7 +48630,7 @@ module stdlib_linalg_lapack_q ! column k is zero or underflow: set info and continue if( info==0 )info = k kp = k - call stdlib_qcopy( k, w( 1, kw ), 1, a( 1, k ), 1 ) + call stdlib_${ri}$copy( k, w( 1, kw ), 1, a( 1, k ), 1 ) ! set e( k ) to zero if( k>1 )e( k ) = zero else @@ -48646,22 +48647,22 @@ module stdlib_linalg_lapack_q 12 continue ! begin pivot search loop body ! copy column imax to column kw-1 of w and update it - call stdlib_qcopy( imax, a( 1, imax ), 1, w( 1, kw-1 ), 1 ) - call stdlib_qcopy( k-imax, a( imax, imax+1 ), lda,w( imax+1, kw-1 ), 1 ) + call stdlib_${ri}$copy( imax, a( 1, imax ), 1, w( 1, kw-1 ), 1 ) + call stdlib_${ri}$copy( k-imax, a( imax, imax+1 ), lda,w( imax+1, kw-1 ), 1 ) - if( k1 ) then - itemp = stdlib_iqamax( imax-1, w( 1, kw-1 ), 1 ) + itemp = stdlib_i${ri}$amax( imax-1, w( 1, kw-1 ), 1 ) dtemp = abs( w( itemp, kw-1 ) ) if( dtemp>rowmax ) then rowmax = dtemp @@ -48676,7 +48677,7 @@ module stdlib_linalg_lapack_q ! use 1-by-1 pivot block kp = imax ! copy column kw-1 of w to column kw of w - call stdlib_qcopy( k, w( 1, kw-1 ), 1, w( 1, kw ), 1 ) + call stdlib_${ri}$copy( k, w( 1, kw-1 ), 1, w( 1, kw ), 1 ) done = .true. ! equivalent to testing for rowmax==colmax, ! (used to handle nan and inf) @@ -48692,7 +48693,7 @@ module stdlib_linalg_lapack_q colmax = rowmax imax = jmax ! copy updated jmaxth (next imaxth) column to kth of w - call stdlib_qcopy( k, w( 1, kw-1 ), 1, w( 1, kw ), 1 ) + call stdlib_${ri}$copy( k, w( 1, kw-1 ), 1, w( 1, kw ), 1 ) end if ! end pivot search loop body if( .not. done ) goto 12 @@ -48703,34 +48704,34 @@ module stdlib_linalg_lapack_q kkw = nb + kk - n if( ( kstep==2 ) .and. ( p/=k ) ) then ! copy non-updated column k to column p - call stdlib_qcopy( k-p, a( p+1, k ), 1, a( p, p+1 ), lda ) - call stdlib_qcopy( p, a( 1, k ), 1, a( 1, p ), 1 ) + call stdlib_${ri}$copy( k-p, a( p+1, k ), 1, a( p, p+1 ), lda ) + call stdlib_${ri}$copy( p, a( 1, k ), 1, a( 1, p ), 1 ) ! interchange rows k and p in last n-k+1 columns of a ! and last n-k+2 columns of w - call stdlib_qswap( n-k+1, a( k, k ), lda, a( p, k ), lda ) - call stdlib_qswap( n-kk+1, w( k, kkw ), ldw, w( p, kkw ), ldw ) + call stdlib_${ri}$swap( n-k+1, a( k, k ), lda, a( p, k ), lda ) + call stdlib_${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_qcopy( k-1-kp, a( kp+1, kk ), 1, a( kp, kp+1 ),lda ) - call stdlib_qcopy( kp, a( 1, kk ), 1, a( 1, kp ), 1 ) + call stdlib_${ri}$copy( k-1-kp, a( kp+1, kk ), 1, a( kp, kp+1 ),lda ) + call stdlib_${ri}$copy( kp, a( 1, kk ), 1, a( 1, kp ), 1 ) ! interchange rows kk and kp in last n-kk+1 columns ! of a and w - call stdlib_qswap( n-kk+1, a( kk, kk ), lda, a( kp, kk ), lda ) - call stdlib_qswap( n-kk+1, w( kk, kkw ), ldw, w( kp, kkw ),ldw ) + call stdlib_${ri}$swap( n-kk+1, a( kk, kk ), lda, a( kp, kk ), lda ) + call stdlib_${ri}$swap( n-kk+1, w( kk, kkw ), ldw, w( kp, kkw ),ldw ) end if if( kstep==1 ) 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_qcopy( k, w( 1, kw ), 1, a( 1, k ), 1 ) + call stdlib_${ri}$copy( k, w( 1, kw ), 1, a( 1, k ), 1 ) if( k>1 ) then if( abs( a( k, k ) )>=sfmin ) then r1 = one / a( k, k ) - call stdlib_qscal( k-1, r1, a( 1, k ), 1 ) + call stdlib_${ri}$scal( k-1, r1, a( 1, k ), 1 ) else if( a( k, k )/=zero ) then do ii = 1, k - 1 a( ii, k ) = a( ii, k ) / a( k, k ) @@ -48785,11 +48786,11 @@ module stdlib_linalg_lapack_q jb = min( nb, k-j+1 ) ! update the upper triangle of the diagonal block do jj = j, j + jb - 1 - call stdlib_qgemv( 'NO TRANSPOSE', jj-j+1, n-k, -one,a( j, k+1 ), lda, w( jj, & + call stdlib_${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 ) end do ! update the rectangular superdiagonal block - if( j>=2 )call stdlib_qgemm( 'NO TRANSPOSE', 'TRANSPOSE', j-1, jb,n-k, -one, a( & + if( j>=2 )call stdlib_${ri}$gemm( 'NO TRANSPOSE', 'TRANSPOSE', j-1, jb,n-k, -one, a( & 1, k+1 ), lda, w( j, kw+1 ),ldw, one, a( 1, j ), lda ) end do ! set kb to the number of columns factorized @@ -48808,8 +48809,8 @@ module stdlib_linalg_lapack_q kstep = 1 p = k ! copy column k of a to column k of w and update it - call stdlib_qcopy( n-k+1, a( k, k ), 1, w( k, k ), 1 ) - if( k>1 )call stdlib_qgemv( 'NO TRANSPOSE', n-k+1, k-1, -one, a( k, 1 ),lda, w( k, & + call stdlib_${ri}$copy( n-k+1, a( k, k ), 1, w( k, k ), 1 ) + if( k>1 )call stdlib_${ri}$gemv( 'NO TRANSPOSE', n-k+1, k-1, -one, a( k, 1 ),lda, w( k, & 1 ), ldw, one, w( k, k ), 1 ) ! determine rows and columns to be interchanged and whether ! a 1-by-1 or 2-by-2 pivot block will be used @@ -48818,7 +48819,7 @@ module stdlib_linalg_lapack_q ! column k, and colmax is its absolute value. ! determine both colmax and imax. if( k1 )call stdlib_qgemv( 'NO TRANSPOSE', n-k+1, k-1, -one,a( k, 1 ), & + call stdlib_${ri}$copy( imax-k, a( imax, k ), lda, w( k, k+1 ), 1) + call stdlib_${ri}$copy( n-imax+1, a( imax, imax ), 1,w( imax, k+1 ), 1 ) + if( k>1 )call stdlib_${ri}$gemv( 'NO TRANSPOSE', n-k+1, k-1, -one,a( k, 1 ), & lda, w( imax, 1 ), ldw,one, w( k, k+1 ), 1 ) ! 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 + stdlib_iqamax( imax-k, w( k, k+1 ), 1 ) + jmax = k - 1 + stdlib_i${ri}$amax( imax-k, w( k, k+1 ), 1 ) rowmax = abs( w( jmax, k+1 ) ) else rowmax = zero end if if( imaxrowmax ) then rowmax = dtemp @@ -48873,7 +48874,7 @@ module stdlib_linalg_lapack_q ! use 1-by-1 pivot block kp = imax ! copy column k+1 of w to column k of w - call stdlib_qcopy( n-k+1, w( k, k+1 ), 1, w( k, k ), 1 ) + call stdlib_${ri}$copy( n-k+1, w( k, k+1 ), 1, w( k, k ), 1 ) done = .true. ! equivalent to testing for rowmax==colmax, ! (used to handle nan and inf) @@ -48889,7 +48890,7 @@ module stdlib_linalg_lapack_q colmax = rowmax imax = jmax ! copy updated jmaxth (next imaxth) column to kth of w - call stdlib_qcopy( n-k+1, w( k, k+1 ), 1, w( k, k ), 1 ) + call stdlib_${ri}$copy( n-k+1, w( k, k+1 ), 1, w( k, k ), 1 ) end if ! end pivot search loop body if( .not. done ) goto 72 @@ -48898,33 +48899,33 @@ module stdlib_linalg_lapack_q kk = k + kstep - 1 if( ( kstep==2 ) .and. ( p/=k ) ) then ! copy non-updated column k to column p - call stdlib_qcopy( p-k, a( k, k ), 1, a( p, k ), lda ) - call stdlib_qcopy( n-p+1, a( p, k ), 1, a( p, p ), 1 ) + call stdlib_${ri}$copy( p-k, a( k, k ), 1, a( p, k ), lda ) + call stdlib_${ri}$copy( n-p+1, a( p, k ), 1, a( p, p ), 1 ) ! interchange rows k and p in first k columns of a ! and first k+1 columns of w - call stdlib_qswap( k, a( k, 1 ), lda, a( p, 1 ), lda ) - call stdlib_qswap( kk, w( k, 1 ), ldw, w( p, 1 ), ldw ) + call stdlib_${ri}$swap( k, a( k, 1 ), lda, a( p, 1 ), lda ) + call stdlib_${ri}$swap( kk, w( k, 1 ), ldw, w( p, 1 ), 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_qcopy( kp-k-1, a( k+1, kk ), 1, a( kp, k+1 ), lda ) - call stdlib_qcopy( n-kp+1, a( kp, kk ), 1, a( kp, kp ), 1 ) + call stdlib_${ri}$copy( kp-k-1, a( k+1, kk ), 1, a( kp, k+1 ), lda ) + call stdlib_${ri}$copy( n-kp+1, a( kp, kk ), 1, a( kp, kp ), 1 ) ! interchange rows kk and kp in first kk columns of a and w - call stdlib_qswap( kk, a( kk, 1 ), lda, a( kp, 1 ), lda ) - call stdlib_qswap( kk, w( kk, 1 ), ldw, w( kp, 1 ), ldw ) + call stdlib_${ri}$swap( kk, a( kk, 1 ), lda, a( kp, 1 ), lda ) + call stdlib_${ri}$swap( kk, w( kk, 1 ), ldw, w( kp, 1 ), ldw ) end if if( kstep==1 ) 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_qcopy( n-k+1, w( k, k ), 1, a( k, k ), 1 ) + call stdlib_${ri}$copy( n-k+1, w( k, k ), 1, a( k, k ), 1 ) if( k=sfmin ) then r1 = one / a( k, k ) - call stdlib_qscal( n-k, r1, a( k+1, k ), 1 ) + call stdlib_${ri}$scal( n-k, r1, a( k+1, k ), 1 ) else if( a( k, k )/=zero ) then do ii = k + 1, n a( ii, k ) = a( ii, k ) / a( k, k ) @@ -48978,21 +48979,21 @@ module stdlib_linalg_lapack_q jb = min( nb, n-j+1 ) ! update the lower triangle of the diagonal block do jj = j, j + jb - 1 - call stdlib_qgemv( 'NO TRANSPOSE', j+jb-jj, k-1, -one,a( jj, 1 ), lda, w( jj, & + call stdlib_${ri}$gemv( 'NO TRANSPOSE', j+jb-jj, k-1, -one,a( jj, 1 ), lda, w( jj, & 1 ), ldw, one,a( jj, jj ), 1 ) end do ! update the rectangular subdiagonal block - if( j+jb<=n )call stdlib_qgemm( 'NO TRANSPOSE', 'TRANSPOSE', n-j-jb+1, jb,k-1, -& + if( j+jb<=n )call stdlib_${ri}$gemm( 'NO TRANSPOSE', 'TRANSPOSE', n-j-jb+1, jb,k-1, -& one, a( j+jb, 1 ), lda, w( j, 1 ),ldw, one, a( j+jb, j ), lda ) end do ! set kb to the number of columns factorized kb = k - 1 end if return - end subroutine stdlib_qlasyf_rk + end subroutine stdlib_${ri}$lasyf_rk - pure subroutine stdlib_qlasyf_rook( uplo, n, nb, kb, a, lda, ipiv, w, ldw,info ) + pure subroutine stdlib_${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: @@ -49014,18 +49015,18 @@ module stdlib_linalg_lapack_q integer(ilp), intent(in) :: lda, ldw, n, nb ! Array Arguments integer(ilp), intent(out) :: ipiv(*) - real(qp), intent(inout) :: a(lda,*) - real(qp), intent(out) :: w(ldw,*) + real(${rk}$), intent(inout) :: a(lda,*) + real(${rk}$), intent(out) :: w(ldw,*) ! ===================================================================== ! Parameters - real(qp), parameter :: sevten = 17.0e+0_qp + real(${rk}$), parameter :: sevten = 17.0e+0_${rk}$ ! Local Scalars logical(lk) :: done integer(ilp) :: imax, itemp, j, jb, jj, jmax, jp1, jp2, k, kk, kw, kkw, kp, kstep, p, & ii - real(qp) :: absakk, alpha, colmax, d11, d12, d21, d22, dtemp, r1, rowmax, t, & + real(${rk}$) :: absakk, alpha, colmax, d11, d12, d21, d22, dtemp, r1, rowmax, t, & sfmin ! Intrinsic Functions intrinsic :: abs,max,min,sqrt @@ -49034,7 +49035,7 @@ module stdlib_linalg_lapack_q ! initialize alpha for use in choosing pivot block size. alpha = ( one+sqrt( sevten ) ) / eight ! compute machine safe minimum - sfmin = stdlib_qlamch( 'S' ) + sfmin = stdlib_${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 @@ -49049,8 +49050,8 @@ module stdlib_linalg_lapack_q kstep = 1 p = k ! copy column k of a to column kw of w and update it - call stdlib_qcopy( k, a( 1, k ), 1, w( 1, kw ), 1 ) - if( k1 ) then - imax = stdlib_iqamax( k-1, w( 1, kw ), 1 ) + imax = stdlib_i${ri}$amax( k-1, w( 1, kw ), 1 ) colmax = abs( w( imax, kw ) ) else colmax = zero @@ -49068,7 +49069,7 @@ module stdlib_linalg_lapack_q ! column k is zero or underflow: set info and continue if( info==0 )info = k kp = k - call stdlib_qcopy( k, w( 1, kw ), 1, a( 1, k ), 1 ) + call stdlib_${ri}$copy( k, w( 1, kw ), 1, a( 1, k ), 1 ) else ! ============================================================ ! test for interchange @@ -49083,22 +49084,22 @@ module stdlib_linalg_lapack_q 12 continue ! begin pivot search loop body ! copy column imax to column kw-1 of w and update it - call stdlib_qcopy( imax, a( 1, imax ), 1, w( 1, kw-1 ), 1 ) - call stdlib_qcopy( k-imax, a( imax, imax+1 ), lda,w( imax+1, kw-1 ), 1 ) + call stdlib_${ri}$copy( imax, a( 1, imax ), 1, w( 1, kw-1 ), 1 ) + call stdlib_${ri}$copy( k-imax, a( imax, imax+1 ), lda,w( imax+1, kw-1 ), 1 ) - if( k1 ) then - itemp = stdlib_iqamax( imax-1, w( 1, kw-1 ), 1 ) + itemp = stdlib_i${ri}$amax( imax-1, w( 1, kw-1 ), 1 ) dtemp = abs( w( itemp, kw-1 ) ) if( dtemp>rowmax ) then rowmax = dtemp @@ -49113,7 +49114,7 @@ module stdlib_linalg_lapack_q ! use 1-by-1 pivot block kp = imax ! copy column kw-1 of w to column kw of w - call stdlib_qcopy( k, w( 1, kw-1 ), 1, w( 1, kw ), 1 ) + call stdlib_${ri}$copy( k, w( 1, kw-1 ), 1, w( 1, kw ), 1 ) done = .true. ! equivalent to testing for rowmax==colmax, ! (used to handle nan and inf) @@ -49129,7 +49130,7 @@ module stdlib_linalg_lapack_q colmax = rowmax imax = jmax ! copy updated jmaxth (next imaxth) column to kth of w - call stdlib_qcopy( k, w( 1, kw-1 ), 1, w( 1, kw ), 1 ) + call stdlib_${ri}$copy( k, w( 1, kw-1 ), 1, w( 1, kw ), 1 ) end if ! end pivot search loop body if( .not. done ) goto 12 @@ -49140,34 +49141,34 @@ module stdlib_linalg_lapack_q kkw = nb + kk - n if( ( kstep==2 ) .and. ( p/=k ) ) then ! copy non-updated column k to column p - call stdlib_qcopy( k-p, a( p+1, k ), 1, a( p, p+1 ), lda ) - call stdlib_qcopy( p, a( 1, k ), 1, a( 1, p ), 1 ) + call stdlib_${ri}$copy( k-p, a( p+1, k ), 1, a( p, p+1 ), lda ) + call stdlib_${ri}$copy( p, a( 1, k ), 1, a( 1, p ), 1 ) ! interchange rows k and p in last n-k+1 columns of a ! and last n-k+2 columns of w - call stdlib_qswap( n-k+1, a( k, k ), lda, a( p, k ), lda ) - call stdlib_qswap( n-kk+1, w( k, kkw ), ldw, w( p, kkw ), ldw ) + call stdlib_${ri}$swap( n-k+1, a( k, k ), lda, a( p, k ), lda ) + call stdlib_${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_qcopy( k-1-kp, a( kp+1, kk ), 1, a( kp, kp+1 ),lda ) - call stdlib_qcopy( kp, a( 1, kk ), 1, a( 1, kp ), 1 ) + call stdlib_${ri}$copy( k-1-kp, a( kp+1, kk ), 1, a( kp, kp+1 ),lda ) + call stdlib_${ri}$copy( kp, a( 1, kk ), 1, a( 1, kp ), 1 ) ! interchange rows kk and kp in last n-kk+1 columns ! of a and w - call stdlib_qswap( n-kk+1, a( kk, kk ), lda, a( kp, kk ), lda ) - call stdlib_qswap( n-kk+1, w( kk, kkw ), ldw, w( kp, kkw ),ldw ) + call stdlib_${ri}$swap( n-kk+1, a( kk, kk ), lda, a( kp, kk ), lda ) + call stdlib_${ri}$swap( n-kk+1, w( kk, kkw ), ldw, w( kp, kkw ),ldw ) end if if( kstep==1 ) 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_qcopy( k, w( 1, kw ), 1, a( 1, k ), 1 ) + call stdlib_${ri}$copy( k, w( 1, kw ), 1, a( 1, k ), 1 ) if( k>1 ) then if( abs( a( k, k ) )>=sfmin ) then r1 = one / a( k, k ) - call stdlib_qscal( k-1, r1, a( 1, k ), 1 ) + call stdlib_${ri}$scal( k-1, r1, a( 1, k ), 1 ) else if( a( k, k )/=zero ) then do ii = 1, k - 1 a( ii, k ) = a( ii, k ) / a( k, k ) @@ -49215,11 +49216,11 @@ module stdlib_linalg_lapack_q jb = min( nb, k-j+1 ) ! update the upper triangle of the diagonal block do jj = j, j + jb - 1 - call stdlib_qgemv( 'NO TRANSPOSE', jj-j+1, n-k, -one,a( j, k+1 ), lda, w( jj, & + call stdlib_${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 ) end do ! update the rectangular superdiagonal block - if( j>=2 )call stdlib_qgemm( 'NO TRANSPOSE', 'TRANSPOSE', j-1, jb,n-k, -one, a( & + if( j>=2 )call stdlib_${ri}$gemm( 'NO TRANSPOSE', 'TRANSPOSE', j-1, jb,n-k, -one, a( & 1, k+1 ), lda, w( j, kw+1 ), ldw,one, a( 1, j ), lda ) end do ! put u12 in standard form by partially undoing the interchanges @@ -49237,10 +49238,10 @@ module stdlib_linalg_lapack_q kstep = 2 end if j = j + 1 - if( jp2/=jj .and. j<=n )call stdlib_qswap( n-j+1, a( jp2, j ), lda, a( jj, j ), & + if( jp2/=jj .and. j<=n )call stdlib_${ri}$swap( n-j+1, a( jp2, j ), lda, a( jj, j ), & lda ) jj = j - 1 - if( jp1/=jj .and. kstep==2 )call stdlib_qswap( n-j+1, a( jp1, j ), lda, a( jj, j & + if( jp1/=jj .and. kstep==2 )call stdlib_${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 @@ -49257,8 +49258,8 @@ module stdlib_linalg_lapack_q kstep = 1 p = k ! copy column k of a to column k of w and update it - call stdlib_qcopy( n-k+1, a( k, k ), 1, w( k, k ), 1 ) - if( k>1 )call stdlib_qgemv( 'NO TRANSPOSE', n-k+1, k-1, -one, a( k, 1 ),lda, w( k, & + call stdlib_${ri}$copy( n-k+1, a( k, k ), 1, w( k, k ), 1 ) + if( k>1 )call stdlib_${ri}$gemv( 'NO TRANSPOSE', n-k+1, k-1, -one, a( k, 1 ),lda, w( k, & 1 ), ldw, one, w( k, k ), 1 ) ! determine rows and columns to be interchanged and whether ! a 1-by-1 or 2-by-2 pivot block will be used @@ -49267,7 +49268,7 @@ module stdlib_linalg_lapack_q ! column k, and colmax is its absolute value. ! determine both colmax and imax. if( k1 )call stdlib_qgemv( 'NO TRANSPOSE', n-k+1, k-1, -one,a( k, 1 ), & + call stdlib_${ri}$copy( imax-k, a( imax, k ), lda, w( k, k+1 ), 1) + call stdlib_${ri}$copy( n-imax+1, a( imax, imax ), 1,w( imax, k+1 ), 1 ) + if( k>1 )call stdlib_${ri}$gemv( 'NO TRANSPOSE', n-k+1, k-1, -one,a( k, 1 ), & lda, w( imax, 1 ), ldw,one, w( k, k+1 ), 1 ) ! 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 + stdlib_iqamax( imax-k, w( k, k+1 ), 1 ) + jmax = k - 1 + stdlib_i${ri}$amax( imax-k, w( k, k+1 ), 1 ) rowmax = abs( w( jmax, k+1 ) ) else rowmax = zero end if if( imaxrowmax ) then rowmax = dtemp @@ -49320,7 +49321,7 @@ module stdlib_linalg_lapack_q ! use 1-by-1 pivot block kp = imax ! copy column k+1 of w to column k of w - call stdlib_qcopy( n-k+1, w( k, k+1 ), 1, w( k, k ), 1 ) + call stdlib_${ri}$copy( n-k+1, w( k, k+1 ), 1, w( k, k ), 1 ) done = .true. ! equivalent to testing for rowmax==colmax, ! (used to handle nan and inf) @@ -49336,7 +49337,7 @@ module stdlib_linalg_lapack_q colmax = rowmax imax = jmax ! copy updated jmaxth (next imaxth) column to kth of w - call stdlib_qcopy( n-k+1, w( k, k+1 ), 1, w( k, k ), 1 ) + call stdlib_${ri}$copy( n-k+1, w( k, k+1 ), 1, w( k, k ), 1 ) end if ! end pivot search loop body if( .not. done ) goto 72 @@ -49345,33 +49346,33 @@ module stdlib_linalg_lapack_q kk = k + kstep - 1 if( ( kstep==2 ) .and. ( p/=k ) ) then ! copy non-updated column k to column p - call stdlib_qcopy( p-k, a( k, k ), 1, a( p, k ), lda ) - call stdlib_qcopy( n-p+1, a( p, k ), 1, a( p, p ), 1 ) + call stdlib_${ri}$copy( p-k, a( k, k ), 1, a( p, k ), lda ) + call stdlib_${ri}$copy( n-p+1, a( p, k ), 1, a( p, p ), 1 ) ! interchange rows k and p in first k columns of a ! and first k+1 columns of w - call stdlib_qswap( k, a( k, 1 ), lda, a( p, 1 ), lda ) - call stdlib_qswap( kk, w( k, 1 ), ldw, w( p, 1 ), ldw ) + call stdlib_${ri}$swap( k, a( k, 1 ), lda, a( p, 1 ), lda ) + call stdlib_${ri}$swap( kk, w( k, 1 ), ldw, w( p, 1 ), 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_qcopy( kp-k-1, a( k+1, kk ), 1, a( kp, k+1 ), lda ) - call stdlib_qcopy( n-kp+1, a( kp, kk ), 1, a( kp, kp ), 1 ) + call stdlib_${ri}$copy( kp-k-1, a( k+1, kk ), 1, a( kp, k+1 ), lda ) + call stdlib_${ri}$copy( n-kp+1, a( kp, kk ), 1, a( kp, kp ), 1 ) ! interchange rows kk and kp in first kk columns of a and w - call stdlib_qswap( kk, a( kk, 1 ), lda, a( kp, 1 ), lda ) - call stdlib_qswap( kk, w( kk, 1 ), ldw, w( kp, 1 ), ldw ) + call stdlib_${ri}$swap( kk, a( kk, 1 ), lda, a( kp, 1 ), lda ) + call stdlib_${ri}$swap( kk, w( kk, 1 ), ldw, w( kp, 1 ), ldw ) end if if( kstep==1 ) 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_qcopy( n-k+1, w( k, k ), 1, a( k, k ), 1 ) + call stdlib_${ri}$copy( n-k+1, w( k, k ), 1, a( k, k ), 1 ) if( k=sfmin ) then r1 = one / a( k, k ) - call stdlib_qscal( n-k, r1, a( k+1, k ), 1 ) + call stdlib_${ri}$scal( n-k, r1, a( k+1, k ), 1 ) else if( a( k, k )/=zero ) then do ii = k + 1, n a( ii, k ) = a( ii, k ) / a( k, k ) @@ -49418,11 +49419,11 @@ module stdlib_linalg_lapack_q jb = min( nb, n-j+1 ) ! update the lower triangle of the diagonal block do jj = j, j + jb - 1 - call stdlib_qgemv( 'NO TRANSPOSE', j+jb-jj, k-1, -one,a( jj, 1 ), lda, w( jj, & + call stdlib_${ri}$gemv( 'NO TRANSPOSE', j+jb-jj, k-1, -one,a( jj, 1 ), lda, w( jj, & 1 ), ldw, one,a( jj, jj ), 1 ) end do ! update the rectangular subdiagonal block - if( j+jb<=n )call stdlib_qgemm( 'NO TRANSPOSE', 'TRANSPOSE', n-j-jb+1, jb,k-1, -& + if( j+jb<=n )call stdlib_${ri}$gemm( 'NO TRANSPOSE', 'TRANSPOSE', n-j-jb+1, jb,k-1, -& one, a( j+jb, 1 ), lda, w( j, 1 ), ldw,one, a( j+jb, j ), lda ) end do ! put l21 in standard form by partially undoing the interchanges @@ -49440,20 +49441,20 @@ module stdlib_linalg_lapack_q kstep = 2 end if j = j - 1 - if( jp2/=jj .and. j>=1 )call stdlib_qswap( j, a( jp2, 1 ), lda, a( jj, 1 ), lda ) + if( jp2/=jj .and. j>=1 )call stdlib_${ri}$swap( j, a( jp2, 1 ), lda, a( jj, 1 ), lda ) jj = j + 1 - if( jp1/=jj .and. kstep==2 )call stdlib_qswap( j, a( jp1, 1 ), lda, a( jj, 1 ), & + if( jp1/=jj .and. kstep==2 )call stdlib_${ri}$swap( j, a( jp1, 1 ), lda, a( jj, 1 ), & lda ) if( j>=1 )go to 120 ! set kb to the number of columns factorized kb = k - 1 end if return - end subroutine stdlib_qlasyf_rook + end subroutine stdlib_${ri}$lasyf_rook - pure subroutine stdlib_qlat2s( uplo, n, a, lda, sa, ldsa, info ) + pure subroutine stdlib_${ri}$lat2s( uplo, n, a, lda, sa, ldsa, info ) !! DLAT2S: converts a DOUBLE PRECISION triangular matrix, SA, to a SINGLE !! PRECISION triangular matrix, A. !! RMAX is the overflow for the SINGLE PRECISION arithmetic @@ -49469,11 +49470,11 @@ module stdlib_linalg_lapack_q integer(ilp), intent(in) :: lda, ldsa, n ! Array Arguments real(dp), intent(out) :: sa(ldsa,*) - real(qp), intent(in) :: a(lda,*) + real(${rk}$), intent(in) :: a(lda,*) ! ===================================================================== ! Local Scalars integer(ilp) :: i, j - real(qp) :: rmax + real(${rk}$) :: rmax logical(lk) :: upper ! Executable Statements rmax = stdlib_dlamch( 'O' ) @@ -49501,10 +49502,10 @@ module stdlib_linalg_lapack_q end if 50 continue return - end subroutine stdlib_qlat2s + end subroutine stdlib_${ri}$lat2s - pure subroutine stdlib_qlatbs( uplo, trans, diag, normin, n, kd, ab, ldab, x,scale, cnorm, & + pure subroutine stdlib_${ri}$latbs( uplo, trans, diag, normin, n, kd, ab, ldab, x,scale, cnorm, & !! DLATBS: solves one of the triangular systems !! A *x = s*b or A**T*x = s*b !! with scaling to prevent overflow, where A is an upper or lower @@ -49523,16 +49524,16 @@ module stdlib_linalg_lapack_q character, intent(in) :: diag, normin, trans, uplo integer(ilp), intent(out) :: info integer(ilp), intent(in) :: kd, ldab, n - real(qp), intent(out) :: scale + real(${rk}$), intent(out) :: scale ! Array Arguments - real(qp), intent(in) :: ab(ldab,*) - real(qp), intent(inout) :: cnorm(*), x(*) + real(${rk}$), intent(in) :: ab(ldab,*) + real(${rk}$), intent(inout) :: cnorm(*), x(*) ! ===================================================================== ! Local Scalars logical(lk) :: notran, nounit, upper integer(ilp) :: i, imax, j, jfirst, jinc, jlast, jlen, maind - real(qp) :: bignum, grow, rec, smlnum, sumj, tjj, tjjs, tmax, tscal, uscal, xbnd, xj, & + real(${rk}$) :: bignum, grow, rec, smlnum, sumj, tjj, tjjs, tmax, tscal, uscal, xbnd, xj, & xmax ! Intrinsic Functions intrinsic :: abs,max,min @@ -49566,7 +49567,7 @@ module stdlib_linalg_lapack_q ! quick return if possible if( n==0 )return ! determine machine dependent parameters to control overflow. - smlnum = stdlib_qlamch( 'SAFE MINIMUM' ) / stdlib_qlamch( 'PRECISION' ) + smlnum = stdlib_${ri}$lamch( 'SAFE MINIMUM' ) / stdlib_${ri}$lamch( 'PRECISION' ) bignum = one / smlnum scale = one if( stdlib_lsame( normin, 'N' ) ) then @@ -49575,14 +49576,14 @@ module stdlib_linalg_lapack_q ! a is upper triangular. do j = 1, n jlen = min( kd, j-1 ) - cnorm( j ) = stdlib_qasum( jlen, ab( kd+1-jlen, j ), 1 ) + cnorm( j ) = stdlib_${ri}$asum( jlen, ab( kd+1-jlen, j ), 1 ) end do else ! a is lower triangular. do j = 1, n jlen = min( kd, n-j ) if( jlen>0 ) then - cnorm( j ) = stdlib_qasum( jlen, ab( 2, j ), 1 ) + cnorm( j ) = stdlib_${ri}$asum( jlen, ab( 2, j ), 1 ) else cnorm( j ) = zero end if @@ -49591,17 +49592,17 @@ module stdlib_linalg_lapack_q end if ! scale the column norms by tscal if the maximum element in cnorm is ! greater than bignum. - imax = stdlib_iqamax( n, cnorm, 1 ) + imax = stdlib_i${ri}$amax( n, cnorm, 1 ) tmax = cnorm( imax ) if( tmax<=bignum ) then tscal = one else tscal = one / ( smlnum*tmax ) - call stdlib_qscal( n, tscal, cnorm, 1 ) + call stdlib_${ri}$scal( n, tscal, cnorm, 1 ) end if ! compute a bound on the computed solution vector to see if the - ! level 2 blas routine stdlib_qtbsv can be used. - j = stdlib_iqamax( n, x, 1 ) + ! level 2 blas routine stdlib_${ri}$tbsv can be used. + j = stdlib_i${ri}$amax( n, x, 1 ) xmax = abs( x( j ) ) xbnd = xmax if( notran ) then @@ -49705,14 +49706,14 @@ module stdlib_linalg_lapack_q if( ( grow*tscal )>smlnum ) then ! use the level 2 blas solve if the reciprocal of the bound on ! elements of x is not too small. - call stdlib_qtbsv( uplo, trans, diag, n, kd, ab, ldab, x, 1 ) + call stdlib_${ri}$tbsv( uplo, trans, diag, n, kd, ab, ldab, x, 1 ) else ! use a level 1 blas solve, scaling intermediate results. if( xmax>bignum ) then ! scale x so that its components are less than or equal to ! bignum in absolute value. scale = bignum / xmax - call stdlib_qscal( n, scale, x, 1 ) + call stdlib_${ri}$scal( n, scale, x, 1 ) xmax = bignum end if if( notran ) then @@ -49733,7 +49734,7 @@ module stdlib_linalg_lapack_q if( xj>tjj*bignum ) then ! scale x by 1/b(j). rec = one / xj - call stdlib_qscal( n, rec, x, 1 ) + call stdlib_${ri}$scal( n, rec, x, 1 ) scale = scale*rec xmax = xmax*rec end if @@ -49751,7 +49752,7 @@ module stdlib_linalg_lapack_q ! multiplying x(j) times column j. rec = rec / cnorm( j ) end if - call stdlib_qscal( n, rec, x, 1 ) + call stdlib_${ri}$scal( n, rec, x, 1 ) scale = scale*rec xmax = xmax*rec end if @@ -49776,12 +49777,12 @@ module stdlib_linalg_lapack_q if( cnorm( j )>( bignum-xmax )*rec ) then ! scale x by 1/(2*abs(x(j))). rec = rec*half - call stdlib_qscal( n, rec, x, 1 ) + call stdlib_${ri}$scal( n, rec, x, 1 ) scale = scale*rec end if else if( xj*cnorm( j )>( bignum-xmax ) ) then ! scale x by 1/2. - call stdlib_qscal( n, half, x, 1 ) + call stdlib_${ri}$scal( n, half, x, 1 ) scale = scale*half end if if( upper ) then @@ -49790,9 +49791,9 @@ module stdlib_linalg_lapack_q ! x(max(1,j-kd):j-1) := x(max(1,j-kd):j-1) - ! x(j)* a(max(1,j-kd):j-1,j) jlen = min( kd, j-1 ) - call stdlib_qaxpy( jlen, -x( j )*tscal,ab( kd+1-jlen, j ), 1, x( j-jlen & + call stdlib_${ri}$axpy( jlen, -x( j )*tscal,ab( kd+1-jlen, j ), 1, x( j-jlen & ), 1 ) - i = stdlib_iqamax( j-1, x, 1 ) + i = stdlib_i${ri}$amax( j-1, x, 1 ) xmax = abs( x( i ) ) end if else if( j0 )call stdlib_qaxpy( jlen, -x( j )*tscal, ab( 2, j ), 1,x( j+1 ),& + if( jlen>0 )call stdlib_${ri}$axpy( jlen, -x( j )*tscal, ab( 2, j ), 1,x( j+1 ),& 1 ) - i = j + stdlib_iqamax( n-j, x( j+1 ), 1 ) + i = j + stdlib_i${ri}$amax( n-j, x( j+1 ), 1 ) xmax = abs( x( i ) ) end if end do loop_110 @@ -49829,7 +49830,7 @@ module stdlib_linalg_lapack_q uscal = uscal / tjjs end if if( rec0 )sumj = stdlib_qdot( jlen, ab( 2, j ), 1, x( j+1 ), 1 ) + if( jlen>0 )sumj = stdlib_${ri}$dot( jlen, ab( 2, j ), 1, x( j+1 ), 1 ) end if else @@ -49879,7 +49880,7 @@ module stdlib_linalg_lapack_q if( xj>tjj*bignum ) then ! scale x by 1/abs(x(j)). rec = one / xj - call stdlib_qscal( n, rec, x, 1 ) + call stdlib_${ri}$scal( n, rec, x, 1 ) scale = scale*rec xmax = xmax*rec end if @@ -49890,7 +49891,7 @@ module stdlib_linalg_lapack_q if( xj>tjj*bignum ) then ! scale x by (1/abs(x(j)))*abs(a(j,j))*bignum. rec = ( tjj*bignum ) / xj - call stdlib_qscal( n, rec, x, 1 ) + call stdlib_${ri}$scal( n, rec, x, 1 ) scale = scale*rec xmax = xmax*rec end if @@ -49918,13 +49919,13 @@ module stdlib_linalg_lapack_q end if ! scale the column norms by 1/tscal for return. if( tscal/=one ) then - call stdlib_qscal( n, one / tscal, cnorm, 1 ) + call stdlib_${ri}$scal( n, one / tscal, cnorm, 1 ) end if return - end subroutine stdlib_qlatbs + end subroutine stdlib_${ri}$latbs - pure subroutine stdlib_qlatdf( ijob, n, z, ldz, rhs, rdsum, rdscal, ipiv,jpiv ) + pure subroutine stdlib_${ri}$latdf( ijob, n, z, ldz, rhs, rdsum, rdscal, ipiv,jpiv ) !! DLATDF: uses the LU factorization of the n-by-n matrix Z computed by !! DGETC2 and computes a contribution to the reciprocal Dif-estimate !! by solving Z * x = b for x, and choosing the r.h.s. b such that @@ -49938,10 +49939,10 @@ module stdlib_linalg_lapack_q ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments integer(ilp), intent(in) :: ijob, ldz, n - real(qp), intent(inout) :: rdscal, rdsum + real(${rk}$), intent(inout) :: rdscal, rdsum ! Array Arguments integer(ilp), intent(in) :: ipiv(*), jpiv(*) - real(qp), intent(inout) :: rhs(*), z(ldz,*) + real(${rk}$), intent(inout) :: rhs(*), z(ldz,*) ! ===================================================================== ! Parameters integer(ilp), parameter :: maxdim = 8 @@ -49949,16 +49950,16 @@ module stdlib_linalg_lapack_q ! Local Scalars integer(ilp) :: i, info, j, k - real(qp) :: bm, bp, pmone, sminu, splus, temp + real(${rk}$) :: bm, bp, pmone, sminu, splus, temp ! Local Arrays integer(ilp) :: iwork(maxdim) - real(qp) :: work(4*maxdim), xm(maxdim), xp(maxdim) + real(${rk}$) :: work(4*maxdim), xm(maxdim), xp(maxdim) ! Intrinsic Functions intrinsic :: abs,sqrt ! Executable Statements if( ijob/=2 ) then ! apply permutations ipiv to rhs - call stdlib_qlaswp( 1, rhs, ldz, 1, n-1, ipiv, 1 ) + call stdlib_${ri}$laswp( 1, rhs, ldz, 1, n-1, ipiv, 1 ) ! solve for l-part choosing rhs either to +1 or -1. pmone = -one loop_10: do j = 1, n - 1 @@ -49967,8 +49968,8 @@ module stdlib_linalg_lapack_q splus = one ! look-ahead for l-part rhs(1:n-1) = + or -1, splus and ! smin computed more efficiently than in bsolve [1]. - splus = splus + stdlib_qdot( n-j, z( j+1, j ), 1, z( j+1, j ), 1 ) - sminu = stdlib_qdot( n-j, z( j+1, j ), 1, rhs( j+1 ), 1 ) + splus = splus + stdlib_${ri}$dot( n-j, z( j+1, j ), 1, z( j+1, j ), 1 ) + sminu = stdlib_${ri}$dot( n-j, z( j+1, j ), 1, rhs( j+1 ), 1 ) splus = splus*rhs( j ) if( splus>sminu ) then rhs( j ) = bp @@ -49985,13 +49986,13 @@ module stdlib_linalg_lapack_q end if ! compute the remaining r.h.s. temp = -rhs( j ) - call stdlib_qaxpy( n-j, temp, z( j+1, j ), 1, rhs( j+1 ), 1 ) + call stdlib_${ri}$axpy( n-j, temp, z( j+1, j ), 1, rhs( j+1 ), 1 ) end do loop_10 ! solve for u-part, look-ahead for rhs(n) = +-1. this is not done ! in bsolve and will hopefully give us a better estimate because ! any ill-conditioning of the original matrix is transferred to u ! and not to l. u(n, n) is an approximation to sigma_min(lu). - call stdlib_qcopy( n-1, rhs, 1, xp, 1 ) + call stdlib_${ri}$copy( n-1, rhs, 1, xp, 1 ) xp( n ) = rhs( n ) + one rhs( n ) = rhs( n ) - one splus = zero @@ -50007,34 +50008,34 @@ module stdlib_linalg_lapack_q splus = splus + abs( xp( i ) ) sminu = sminu + abs( rhs( i ) ) end do - if( splus>sminu )call stdlib_qcopy( n, xp, 1, rhs, 1 ) + if( splus>sminu )call stdlib_${ri}$copy( n, xp, 1, rhs, 1 ) ! apply the permutations jpiv to the computed solution (rhs) - call stdlib_qlaswp( 1, rhs, ldz, 1, n-1, jpiv, -1 ) + call stdlib_${ri}$laswp( 1, rhs, ldz, 1, n-1, jpiv, -1 ) ! compute the sum of squares - call stdlib_qlassq( n, rhs, 1, rdscal, rdsum ) + call stdlib_${ri}$lassq( n, rhs, 1, rdscal, rdsum ) else ! ijob = 2, compute approximate nullvector xm of z - call stdlib_qgecon( 'I', n, z, ldz, one, temp, work, iwork, info ) - call stdlib_qcopy( n, work( n+1 ), 1, xm, 1 ) + call stdlib_${ri}$gecon( 'I', n, z, ldz, one, temp, work, iwork, info ) + call stdlib_${ri}$copy( n, work( n+1 ), 1, xm, 1 ) ! compute rhs - call stdlib_qlaswp( 1, xm, ldz, 1, n-1, ipiv, -1 ) - temp = one / sqrt( stdlib_qdot( n, xm, 1, xm, 1 ) ) - call stdlib_qscal( n, temp, xm, 1 ) - call stdlib_qcopy( n, xm, 1, xp, 1 ) - call stdlib_qaxpy( n, one, rhs, 1, xp, 1 ) - call stdlib_qaxpy( n, -one, xm, 1, rhs, 1 ) - call stdlib_qgesc2( n, z, ldz, rhs, ipiv, jpiv, temp ) - call stdlib_qgesc2( n, z, ldz, xp, ipiv, jpiv, temp ) - if( stdlib_qasum( n, xp, 1 )>stdlib_qasum( n, rhs, 1 ) )call stdlib_qcopy( n, xp, 1,& + call stdlib_${ri}$laswp( 1, xm, ldz, 1, n-1, ipiv, -1 ) + temp = one / sqrt( stdlib_${ri}$dot( n, xm, 1, xm, 1 ) ) + call stdlib_${ri}$scal( n, temp, xm, 1 ) + call stdlib_${ri}$copy( n, xm, 1, xp, 1 ) + call stdlib_${ri}$axpy( n, one, rhs, 1, xp, 1 ) + call stdlib_${ri}$axpy( n, -one, xm, 1, rhs, 1 ) + call stdlib_${ri}$gesc2( n, z, ldz, rhs, ipiv, jpiv, temp ) + call stdlib_${ri}$gesc2( n, z, ldz, xp, ipiv, jpiv, temp ) + if( stdlib_${ri}$asum( n, xp, 1 )>stdlib_${ri}$asum( n, rhs, 1 ) )call stdlib_${ri}$copy( n, xp, 1,& rhs, 1 ) ! compute the sum of squares - call stdlib_qlassq( n, rhs, 1, rdscal, rdsum ) + call stdlib_${ri}$lassq( n, rhs, 1, rdscal, rdsum ) end if return - end subroutine stdlib_qlatdf + end subroutine stdlib_${ri}$latdf - pure subroutine stdlib_qlatps( uplo, trans, diag, normin, n, ap, x, scale,cnorm, info ) + pure subroutine stdlib_${ri}$latps( uplo, trans, diag, normin, n, ap, x, scale,cnorm, info ) !! DLATPS: solves one of the triangular systems !! A *x = s*b or A**T*x = s*b !! with scaling to prevent overflow, where A is an upper or lower @@ -50053,16 +50054,16 @@ module stdlib_linalg_lapack_q character, intent(in) :: diag, normin, trans, uplo integer(ilp), intent(out) :: info integer(ilp), intent(in) :: n - real(qp), intent(out) :: scale + real(${rk}$), intent(out) :: scale ! Array Arguments - real(qp), intent(in) :: ap(*) - real(qp), intent(inout) :: cnorm(*), x(*) + real(${rk}$), intent(in) :: ap(*) + real(${rk}$), intent(inout) :: cnorm(*), x(*) ! ===================================================================== ! Local Scalars logical(lk) :: notran, nounit, upper integer(ilp) :: i, imax, ip, j, jfirst, jinc, jlast, jlen - real(qp) :: bignum, grow, rec, smlnum, sumj, tjj, tjjs, tmax, tscal, uscal, xbnd, xj, & + real(${rk}$) :: bignum, grow, rec, smlnum, sumj, tjj, tjjs, tmax, tscal, uscal, xbnd, xj, & xmax ! Intrinsic Functions intrinsic :: abs,max,min @@ -50092,7 +50093,7 @@ module stdlib_linalg_lapack_q ! quick return if possible if( n==0 )return ! determine machine dependent parameters to control overflow. - smlnum = stdlib_qlamch( 'SAFE MINIMUM' ) / stdlib_qlamch( 'PRECISION' ) + smlnum = stdlib_${ri}$lamch( 'SAFE MINIMUM' ) / stdlib_${ri}$lamch( 'PRECISION' ) bignum = one / smlnum scale = one if( stdlib_lsame( normin, 'N' ) ) then @@ -50101,14 +50102,14 @@ module stdlib_linalg_lapack_q ! a is upper triangular. ip = 1 do j = 1, n - cnorm( j ) = stdlib_qasum( j-1, ap( ip ), 1 ) + cnorm( j ) = stdlib_${ri}$asum( j-1, ap( ip ), 1 ) ip = ip + j end do else ! a is lower triangular. ip = 1 do j = 1, n - 1 - cnorm( j ) = stdlib_qasum( n-j, ap( ip+1 ), 1 ) + cnorm( j ) = stdlib_${ri}$asum( n-j, ap( ip+1 ), 1 ) ip = ip + n - j + 1 end do cnorm( n ) = zero @@ -50116,17 +50117,17 @@ module stdlib_linalg_lapack_q end if ! scale the column norms by tscal if the maximum element in cnorm is ! greater than bignum. - imax = stdlib_iqamax( n, cnorm, 1 ) + imax = stdlib_i${ri}$amax( n, cnorm, 1 ) tmax = cnorm( imax ) if( tmax<=bignum ) then tscal = one else tscal = one / ( smlnum*tmax ) - call stdlib_qscal( n, tscal, cnorm, 1 ) + call stdlib_${ri}$scal( n, tscal, cnorm, 1 ) end if ! compute a bound on the computed solution vector to see if the - ! level 2 blas routine stdlib_qtpsv can be used. - j = stdlib_iqamax( n, x, 1 ) + ! level 2 blas routine stdlib_${ri}$tpsv can be used. + j = stdlib_i${ri}$amax( n, x, 1 ) xmax = abs( x( j ) ) xbnd = xmax if( notran ) then @@ -50234,14 +50235,14 @@ module stdlib_linalg_lapack_q if( ( grow*tscal )>smlnum ) then ! use the level 2 blas solve if the reciprocal of the bound on ! elements of x is not too small. - call stdlib_qtpsv( uplo, trans, diag, n, ap, x, 1 ) + call stdlib_${ri}$tpsv( uplo, trans, diag, n, ap, x, 1 ) else ! use a level 1 blas solve, scaling intermediate results. if( xmax>bignum ) then ! scale x so that its components are less than or equal to ! bignum in absolute value. scale = bignum / xmax - call stdlib_qscal( n, scale, x, 1 ) + call stdlib_${ri}$scal( n, scale, x, 1 ) xmax = bignum end if if( notran ) then @@ -50263,7 +50264,7 @@ module stdlib_linalg_lapack_q if( xj>tjj*bignum ) then ! scale x by 1/b(j). rec = one / xj - call stdlib_qscal( n, rec, x, 1 ) + call stdlib_${ri}$scal( n, rec, x, 1 ) scale = scale*rec xmax = xmax*rec end if @@ -50281,7 +50282,7 @@ module stdlib_linalg_lapack_q ! multiplying x(j) times column j. rec = rec / cnorm( j ) end if - call stdlib_qscal( n, rec, x, 1 ) + call stdlib_${ri}$scal( n, rec, x, 1 ) scale = scale*rec xmax = xmax*rec end if @@ -50306,20 +50307,20 @@ module stdlib_linalg_lapack_q if( cnorm( j )>( bignum-xmax )*rec ) then ! scale x by 1/(2*abs(x(j))). rec = rec*half - call stdlib_qscal( n, rec, x, 1 ) + call stdlib_${ri}$scal( n, rec, x, 1 ) scale = scale*rec end if else if( xj*cnorm( j )>( bignum-xmax ) ) then ! scale x by 1/2. - call stdlib_qscal( n, half, x, 1 ) + call stdlib_${ri}$scal( n, half, x, 1 ) scale = scale*half end if if( upper ) then if( j>1 ) then ! compute the update ! x(1:j-1) := x(1:j-1) - x(j) * a(1:j-1,j) - call stdlib_qaxpy( j-1, -x( j )*tscal, ap( ip-j+1 ), 1, x,1 ) - i = stdlib_iqamax( j-1, x, 1 ) + call stdlib_${ri}$axpy( j-1, -x( j )*tscal, ap( ip-j+1 ), 1, x,1 ) + i = stdlib_i${ri}$amax( j-1, x, 1 ) xmax = abs( x( i ) ) end if ip = ip - j @@ -50327,9 +50328,9 @@ module stdlib_linalg_lapack_q if( jtjj*bignum ) then ! scale x by 1/abs(x(j)). rec = one / xj - call stdlib_qscal( n, rec, x, 1 ) + call stdlib_${ri}$scal( n, rec, x, 1 ) scale = scale*rec xmax = xmax*rec end if @@ -50416,7 +50417,7 @@ module stdlib_linalg_lapack_q if( xj>tjj*bignum ) then ! scale x by (1/abs(x(j)))*abs(a(j,j))*bignum. rec = ( tjj*bignum ) / xj - call stdlib_qscal( n, rec, x, 1 ) + call stdlib_${ri}$scal( n, rec, x, 1 ) scale = scale*rec xmax = xmax*rec end if @@ -50446,13 +50447,13 @@ module stdlib_linalg_lapack_q end if ! scale the column norms by 1/tscal for return. if( tscal/=one ) then - call stdlib_qscal( n, one / tscal, cnorm, 1 ) + call stdlib_${ri}$scal( n, one / tscal, cnorm, 1 ) end if return - end subroutine stdlib_qlatps + end subroutine stdlib_${ri}$latps - pure subroutine stdlib_qlatrd( uplo, n, nb, a, lda, e, tau, w, ldw ) + pure subroutine stdlib_${ri}$latrd( uplo, n, nb, a, lda, e, tau, w, ldw ) !! DLATRD: reduces NB rows and columns of a real symmetric matrix A to !! symmetric tridiagonal form by an orthogonal similarity !! transformation Q**T * A * Q, and returns the matrices V and W which are @@ -50469,13 +50470,13 @@ module stdlib_linalg_lapack_q character, intent(in) :: uplo integer(ilp), intent(in) :: lda, ldw, n, nb ! Array Arguments - real(qp), intent(inout) :: a(lda,*) - real(qp), intent(out) :: e(*), tau(*), w(ldw,*) + real(${rk}$), intent(inout) :: a(lda,*) + real(${rk}$), intent(out) :: e(*), tau(*), w(ldw,*) ! ===================================================================== ! Local Scalars integer(ilp) :: i, iw - real(qp) :: alpha + real(${rk}$) :: alpha ! Intrinsic Functions intrinsic :: min ! Executable Statements @@ -50487,74 +50488,74 @@ module stdlib_linalg_lapack_q iw = i - n + nb if( i1 ) then ! generate elementary reflector h(i) to annihilate ! a(1:i-2,i) - call stdlib_qlarfg( i-1, a( i-1, i ), a( 1, i ), 1, tau( i-1 ) ) + call stdlib_${ri}$larfg( i-1, a( i-1, i ), a( 1, i ), 1, tau( i-1 ) ) e( i-1 ) = a( i-1, i ) a( i-1, i ) = one ! compute w(1:i-1,i) - call stdlib_qsymv( 'UPPER', i-1, one, a, lda, a( 1, i ), 1,zero, w( 1, iw ), & + call stdlib_${ri}$symv( 'UPPER', i-1, one, a, lda, a( 1, i ), 1,zero, w( 1, iw ), & 1 ) if( ismlnum ) then ! use the level 2 blas solve if the reciprocal of the bound on ! elements of x is not too small. - call stdlib_qtrsv( uplo, trans, diag, n, a, lda, x, 1 ) + call stdlib_${ri}$trsv( uplo, trans, diag, n, a, lda, x, 1 ) else ! use a level 1 blas solve, scaling intermediate results. if( xmax>bignum ) then ! scale x so that its components are less than or equal to ! bignum in absolute value. scale = bignum / xmax - call stdlib_qscal( n, scale, x, 1 ) + call stdlib_${ri}$scal( n, scale, x, 1 ) xmax = bignum end if if( notran ) then @@ -50772,7 +50773,7 @@ module stdlib_linalg_lapack_q if( xj>tjj*bignum ) then ! scale x by 1/b(j). rec = one / xj - call stdlib_qscal( n, rec, x, 1 ) + call stdlib_${ri}$scal( n, rec, x, 1 ) scale = scale*rec xmax = xmax*rec end if @@ -50790,7 +50791,7 @@ module stdlib_linalg_lapack_q ! multiplying x(j) times column j. rec = rec / cnorm( j ) end if - call stdlib_qscal( n, rec, x, 1 ) + call stdlib_${ri}$scal( n, rec, x, 1 ) scale = scale*rec xmax = xmax*rec end if @@ -50815,29 +50816,29 @@ module stdlib_linalg_lapack_q if( cnorm( j )>( bignum-xmax )*rec ) then ! scale x by 1/(2*abs(x(j))). rec = rec*half - call stdlib_qscal( n, rec, x, 1 ) + call stdlib_${ri}$scal( n, rec, x, 1 ) scale = scale*rec end if else if( xj*cnorm( j )>( bignum-xmax ) ) then ! scale x by 1/2. - call stdlib_qscal( n, half, x, 1 ) + call stdlib_${ri}$scal( n, half, x, 1 ) scale = scale*half end if if( upper ) then if( j>1 ) then ! compute the update ! x(1:j-1) := x(1:j-1) - x(j) * a(1:j-1,j) - call stdlib_qaxpy( j-1, -x( j )*tscal, a( 1, j ), 1, x,1 ) - i = stdlib_iqamax( j-1, x, 1 ) + call stdlib_${ri}$axpy( j-1, -x( j )*tscal, a( 1, j ), 1, x,1 ) + i = stdlib_i${ri}$amax( j-1, x, 1 ) xmax = abs( x( i ) ) end if else if( jtjj*bignum ) then ! scale x by 1/abs(x(j)). rec = one / xj - call stdlib_qscal( n, rec, x, 1 ) + call stdlib_${ri}$scal( n, rec, x, 1 ) scale = scale*rec xmax = xmax*rec end if @@ -50921,7 +50922,7 @@ module stdlib_linalg_lapack_q if( xj>tjj*bignum ) then ! scale x by (1/abs(x(j)))*abs(a(j,j))*bignum. rec = ( tjj*bignum ) / xj - call stdlib_qscal( n, rec, x, 1 ) + call stdlib_${ri}$scal( n, rec, x, 1 ) scale = scale*rec xmax = xmax*rec end if @@ -50949,13 +50950,13 @@ module stdlib_linalg_lapack_q end if ! scale the column norms by 1/tscal for return. if( tscal/=one ) then - call stdlib_qscal( n, one / tscal, cnorm, 1 ) + call stdlib_${ri}$scal( n, one / tscal, cnorm, 1 ) end if return - end subroutine stdlib_qlatrs + end subroutine stdlib_${ri}$latrs - pure subroutine stdlib_qlatrz( m, n, l, a, lda, tau, work ) + pure subroutine stdlib_${ri}$latrz( m, n, l, a, lda, tau, work ) !! DLATRZ: factors the M-by-(M+L) real upper trapezoidal matrix !! [ A1 A2 ] = [ A(1:M,1:M) A(1:M,N-L+1:N) ] as ( R 0 ) * Z, by means !! of orthogonal transformations. Z is an (M+L)-by-(M+L) orthogonal @@ -50966,8 +50967,8 @@ module stdlib_linalg_lapack_q ! Scalar Arguments integer(ilp), intent(in) :: l, lda, m, n ! Array Arguments - real(qp), intent(inout) :: a(lda,*) - real(qp), intent(out) :: tau(*), work(*) + real(${rk}$), intent(inout) :: a(lda,*) + real(${rk}$), intent(out) :: tau(*), work(*) ! ===================================================================== ! Local Scalars @@ -50986,16 +50987,16 @@ module stdlib_linalg_lapack_q do i = m, 1, -1 ! generate elementary reflector h(i) to annihilate ! [ a(i,i) a(i,n-l+1:n) ] - call stdlib_qlarfg( l+1, a( i, i ), a( i, n-l+1 ), lda, tau( i ) ) + call stdlib_${ri}$larfg( l+1, a( i, i ), a( i, n-l+1 ), lda, tau( i ) ) ! apply h(i) to a(1:i-1,i:n) from the right - call stdlib_qlarz( 'RIGHT', i-1, n-i+1, l, a( i, n-l+1 ), lda,tau( i ), a( 1, i ), & + call stdlib_${ri}$larz( 'RIGHT', i-1, n-i+1, l, a( i, n-l+1 ), lda,tau( i ), a( 1, i ), & lda, work ) end do return - end subroutine stdlib_qlatrz + end subroutine stdlib_${ri}$latrz - pure subroutine stdlib_qlatsqr( m, n, mb, nb, a, lda, t, ldt, work,lwork, info) + pure subroutine stdlib_${ri}$latsqr( m, n, mb, nb, a, lda, t, ldt, work,lwork, info) !! DLATSQR: computes a blocked Tall-Skinny QR factorization of !! a real M-by-N matrix A for M >= N: !! A = Q * ( R ), @@ -51014,8 +51015,8 @@ module stdlib_linalg_lapack_q integer(ilp), intent(out) :: info integer(ilp), intent(in) :: lda, m, n, mb, nb, ldt, lwork ! Array Arguments - real(qp), intent(inout) :: a(lda,*) - real(qp), intent(out) :: work(*), t(ldt,*) + real(${rk}$), intent(inout) :: a(lda,*) + real(${rk}$), intent(out) :: work(*), t(ldt,*) ! ===================================================================== ! Local Scalars logical(lk) :: lquery @@ -51056,31 +51057,31 @@ module stdlib_linalg_lapack_q end if ! the qr decomposition if ((mb<=n).or.(mb>=m)) then - call stdlib_qgeqrt( m, n, nb, a, lda, t, ldt, work, info) + call stdlib_${ri}$geqrt( m, n, nb, a, lda, t, ldt, work, info) return end if kk = mod((m-n),(mb-n)) ii=m-kk+1 ! compute the qr factorization of the first block a(1:mb,1:n) - call stdlib_qgeqrt( mb, n, nb, a(1,1), lda, t, ldt, work, info ) + call stdlib_${ri}$geqrt( mb, n, nb, a(1,1), lda, t, ldt, work, info ) ctr = 1 do i = mb+1, ii-mb+n , (mb-n) ! compute the qr factorization of the current block a(i:i+mb-n,1:n) - call stdlib_qtpqrt( mb-n, n, 0, nb, a(1,1), lda, a( i, 1 ), lda,t(1, ctr * n + 1),& + call stdlib_${ri}$tpqrt( mb-n, n, 0, nb, a(1,1), lda, a( i, 1 ), lda,t(1, ctr * n + 1),& ldt, work, info ) ctr = ctr + 1 end do ! compute the qr factorization of the last block a(ii:m,1:n) if (ii<=m) then - call stdlib_qtpqrt( kk, n, 0, nb, a(1,1), lda, a( ii, 1 ), lda,t(1, ctr * n + 1), & + call stdlib_${ri}$tpqrt( kk, n, 0, nb, a(1,1), lda, a( ii, 1 ), lda,t(1, ctr * n + 1), & ldt,work, info ) end if work( 1 ) = n*nb return - end subroutine stdlib_qlatsqr + end subroutine stdlib_${ri}$latsqr - pure subroutine stdlib_qlauu2( uplo, n, a, lda, info ) + pure subroutine stdlib_${ri}$lauu2( uplo, n, a, lda, info ) !! DLAUU2: computes the product U * U**T or L**T * L, where the triangular !! factor U or L is stored in the upper or lower triangular part of !! the array A. @@ -51097,13 +51098,13 @@ module stdlib_linalg_lapack_q integer(ilp), intent(out) :: info integer(ilp), intent(in) :: lda, n ! Array Arguments - real(qp), intent(inout) :: a(lda,*) + real(${rk}$), intent(inout) :: a(lda,*) ! ===================================================================== ! Local Scalars logical(lk) :: upper integer(ilp) :: i - real(qp) :: aii + real(${rk}$) :: aii ! Intrinsic Functions intrinsic :: max ! Executable Statements @@ -51128,11 +51129,11 @@ module stdlib_linalg_lapack_q do i = 1, n aii = a( i, i ) if( i=n ) then ! use unblocked code - call stdlib_qlauu2( uplo, n, a, lda, info ) + call stdlib_${ri}$lauu2( uplo, n, a, lda, info ) else ! use blocked code if( upper ) then ! compute the product u * u**t. do i = 1, n, nb ib = min( nb, n-i+1 ) - call stdlib_qtrmm( 'RIGHT', 'UPPER', 'TRANSPOSE', 'NON-UNIT',i-1, ib, one, a( & + call stdlib_${ri}$trmm( 'RIGHT', 'UPPER', 'TRANSPOSE', 'NON-UNIT',i-1, ib, one, a( & i, i ), lda, a( 1, i ),lda ) - call stdlib_qlauu2( 'UPPER', ib, a( i, i ), lda, info ) + call stdlib_${ri}$lauu2( 'UPPER', ib, a( i, i ), lda, info ) if( i+ib<=n ) then - call stdlib_qgemm( 'NO TRANSPOSE', 'TRANSPOSE', i-1, ib,n-i-ib+1, one, a( & + call stdlib_${ri}$gemm( 'NO TRANSPOSE', 'TRANSPOSE', i-1, ib,n-i-ib+1, one, a( & 1, i+ib ), lda,a( i, i+ib ), lda, one, a( 1, i ), lda ) - call stdlib_qsyrk( 'UPPER', 'NO TRANSPOSE', ib, n-i-ib+1,one, a( i, i+ib ),& + call stdlib_${ri}$syrk( 'UPPER', 'NO TRANSPOSE', ib, n-i-ib+1,one, a( i, i+ib ),& lda, one, a( i, i ),lda ) end if end do @@ -51219,23 +51220,23 @@ module stdlib_linalg_lapack_q ! compute the product l**t * l. do i = 1, n, nb ib = min( nb, n-i+1 ) - call stdlib_qtrmm( 'LEFT', 'LOWER', 'TRANSPOSE', 'NON-UNIT', ib,i-1, one, a( & + call stdlib_${ri}$trmm( 'LEFT', 'LOWER', 'TRANSPOSE', 'NON-UNIT', ib,i-1, one, a( & i, i ), lda, a( i, 1 ), lda ) - call stdlib_qlauu2( 'LOWER', ib, a( i, i ), lda, info ) + call stdlib_${ri}$lauu2( 'LOWER', ib, a( i, i ), lda, info ) if( i+ib<=n ) then - call stdlib_qgemm( 'TRANSPOSE', 'NO TRANSPOSE', ib, i-1,n-i-ib+1, one, a( & + call stdlib_${ri}$gemm( 'TRANSPOSE', 'NO TRANSPOSE', ib, i-1,n-i-ib+1, one, a( & i+ib, i ), lda,a( i+ib, 1 ), lda, one, a( i, 1 ), lda ) - call stdlib_qsyrk( 'LOWER', 'TRANSPOSE', ib, n-i-ib+1, one,a( i+ib, i ), & + call stdlib_${ri}$syrk( 'LOWER', 'TRANSPOSE', ib, n-i-ib+1, one,a( i+ib, i ), & lda, one, a( i, i ), lda ) end if end do end if end if return - end subroutine stdlib_qlauum + end subroutine stdlib_${ri}$lauum - pure subroutine stdlib_qopgtr( uplo, n, ap, tau, q, ldq, work, info ) + pure subroutine stdlib_${ri}$opgtr( uplo, n, ap, tau, q, ldq, work, info ) !! DOPGTR: generates a real orthogonal matrix Q which is defined as the !! product of n-1 elementary reflectors H(i) of order n, as returned by !! DSPTRD using packed storage: @@ -51249,8 +51250,8 @@ module stdlib_linalg_lapack_q integer(ilp), intent(out) :: info integer(ilp), intent(in) :: ldq, n ! Array Arguments - real(qp), intent(in) :: ap(*), tau(*) - real(qp), intent(out) :: q(ldq,*), work(*) + real(${rk}$), intent(in) :: ap(*), tau(*) + real(${rk}$), intent(out) :: q(ldq,*), work(*) ! ===================================================================== ! Local Scalars @@ -51276,7 +51277,7 @@ module stdlib_linalg_lapack_q ! quick return if possible if( n==0 )return if( upper ) then - ! q was determined by a call to stdlib_qsptrd with uplo = 'u' + ! q was determined by a call to stdlib_${ri}$sptrd with uplo = 'u' ! unpack the vectors which define the elementary reflectors and ! set the last row and column of q equal to those of the unit ! matrix @@ -51294,9 +51295,9 @@ module stdlib_linalg_lapack_q end do q( n, n ) = one ! generate q(1:n-1,1:n-1) - call stdlib_qorg2l( n-1, n-1, n-1, q, ldq, tau, work, iinfo ) + call stdlib_${ri}$org2l( n-1, n-1, n-1, q, ldq, tau, work, iinfo ) else - ! q was determined by a call to stdlib_qsptrd with uplo = 'l'. + ! q was determined by a call to stdlib_${ri}$sptrd with uplo = 'l'. ! unpack the vectors which define the elementary reflectors and ! set the first row and column of q equal to those of the unit ! matrix @@ -51315,14 +51316,14 @@ module stdlib_linalg_lapack_q end do if( n>1 ) then ! generate q(2:n,2:n) - call stdlib_qorg2r( n-1, n-1, n-1, q( 2, 2 ), ldq, tau, work,iinfo ) + call stdlib_${ri}$org2r( n-1, n-1, n-1, q( 2, 2 ), ldq, tau, work,iinfo ) end if end if return - end subroutine stdlib_qopgtr + end subroutine stdlib_${ri}$opgtr - pure subroutine stdlib_qopmtr( side, uplo, trans, m, n, ap, tau, c, ldc, work,info ) + pure subroutine stdlib_${ri}$opmtr( side, uplo, trans, m, n, ap, tau, c, ldc, work,info ) !! DOPMTR: overwrites the general real M-by-N matrix C with !! SIDE = 'L' SIDE = 'R' !! TRANS = 'N': Q * C C * Q @@ -51341,15 +51342,15 @@ module stdlib_linalg_lapack_q integer(ilp), intent(out) :: info integer(ilp), intent(in) :: ldc, m, n ! Array Arguments - real(qp), intent(inout) :: ap(*), c(ldc,*) - real(qp), intent(in) :: tau(*) - real(qp), intent(out) :: work(*) + real(${rk}$), intent(inout) :: ap(*), c(ldc,*) + real(${rk}$), intent(in) :: tau(*) + real(${rk}$), intent(out) :: work(*) ! ===================================================================== ! Local Scalars logical(lk) :: forwrd, left, notran, upper integer(ilp) :: i, i1, i2, i3, ic, ii, jc, mi, ni, nq - real(qp) :: aii + real(${rk}$) :: aii ! Intrinsic Functions intrinsic :: max ! Executable Statements @@ -51384,7 +51385,7 @@ module stdlib_linalg_lapack_q ! quick return if possible if( m==0 .or. n==0 )return if( upper ) then - ! q was determined by a call to stdlib_qsptrd with uplo = 'u' + ! q was determined by a call to stdlib_${ri}$sptrd with uplo = 'u' forwrd = ( left .and. notran ) .or.( .not.left .and. .not.notran ) if( forwrd ) then i1 = 1 @@ -51413,7 +51414,7 @@ module stdlib_linalg_lapack_q ! apply h(i) aii = ap( ii ) ap( ii ) = one - call stdlib_qlarf( side, mi, ni, ap( ii-i+1 ), 1, tau( i ), c, ldc,work ) + call stdlib_${ri}$larf( side, mi, ni, ap( ii-i+1 ), 1, tau( i ), c, ldc,work ) ap( ii ) = aii if( forwrd ) then ii = ii + i + 2 @@ -51422,7 +51423,7 @@ module stdlib_linalg_lapack_q end if end do else - ! q was determined by a call to stdlib_qsptrd with uplo = 'l'. + ! q was determined by a call to stdlib_${ri}$sptrd with uplo = 'l'. forwrd = ( left .and. .not.notran ) .or.( .not.left .and. notran ) if( forwrd ) then i1 = 1 @@ -51455,7 +51456,7 @@ module stdlib_linalg_lapack_q jc = i + 1 end if ! apply h(i) - call stdlib_qlarf( side, mi, ni, ap( ii ), 1, tau( i ),c( ic, jc ), ldc, work ) + call stdlib_${ri}$larf( side, mi, ni, ap( ii ), 1, tau( i ),c( ic, jc ), ldc, work ) ap( ii ) = aii if( forwrd ) then @@ -51466,10 +51467,10 @@ module stdlib_linalg_lapack_q end do end if return - end subroutine stdlib_qopmtr + end subroutine stdlib_${ri}$opmtr - subroutine stdlib_qorbdb( trans, signs, m, p, q, x11, ldx11, x12, ldx12,x21, ldx21, x22, & + subroutine stdlib_${ri}$orbdb( trans, signs, m, p, q, x11, ldx11, x12, ldx12,x21, ldx21, x22, & !! DORBDB: simultaneously bidiagonalizes the blocks of an M-by-M !! partitioned orthogonal matrix X: !! [ B11 | B12 0 0 ] @@ -51495,19 +51496,19 @@ module stdlib_linalg_lapack_q integer(ilp), intent(out) :: info integer(ilp), intent(in) :: ldx11, ldx12, ldx21, ldx22, lwork, m, p, q ! Array Arguments - real(qp), intent(out) :: phi(*), theta(*) - real(qp), intent(out) :: taup1(*), taup2(*), tauq1(*), tauq2(*), work(*) - real(qp), intent(inout) :: x11(ldx11,*), x12(ldx12,*), x21(ldx21,*), x22(ldx22,*) + real(${rk}$), intent(out) :: phi(*), theta(*) + real(${rk}$), intent(out) :: taup1(*), taup2(*), tauq1(*), tauq2(*), work(*) + real(${rk}$), intent(inout) :: x11(ldx11,*), x12(ldx12,*), x21(ldx21,*), x22(ldx22,*) ! ==================================================================== ! Parameters - real(qp), parameter :: realone = 1.0_qp + real(${rk}$), parameter :: realone = 1.0_${rk}$ ! Local Scalars logical(lk) :: colmajor, lquery integer(ilp) :: i, lworkmin, lworkopt - real(qp) :: z1, z2, z3, z4 + real(${rk}$) :: z1, z2, z3, z4 ! Intrinsic Functions intrinsic :: atan2,cos,max,sin ! Executable Statements @@ -51569,120 +51570,120 @@ module stdlib_linalg_lapack_q ! reduce columns 1, ..., q of x11, x12, x21, and x22 do i = 1, q if( i == 1 ) then - call stdlib_qscal( p-i+1, z1, x11(i,i), 1 ) + call stdlib_${ri}$scal( p-i+1, z1, x11(i,i), 1 ) else - call stdlib_qscal( p-i+1, z1*cos(phi(i-1)), x11(i,i), 1 ) - call stdlib_qaxpy( p-i+1, -z1*z3*z4*sin(phi(i-1)), x12(i,i-1),1, x11(i,i), 1 ) + call stdlib_${ri}$scal( p-i+1, z1*cos(phi(i-1)), x11(i,i), 1 ) + call stdlib_${ri}$axpy( p-i+1, -z1*z3*z4*sin(phi(i-1)), x12(i,i-1),1, x11(i,i), 1 ) end if if( i == 1 ) then - call stdlib_qscal( m-p-i+1, z2, x21(i,i), 1 ) + call stdlib_${ri}$scal( m-p-i+1, z2, x21(i,i), 1 ) else - call stdlib_qscal( m-p-i+1, z2*cos(phi(i-1)), x21(i,i), 1 ) - call stdlib_qaxpy( m-p-i+1, -z2*z3*z4*sin(phi(i-1)), x22(i,i-1),1, x21(i,i), & + call stdlib_${ri}$scal( m-p-i+1, z2*cos(phi(i-1)), x21(i,i), 1 ) + call stdlib_${ri}$axpy( m-p-i+1, -z2*z3*z4*sin(phi(i-1)), x22(i,i-1),1, x21(i,i), & 1 ) end if - theta(i) = atan2( stdlib_qnrm2( m-p-i+1, x21(i,i), 1 ),stdlib_qnrm2( p-i+1, x11(& + theta(i) = atan2( stdlib_${ri}$nrm2( m-p-i+1, x21(i,i), 1 ),stdlib_${ri}$nrm2( p-i+1, x11(& i,i), 1 ) ) if( p > i ) then - call stdlib_qlarfgp( p-i+1, x11(i,i), x11(i+1,i), 1, taup1(i) ) + call stdlib_${ri}$larfgp( p-i+1, x11(i,i), x11(i+1,i), 1, taup1(i) ) else if( p == i ) then - call stdlib_qlarfgp( p-i+1, x11(i,i), x11(i,i), 1, taup1(i) ) + call stdlib_${ri}$larfgp( p-i+1, x11(i,i), x11(i,i), 1, taup1(i) ) end if x11(i,i) = one if ( m-p > i ) then - call stdlib_qlarfgp( m-p-i+1, x21(i,i), x21(i+1,i), 1,taup2(i) ) + call stdlib_${ri}$larfgp( m-p-i+1, x21(i,i), x21(i+1,i), 1,taup2(i) ) else if ( m-p == i ) then - call stdlib_qlarfgp( m-p-i+1, x21(i,i), x21(i,i), 1, taup2(i) ) + call stdlib_${ri}$larfgp( m-p-i+1, x21(i,i), x21(i,i), 1, taup2(i) ) end if x21(i,i) = one if ( q > i ) then - call stdlib_qlarf( 'L', p-i+1, q-i, x11(i,i), 1, taup1(i),x11(i,i+1), ldx11, & + call stdlib_${ri}$larf( 'L', p-i+1, q-i, x11(i,i), 1, taup1(i),x11(i,i+1), ldx11, & work ) end if if ( m-q+1 > i ) then - call stdlib_qlarf( 'L', p-i+1, m-q-i+1, x11(i,i), 1, taup1(i),x12(i,i), ldx12,& + call stdlib_${ri}$larf( 'L', p-i+1, m-q-i+1, x11(i,i), 1, taup1(i),x12(i,i), ldx12,& work ) end if if ( q > i ) then - call stdlib_qlarf( 'L', m-p-i+1, q-i, x21(i,i), 1, taup2(i),x21(i,i+1), ldx21,& + call stdlib_${ri}$larf( 'L', m-p-i+1, q-i, x21(i,i), 1, taup2(i),x21(i,i+1), ldx21,& work ) end if if ( m-q+1 > i ) then - call stdlib_qlarf( 'L', m-p-i+1, m-q-i+1, x21(i,i), 1, taup2(i),x22(i,i), & + call stdlib_${ri}$larf( 'L', m-p-i+1, m-q-i+1, x21(i,i), 1, taup2(i),x22(i,i), & ldx22, work ) end if if( i < q ) then - call stdlib_qscal( q-i, -z1*z3*sin(theta(i)), x11(i,i+1),ldx11 ) - call stdlib_qaxpy( q-i, z2*z3*cos(theta(i)), x21(i,i+1), ldx21,x11(i,i+1), & + call stdlib_${ri}$scal( q-i, -z1*z3*sin(theta(i)), x11(i,i+1),ldx11 ) + call stdlib_${ri}$axpy( q-i, z2*z3*cos(theta(i)), x21(i,i+1), ldx21,x11(i,i+1), & ldx11 ) end if - call stdlib_qscal( m-q-i+1, -z1*z4*sin(theta(i)), x12(i,i), ldx12 ) - call stdlib_qaxpy( m-q-i+1, z2*z4*cos(theta(i)), x22(i,i), ldx22,x12(i,i), ldx12 & + call stdlib_${ri}$scal( m-q-i+1, -z1*z4*sin(theta(i)), x12(i,i), ldx12 ) + call stdlib_${ri}$axpy( m-q-i+1, z2*z4*cos(theta(i)), x22(i,i), ldx22,x12(i,i), ldx12 & ) - if( i < q )phi(i) = atan2( stdlib_qnrm2( q-i, x11(i,i+1), ldx11 ),stdlib_qnrm2( & + if( i < q )phi(i) = atan2( stdlib_${ri}$nrm2( q-i, x11(i,i+1), ldx11 ),stdlib_${ri}$nrm2( & m-q-i+1, x12(i,i), ldx12 ) ) if( i < q ) then if ( q-i == 1 ) then - call stdlib_qlarfgp( q-i, x11(i,i+1), x11(i,i+1), ldx11,tauq1(i) ) + call stdlib_${ri}$larfgp( q-i, x11(i,i+1), x11(i,i+1), ldx11,tauq1(i) ) else - call stdlib_qlarfgp( q-i, x11(i,i+1), x11(i,i+2), ldx11,tauq1(i) ) + call stdlib_${ri}$larfgp( q-i, x11(i,i+1), x11(i,i+2), ldx11,tauq1(i) ) end if x11(i,i+1) = one end if if ( q+i-1 < m ) then if ( m-q == i ) then - call stdlib_qlarfgp( m-q-i+1, x12(i,i), x12(i,i), ldx12,tauq2(i) ) + call stdlib_${ri}$larfgp( m-q-i+1, x12(i,i), x12(i,i), ldx12,tauq2(i) ) else - call stdlib_qlarfgp( m-q-i+1, x12(i,i), x12(i,i+1), ldx12,tauq2(i) ) + call stdlib_${ri}$larfgp( m-q-i+1, x12(i,i), x12(i,i+1), ldx12,tauq2(i) ) end if end if x12(i,i) = one if( i < q ) then - call stdlib_qlarf( 'R', p-i, q-i, x11(i,i+1), ldx11, tauq1(i),x11(i+1,i+1), & + call stdlib_${ri}$larf( 'R', p-i, q-i, x11(i,i+1), ldx11, tauq1(i),x11(i+1,i+1), & ldx11, work ) - call stdlib_qlarf( 'R', m-p-i, q-i, x11(i,i+1), ldx11, tauq1(i),x21(i+1,i+1), & + call stdlib_${ri}$larf( 'R', m-p-i, q-i, x11(i,i+1), ldx11, tauq1(i),x21(i+1,i+1), & ldx21, work ) end if if ( p > i ) then - call stdlib_qlarf( 'R', p-i, m-q-i+1, x12(i,i), ldx12, tauq2(i),x12(i+1,i), & + call stdlib_${ri}$larf( 'R', p-i, m-q-i+1, x12(i,i), ldx12, tauq2(i),x12(i+1,i), & ldx12, work ) end if if ( m-p > i ) then - call stdlib_qlarf( 'R', m-p-i, m-q-i+1, x12(i,i), ldx12,tauq2(i), x22(i+1,i), & + call stdlib_${ri}$larf( 'R', m-p-i, m-q-i+1, x12(i,i), ldx12,tauq2(i), x22(i+1,i), & ldx22, work ) end if end do ! reduce columns q + 1, ..., p of x12, x22 do i = q + 1, p - call stdlib_qscal( m-q-i+1, -z1*z4, x12(i,i), ldx12 ) + call stdlib_${ri}$scal( m-q-i+1, -z1*z4, x12(i,i), ldx12 ) if ( i >= m-q ) then - call stdlib_qlarfgp( m-q-i+1, x12(i,i), x12(i,i), ldx12,tauq2(i) ) + call stdlib_${ri}$larfgp( m-q-i+1, x12(i,i), x12(i,i), ldx12,tauq2(i) ) else - call stdlib_qlarfgp( m-q-i+1, x12(i,i), x12(i,i+1), ldx12,tauq2(i) ) + call stdlib_${ri}$larfgp( m-q-i+1, x12(i,i), x12(i,i+1), ldx12,tauq2(i) ) end if x12(i,i) = one if ( p > i ) then - call stdlib_qlarf( 'R', p-i, m-q-i+1, x12(i,i), ldx12, tauq2(i),x12(i+1,i), & + call stdlib_${ri}$larf( 'R', p-i, m-q-i+1, x12(i,i), ldx12, tauq2(i),x12(i+1,i), & ldx12, work ) end if - if( m-p-q >= 1 )call stdlib_qlarf( 'R', m-p-q, m-q-i+1, x12(i,i), ldx12,tauq2(i),& + if( m-p-q >= 1 )call stdlib_${ri}$larf( 'R', m-p-q, m-q-i+1, x12(i,i), ldx12,tauq2(i),& x22(q+1,i), ldx22, work ) end do ! reduce columns p + 1, ..., m - q of x12, x22 do i = 1, m - p - q - call stdlib_qscal( m-p-q-i+1, z2*z4, x22(q+i,p+i), ldx22 ) + call stdlib_${ri}$scal( m-p-q-i+1, z2*z4, x22(q+i,p+i), ldx22 ) if ( i == m-p-q ) then - call stdlib_qlarfgp( m-p-q-i+1, x22(q+i,p+i), x22(q+i,p+i),ldx22, tauq2(p+i) ) + call stdlib_${ri}$larfgp( m-p-q-i+1, x22(q+i,p+i), x22(q+i,p+i),ldx22, tauq2(p+i) ) else - call stdlib_qlarfgp( m-p-q-i+1, x22(q+i,p+i), x22(q+i,p+i+1),ldx22, tauq2(p+i)& + call stdlib_${ri}$larfgp( m-p-q-i+1, x22(q+i,p+i), x22(q+i,p+i+1),ldx22, tauq2(p+i)& ) end if x22(q+i,p+i) = one if ( i < m-p-q ) then - call stdlib_qlarf( 'R', m-p-q-i, m-p-q-i+1, x22(q+i,p+i), ldx22,tauq2(p+i), & + call stdlib_${ri}$larf( 'R', m-p-q-i, m-p-q-i+1, x22(q+i,p+i), ldx22,tauq2(p+i), & x22(q+i+1,p+i), ldx22, work ) end if end do @@ -51690,114 +51691,114 @@ module stdlib_linalg_lapack_q ! reduce columns 1, ..., q of x11, x12, x21, x22 do i = 1, q if( i == 1 ) then - call stdlib_qscal( p-i+1, z1, x11(i,i), ldx11 ) + call stdlib_${ri}$scal( p-i+1, z1, x11(i,i), ldx11 ) else - call stdlib_qscal( p-i+1, z1*cos(phi(i-1)), x11(i,i), ldx11 ) - call stdlib_qaxpy( p-i+1, -z1*z3*z4*sin(phi(i-1)), x12(i-1,i),ldx12, x11(i,i),& + call stdlib_${ri}$scal( p-i+1, z1*cos(phi(i-1)), x11(i,i), ldx11 ) + call stdlib_${ri}$axpy( p-i+1, -z1*z3*z4*sin(phi(i-1)), x12(i-1,i),ldx12, x11(i,i),& ldx11 ) end if if( i == 1 ) then - call stdlib_qscal( m-p-i+1, z2, x21(i,i), ldx21 ) + call stdlib_${ri}$scal( m-p-i+1, z2, x21(i,i), ldx21 ) else - call stdlib_qscal( m-p-i+1, z2*cos(phi(i-1)), x21(i,i), ldx21 ) - call stdlib_qaxpy( m-p-i+1, -z2*z3*z4*sin(phi(i-1)), x22(i-1,i),ldx22, x21(i,& + call stdlib_${ri}$scal( m-p-i+1, z2*cos(phi(i-1)), x21(i,i), ldx21 ) + call stdlib_${ri}$axpy( m-p-i+1, -z2*z3*z4*sin(phi(i-1)), x22(i-1,i),ldx22, x21(i,& i), ldx21 ) end if - theta(i) = atan2( stdlib_qnrm2( m-p-i+1, x21(i,i), ldx21 ),stdlib_qnrm2( p-i+1, & + theta(i) = atan2( stdlib_${ri}$nrm2( m-p-i+1, x21(i,i), ldx21 ),stdlib_${ri}$nrm2( p-i+1, & x11(i,i), ldx11 ) ) - call stdlib_qlarfgp( p-i+1, x11(i,i), x11(i,i+1), ldx11, taup1(i) ) + call stdlib_${ri}$larfgp( p-i+1, x11(i,i), x11(i,i+1), ldx11, taup1(i) ) x11(i,i) = one if ( i == m-p ) then - call stdlib_qlarfgp( m-p-i+1, x21(i,i), x21(i,i), ldx21,taup2(i) ) + call stdlib_${ri}$larfgp( m-p-i+1, x21(i,i), x21(i,i), ldx21,taup2(i) ) else - call stdlib_qlarfgp( m-p-i+1, x21(i,i), x21(i,i+1), ldx21,taup2(i) ) + call stdlib_${ri}$larfgp( m-p-i+1, x21(i,i), x21(i,i+1), ldx21,taup2(i) ) end if x21(i,i) = one if ( q > i ) then - call stdlib_qlarf( 'R', q-i, p-i+1, x11(i,i), ldx11, taup1(i),x11(i+1,i), & + call stdlib_${ri}$larf( 'R', q-i, p-i+1, x11(i,i), ldx11, taup1(i),x11(i+1,i), & ldx11, work ) end if if ( m-q+1 > i ) then - call stdlib_qlarf( 'R', m-q-i+1, p-i+1, x11(i,i), ldx11,taup1(i), x12(i,i), & + call stdlib_${ri}$larf( 'R', m-q-i+1, p-i+1, x11(i,i), ldx11,taup1(i), x12(i,i), & ldx12, work ) end if if ( q > i ) then - call stdlib_qlarf( 'R', q-i, m-p-i+1, x21(i,i), ldx21, taup2(i),x21(i+1,i), & + call stdlib_${ri}$larf( 'R', q-i, m-p-i+1, x21(i,i), ldx21, taup2(i),x21(i+1,i), & ldx21, work ) end if if ( m-q+1 > i ) then - call stdlib_qlarf( 'R', m-q-i+1, m-p-i+1, x21(i,i), ldx21,taup2(i), x22(i,i), & + call stdlib_${ri}$larf( 'R', m-q-i+1, m-p-i+1, x21(i,i), ldx21,taup2(i), x22(i,i), & ldx22, work ) end if if( i < q ) then - call stdlib_qscal( q-i, -z1*z3*sin(theta(i)), x11(i+1,i), 1 ) - call stdlib_qaxpy( q-i, z2*z3*cos(theta(i)), x21(i+1,i), 1,x11(i+1,i), 1 ) + call stdlib_${ri}$scal( q-i, -z1*z3*sin(theta(i)), x11(i+1,i), 1 ) + call stdlib_${ri}$axpy( q-i, z2*z3*cos(theta(i)), x21(i+1,i), 1,x11(i+1,i), 1 ) end if - call stdlib_qscal( m-q-i+1, -z1*z4*sin(theta(i)), x12(i,i), 1 ) - call stdlib_qaxpy( m-q-i+1, z2*z4*cos(theta(i)), x22(i,i), 1,x12(i,i), 1 ) + call stdlib_${ri}$scal( m-q-i+1, -z1*z4*sin(theta(i)), x12(i,i), 1 ) + call stdlib_${ri}$axpy( m-q-i+1, z2*z4*cos(theta(i)), x22(i,i), 1,x12(i,i), 1 ) - if( i < q )phi(i) = atan2( stdlib_qnrm2( q-i, x11(i+1,i), 1 ),stdlib_qnrm2( m-q-& + if( i < q )phi(i) = atan2( stdlib_${ri}$nrm2( q-i, x11(i+1,i), 1 ),stdlib_${ri}$nrm2( m-q-& i+1, x12(i,i), 1 ) ) if( i < q ) then if ( q-i == 1) then - call stdlib_qlarfgp( q-i, x11(i+1,i), x11(i+1,i), 1,tauq1(i) ) + call stdlib_${ri}$larfgp( q-i, x11(i+1,i), x11(i+1,i), 1,tauq1(i) ) else - call stdlib_qlarfgp( q-i, x11(i+1,i), x11(i+2,i), 1,tauq1(i) ) + call stdlib_${ri}$larfgp( q-i, x11(i+1,i), x11(i+2,i), 1,tauq1(i) ) end if x11(i+1,i) = one end if if ( m-q > i ) then - call stdlib_qlarfgp( m-q-i+1, x12(i,i), x12(i+1,i), 1,tauq2(i) ) + call stdlib_${ri}$larfgp( m-q-i+1, x12(i,i), x12(i+1,i), 1,tauq2(i) ) else - call stdlib_qlarfgp( m-q-i+1, x12(i,i), x12(i,i), 1,tauq2(i) ) + call stdlib_${ri}$larfgp( m-q-i+1, x12(i,i), x12(i,i), 1,tauq2(i) ) end if x12(i,i) = one if( i < q ) then - call stdlib_qlarf( 'L', q-i, p-i, x11(i+1,i), 1, tauq1(i),x11(i+1,i+1), ldx11,& + call stdlib_${ri}$larf( 'L', q-i, p-i, x11(i+1,i), 1, tauq1(i),x11(i+1,i+1), ldx11,& work ) - call stdlib_qlarf( 'L', q-i, m-p-i, x11(i+1,i), 1, tauq1(i),x21(i+1,i+1), & + call stdlib_${ri}$larf( 'L', q-i, m-p-i, x11(i+1,i), 1, tauq1(i),x21(i+1,i+1), & ldx21, work ) end if - call stdlib_qlarf( 'L', m-q-i+1, p-i, x12(i,i), 1, tauq2(i),x12(i,i+1), ldx12, & + call stdlib_${ri}$larf( 'L', m-q-i+1, p-i, x12(i,i), 1, tauq2(i),x12(i,i+1), ldx12, & work ) if ( m-p-i > 0 ) then - call stdlib_qlarf( 'L', m-q-i+1, m-p-i, x12(i,i), 1, tauq2(i),x22(i,i+1), & + call stdlib_${ri}$larf( 'L', m-q-i+1, m-p-i, x12(i,i), 1, tauq2(i),x22(i,i+1), & ldx22, work ) end if end do ! reduce columns q + 1, ..., p of x12, x22 do i = q + 1, p - call stdlib_qscal( m-q-i+1, -z1*z4, x12(i,i), 1 ) - call stdlib_qlarfgp( m-q-i+1, x12(i,i), x12(i+1,i), 1, tauq2(i) ) + call stdlib_${ri}$scal( m-q-i+1, -z1*z4, x12(i,i), 1 ) + call stdlib_${ri}$larfgp( m-q-i+1, x12(i,i), x12(i+1,i), 1, tauq2(i) ) x12(i,i) = one if ( p > i ) then - call stdlib_qlarf( 'L', m-q-i+1, p-i, x12(i,i), 1, tauq2(i),x12(i,i+1), ldx12,& + call stdlib_${ri}$larf( 'L', m-q-i+1, p-i, x12(i,i), 1, tauq2(i),x12(i,i+1), ldx12,& work ) end if - if( m-p-q >= 1 )call stdlib_qlarf( 'L', m-q-i+1, m-p-q, x12(i,i), 1, tauq2(i),& + if( m-p-q >= 1 )call stdlib_${ri}$larf( 'L', m-q-i+1, m-p-q, x12(i,i), 1, tauq2(i),& x22(i,q+1), ldx22, work ) end do ! reduce columns p + 1, ..., m - q of x12, x22 do i = 1, m - p - q - call stdlib_qscal( m-p-q-i+1, z2*z4, x22(p+i,q+i), 1 ) + call stdlib_${ri}$scal( m-p-q-i+1, z2*z4, x22(p+i,q+i), 1 ) if ( m-p-q == i ) then - call stdlib_qlarfgp( m-p-q-i+1, x22(p+i,q+i), x22(p+i,q+i), 1,tauq2(p+i) ) + call stdlib_${ri}$larfgp( m-p-q-i+1, x22(p+i,q+i), x22(p+i,q+i), 1,tauq2(p+i) ) else - call stdlib_qlarfgp( m-p-q-i+1, x22(p+i,q+i), x22(p+i+1,q+i), 1,tauq2(p+i) ) + call stdlib_${ri}$larfgp( m-p-q-i+1, x22(p+i,q+i), x22(p+i+1,q+i), 1,tauq2(p+i) ) - call stdlib_qlarf( 'L', m-p-q-i+1, m-p-q-i, x22(p+i,q+i), 1,tauq2(p+i), x22(p+& + call stdlib_${ri}$larf( 'L', m-p-q-i+1, m-p-q-i, x22(p+i,q+i), 1,tauq2(p+i), x22(p+& i,q+i+1), ldx22, work ) end if x22(p+i,q+i) = one end do end if return - end subroutine stdlib_qorbdb + end subroutine stdlib_${ri}$orbdb - subroutine stdlib_qorbdb1( m, p, q, x11, ldx11, x21, ldx21, theta, phi,taup1, taup2, tauq1, & + subroutine stdlib_${ri}$orbdb1( m, p, q, x11, ldx11, x21, ldx21, theta, phi,taup1, taup2, tauq1, & !! DORBDB1: simultaneously bidiagonalizes the blocks of a tall and skinny !! matrix X with orthonomal columns: !! [ B11 ] @@ -51821,13 +51822,13 @@ module stdlib_linalg_lapack_q integer(ilp), intent(out) :: info integer(ilp), intent(in) :: lwork, m, p, q, ldx11, ldx21 ! Array Arguments - real(qp), intent(out) :: phi(*), theta(*) - real(qp), intent(out) :: taup1(*), taup2(*), tauq1(*), work(*) - real(qp), intent(inout) :: x11(ldx11,*), x21(ldx21,*) + real(${rk}$), intent(out) :: phi(*), theta(*) + real(${rk}$), intent(out) :: taup1(*), taup2(*), tauq1(*), work(*) + real(${rk}$), intent(inout) :: x11(ldx11,*), x21(ldx21,*) ! ==================================================================== ! Local Scalars - real(qp) :: c, s + real(${rk}$) :: c, s integer(ilp) :: childinfo, i, ilarf, iorbdb5, llarf, lorbdb5, lworkmin, & lworkopt logical(lk) :: lquery @@ -51869,38 +51870,38 @@ module stdlib_linalg_lapack_q end if ! reduce columns 1, ..., q of x11 and x21 do i = 1, q - call stdlib_qlarfgp( p-i+1, x11(i,i), x11(i+1,i), 1, taup1(i) ) - call stdlib_qlarfgp( m-p-i+1, x21(i,i), x21(i+1,i), 1, taup2(i) ) + call stdlib_${ri}$larfgp( p-i+1, x11(i,i), x11(i+1,i), 1, taup1(i) ) + call stdlib_${ri}$larfgp( m-p-i+1, x21(i,i), x21(i+1,i), 1, taup2(i) ) theta(i) = atan2( x21(i,i), x11(i,i) ) c = cos( theta(i) ) s = sin( theta(i) ) x11(i,i) = one x21(i,i) = one - call stdlib_qlarf( 'L', p-i+1, q-i, x11(i,i), 1, taup1(i), x11(i,i+1),ldx11, work(& + call stdlib_${ri}$larf( 'L', p-i+1, q-i, x11(i,i), 1, taup1(i), x11(i,i+1),ldx11, work(& ilarf) ) - call stdlib_qlarf( 'L', m-p-i+1, q-i, x21(i,i), 1, taup2(i),x21(i,i+1), ldx21, work(& + call stdlib_${ri}$larf( 'L', m-p-i+1, q-i, x21(i,i), 1, taup2(i),x21(i,i+1), ldx21, work(& ilarf) ) if( i < q ) then - call stdlib_qrot( q-i, x11(i,i+1), ldx11, x21(i,i+1), ldx21, c, s ) - call stdlib_qlarfgp( q-i, x21(i,i+1), x21(i,i+2), ldx21, tauq1(i) ) + call stdlib_${ri}$rot( q-i, x11(i,i+1), ldx11, x21(i,i+1), ldx21, c, s ) + call stdlib_${ri}$larfgp( q-i, x21(i,i+1), x21(i,i+2), ldx21, tauq1(i) ) s = x21(i,i+1) x21(i,i+1) = one - call stdlib_qlarf( 'R', p-i, q-i, x21(i,i+1), ldx21, tauq1(i),x11(i+1,i+1), & + call stdlib_${ri}$larf( 'R', p-i, q-i, x21(i,i+1), ldx21, tauq1(i),x11(i+1,i+1), & ldx11, work(ilarf) ) - call stdlib_qlarf( 'R', m-p-i, q-i, x21(i,i+1), ldx21, tauq1(i),x21(i+1,i+1), & + call stdlib_${ri}$larf( 'R', m-p-i, q-i, x21(i,i+1), ldx21, tauq1(i),x21(i+1,i+1), & ldx21, work(ilarf) ) - c = sqrt( stdlib_qnrm2( p-i, x11(i+1,i+1), 1 )**2+ stdlib_qnrm2( m-p-i, x21(i+1,& + c = sqrt( stdlib_${ri}$nrm2( p-i, x11(i+1,i+1), 1 )**2+ stdlib_${ri}$nrm2( m-p-i, x21(i+1,& i+1), 1 )**2 ) phi(i) = atan2( s, c ) - call stdlib_qorbdb5( p-i, m-p-i, q-i-1, x11(i+1,i+1), 1,x21(i+1,i+1), 1, x11(i+1,& + call stdlib_${ri}$orbdb5( p-i, m-p-i, q-i-1, x11(i+1,i+1), 1,x21(i+1,i+1), 1, x11(i+1,& i+2), ldx11,x21(i+1,i+2), ldx21, work(iorbdb5), lorbdb5,childinfo ) end if end do return - end subroutine stdlib_qorbdb1 + end subroutine stdlib_${ri}$orbdb1 - subroutine stdlib_qorbdb2( m, p, q, x11, ldx11, x21, ldx21, theta, phi,taup1, taup2, tauq1, & + subroutine stdlib_${ri}$orbdb2( m, p, q, x11, ldx11, x21, ldx21, theta, phi,taup1, taup2, tauq1, & !! DORBDB2: simultaneously bidiagonalizes the blocks of a tall and skinny !! matrix X with orthonomal columns: !! [ B11 ] @@ -51924,13 +51925,13 @@ module stdlib_linalg_lapack_q integer(ilp), intent(out) :: info integer(ilp), intent(in) :: lwork, m, p, q, ldx11, ldx21 ! Array Arguments - real(qp), intent(out) :: phi(*), theta(*) - real(qp), intent(out) :: taup1(*), taup2(*), tauq1(*), work(*) - real(qp), intent(inout) :: x11(ldx11,*), x21(ldx21,*) + real(${rk}$), intent(out) :: phi(*), theta(*) + real(${rk}$), intent(out) :: taup1(*), taup2(*), tauq1(*), work(*) + real(${rk}$), intent(inout) :: x11(ldx11,*), x21(ldx21,*) ! ==================================================================== ! Local Scalars - real(qp) :: c, s + real(${rk}$) :: c, s integer(ilp) :: childinfo, i, ilarf, iorbdb5, llarf, lorbdb5, lworkmin, & lworkopt logical(lk) :: lquery @@ -51973,47 +51974,47 @@ module stdlib_linalg_lapack_q ! reduce rows 1, ..., p of x11 and x21 do i = 1, p if( i > 1 ) then - call stdlib_qrot( q-i+1, x11(i,i), ldx11, x21(i-1,i), ldx21, c, s ) + call stdlib_${ri}$rot( q-i+1, x11(i,i), ldx11, x21(i-1,i), ldx21, c, s ) end if - call stdlib_qlarfgp( q-i+1, x11(i,i), x11(i,i+1), ldx11, tauq1(i) ) + call stdlib_${ri}$larfgp( q-i+1, x11(i,i), x11(i,i+1), ldx11, tauq1(i) ) c = x11(i,i) x11(i,i) = one - call stdlib_qlarf( 'R', p-i, q-i+1, x11(i,i), ldx11, tauq1(i),x11(i+1,i), ldx11, & + call stdlib_${ri}$larf( 'R', p-i, q-i+1, x11(i,i), ldx11, tauq1(i),x11(i+1,i), ldx11, & work(ilarf) ) - call stdlib_qlarf( 'R', m-p-i+1, q-i+1, x11(i,i), ldx11, tauq1(i),x21(i,i), ldx21, & + call stdlib_${ri}$larf( 'R', m-p-i+1, q-i+1, x11(i,i), ldx11, tauq1(i),x21(i,i), ldx21, & work(ilarf) ) - s = sqrt( stdlib_qnrm2( p-i, x11(i+1,i), 1 )**2+ stdlib_qnrm2( m-p-i+1, x21(i,i), 1 & + s = sqrt( stdlib_${ri}$nrm2( p-i, x11(i+1,i), 1 )**2+ stdlib_${ri}$nrm2( m-p-i+1, x21(i,i), 1 & )**2 ) theta(i) = atan2( s, c ) - call stdlib_qorbdb5( p-i, m-p-i+1, q-i, x11(i+1,i), 1, x21(i,i), 1,x11(i+1,i+1), & + call stdlib_${ri}$orbdb5( p-i, m-p-i+1, q-i, x11(i+1,i), 1, x21(i,i), 1,x11(i+1,i+1), & ldx11, x21(i,i+1), ldx21,work(iorbdb5), lorbdb5, childinfo ) - call stdlib_qscal( p-i, negone, x11(i+1,i), 1 ) - call stdlib_qlarfgp( m-p-i+1, x21(i,i), x21(i+1,i), 1, taup2(i) ) + call stdlib_${ri}$scal( p-i, negone, x11(i+1,i), 1 ) + call stdlib_${ri}$larfgp( m-p-i+1, x21(i,i), x21(i+1,i), 1, taup2(i) ) if( i < p ) then - call stdlib_qlarfgp( p-i, x11(i+1,i), x11(i+2,i), 1, taup1(i) ) + call stdlib_${ri}$larfgp( p-i, x11(i+1,i), x11(i+2,i), 1, taup1(i) ) phi(i) = atan2( x11(i+1,i), x21(i,i) ) c = cos( phi(i) ) s = sin( phi(i) ) x11(i+1,i) = one - call stdlib_qlarf( 'L', p-i, q-i, x11(i+1,i), 1, taup1(i),x11(i+1,i+1), ldx11, & + call stdlib_${ri}$larf( 'L', p-i, q-i, x11(i+1,i), 1, taup1(i),x11(i+1,i+1), ldx11, & work(ilarf) ) end if x21(i,i) = one - call stdlib_qlarf( 'L', m-p-i+1, q-i, x21(i,i), 1, taup2(i),x21(i,i+1), ldx21, work(& + call stdlib_${ri}$larf( 'L', m-p-i+1, q-i, x21(i,i), 1, taup2(i),x21(i,i+1), ldx21, work(& ilarf) ) end do ! reduce the bottom-right portion of x21 to the identity matrix do i = p + 1, q - call stdlib_qlarfgp( m-p-i+1, x21(i,i), x21(i+1,i), 1, taup2(i) ) + call stdlib_${ri}$larfgp( m-p-i+1, x21(i,i), x21(i+1,i), 1, taup2(i) ) x21(i,i) = one - call stdlib_qlarf( 'L', m-p-i+1, q-i, x21(i,i), 1, taup2(i),x21(i,i+1), ldx21, work(& + call stdlib_${ri}$larf( 'L', m-p-i+1, q-i, x21(i,i), 1, taup2(i),x21(i,i+1), ldx21, work(& ilarf) ) end do return - end subroutine stdlib_qorbdb2 + end subroutine stdlib_${ri}$orbdb2 - subroutine stdlib_qorbdb3( m, p, q, x11, ldx11, x21, ldx21, theta, phi,taup1, taup2, tauq1, & + subroutine stdlib_${ri}$orbdb3( m, p, q, x11, ldx11, x21, ldx21, theta, phi,taup1, taup2, tauq1, & !! DORBDB3: simultaneously bidiagonalizes the blocks of a tall and skinny !! matrix X with orthonomal columns: !! [ B11 ] @@ -52037,13 +52038,13 @@ module stdlib_linalg_lapack_q integer(ilp), intent(out) :: info integer(ilp), intent(in) :: lwork, m, p, q, ldx11, ldx21 ! Array Arguments - real(qp), intent(out) :: phi(*), theta(*) - real(qp), intent(out) :: taup1(*), taup2(*), tauq1(*), work(*) - real(qp), intent(inout) :: x11(ldx11,*), x21(ldx21,*) + real(${rk}$), intent(out) :: phi(*), theta(*) + real(${rk}$), intent(out) :: taup1(*), taup2(*), tauq1(*), work(*) + real(${rk}$), intent(inout) :: x11(ldx11,*), x21(ldx21,*) ! ==================================================================== ! Local Scalars - real(qp) :: c, s + real(${rk}$) :: c, s integer(ilp) :: childinfo, i, ilarf, iorbdb5, llarf, lorbdb5, lworkmin, & lworkopt logical(lk) :: lquery @@ -52086,46 +52087,46 @@ module stdlib_linalg_lapack_q ! reduce rows 1, ..., m-p of x11 and x21 do i = 1, m-p if( i > 1 ) then - call stdlib_qrot( q-i+1, x11(i-1,i), ldx11, x21(i,i), ldx11, c, s ) + call stdlib_${ri}$rot( q-i+1, x11(i-1,i), ldx11, x21(i,i), ldx11, c, s ) end if - call stdlib_qlarfgp( q-i+1, x21(i,i), x21(i,i+1), ldx21, tauq1(i) ) + call stdlib_${ri}$larfgp( q-i+1, x21(i,i), x21(i,i+1), ldx21, tauq1(i) ) s = x21(i,i) x21(i,i) = one - call stdlib_qlarf( 'R', p-i+1, q-i+1, x21(i,i), ldx21, tauq1(i),x11(i,i), ldx11, & + call stdlib_${ri}$larf( 'R', p-i+1, q-i+1, x21(i,i), ldx21, tauq1(i),x11(i,i), ldx11, & work(ilarf) ) - call stdlib_qlarf( 'R', m-p-i, q-i+1, x21(i,i), ldx21, tauq1(i),x21(i+1,i), ldx21, & + call stdlib_${ri}$larf( 'R', m-p-i, q-i+1, x21(i,i), ldx21, tauq1(i),x21(i+1,i), ldx21, & work(ilarf) ) - c = sqrt( stdlib_qnrm2( p-i+1, x11(i,i), 1 )**2+ stdlib_qnrm2( m-p-i, x21(i+1,i), 1 & + c = sqrt( stdlib_${ri}$nrm2( p-i+1, x11(i,i), 1 )**2+ stdlib_${ri}$nrm2( m-p-i, x21(i+1,i), 1 & )**2 ) theta(i) = atan2( s, c ) - call stdlib_qorbdb5( p-i+1, m-p-i, q-i, x11(i,i), 1, x21(i+1,i), 1,x11(i,i+1), & + call stdlib_${ri}$orbdb5( p-i+1, m-p-i, q-i, x11(i,i), 1, x21(i+1,i), 1,x11(i,i+1), & ldx11, x21(i+1,i+1), ldx21,work(iorbdb5), lorbdb5, childinfo ) - call stdlib_qlarfgp( p-i+1, x11(i,i), x11(i+1,i), 1, taup1(i) ) + call stdlib_${ri}$larfgp( p-i+1, x11(i,i), x11(i+1,i), 1, taup1(i) ) if( i < m-p ) then - call stdlib_qlarfgp( m-p-i, x21(i+1,i), x21(i+2,i), 1, taup2(i) ) + call stdlib_${ri}$larfgp( m-p-i, x21(i+1,i), x21(i+2,i), 1, taup2(i) ) phi(i) = atan2( x21(i+1,i), x11(i,i) ) c = cos( phi(i) ) s = sin( phi(i) ) x21(i+1,i) = one - call stdlib_qlarf( 'L', m-p-i, q-i, x21(i+1,i), 1, taup2(i),x21(i+1,i+1), ldx21, & + call stdlib_${ri}$larf( 'L', m-p-i, q-i, x21(i+1,i), 1, taup2(i),x21(i+1,i+1), ldx21, & work(ilarf) ) end if x11(i,i) = one - call stdlib_qlarf( 'L', p-i+1, q-i, x11(i,i), 1, taup1(i), x11(i,i+1),ldx11, work(& + call stdlib_${ri}$larf( 'L', p-i+1, q-i, x11(i,i), 1, taup1(i), x11(i,i+1),ldx11, work(& ilarf) ) end do ! reduce the bottom-right portion of x11 to the identity matrix do i = m-p + 1, q - call stdlib_qlarfgp( p-i+1, x11(i,i), x11(i+1,i), 1, taup1(i) ) + call stdlib_${ri}$larfgp( p-i+1, x11(i,i), x11(i+1,i), 1, taup1(i) ) x11(i,i) = one - call stdlib_qlarf( 'L', p-i+1, q-i, x11(i,i), 1, taup1(i), x11(i,i+1),ldx11, work(& + call stdlib_${ri}$larf( 'L', p-i+1, q-i, x11(i,i), 1, taup1(i), x11(i,i+1),ldx11, work(& ilarf) ) end do return - end subroutine stdlib_qorbdb3 + end subroutine stdlib_${ri}$orbdb3 - subroutine stdlib_qorbdb4( m, p, q, x11, ldx11, x21, ldx21, theta, phi,taup1, taup2, tauq1, & + subroutine stdlib_${ri}$orbdb4( m, p, q, x11, ldx11, x21, ldx21, theta, phi,taup1, taup2, tauq1, & !! DORBDB4: simultaneously bidiagonalizes the blocks of a tall and skinny !! matrix X with orthonomal columns: !! [ B11 ] @@ -52149,13 +52150,13 @@ module stdlib_linalg_lapack_q integer(ilp), intent(out) :: info integer(ilp), intent(in) :: lwork, m, p, q, ldx11, ldx21 ! Array Arguments - real(qp), intent(out) :: phi(*), theta(*) - real(qp), intent(out) :: phantom(*), taup1(*), taup2(*), tauq1(*), work(*) - real(qp), intent(inout) :: x11(ldx11,*), x21(ldx21,*) + real(${rk}$), intent(out) :: phi(*), theta(*) + real(${rk}$), intent(out) :: phantom(*), taup1(*), taup2(*), tauq1(*), work(*) + real(${rk}$), intent(inout) :: x11(ldx11,*), x21(ldx21,*) ! ==================================================================== ! Local Scalars - real(qp) :: c, s + real(${rk}$) :: c, s integer(ilp) :: childinfo, i, ilarf, iorbdb5, j, llarf, lorbdb5, lworkmin, & lworkopt logical(lk) :: lquery @@ -52202,72 +52203,72 @@ module stdlib_linalg_lapack_q do j = 1, m phantom(j) = zero end do - call stdlib_qorbdb5( p, m-p, q, phantom(1), 1, phantom(p+1), 1,x11, ldx11, x21, & + call stdlib_${ri}$orbdb5( p, m-p, q, phantom(1), 1, phantom(p+1), 1,x11, ldx11, x21, & ldx21, work(iorbdb5),lorbdb5, childinfo ) - call stdlib_qscal( p, negone, phantom(1), 1 ) - call stdlib_qlarfgp( p, phantom(1), phantom(2), 1, taup1(1) ) - call stdlib_qlarfgp( m-p, phantom(p+1), phantom(p+2), 1, taup2(1) ) + call stdlib_${ri}$scal( p, negone, phantom(1), 1 ) + call stdlib_${ri}$larfgp( p, phantom(1), phantom(2), 1, taup1(1) ) + call stdlib_${ri}$larfgp( m-p, phantom(p+1), phantom(p+2), 1, taup2(1) ) theta(i) = atan2( phantom(1), phantom(p+1) ) c = cos( theta(i) ) s = sin( theta(i) ) phantom(1) = one phantom(p+1) = one - call stdlib_qlarf( 'L', p, q, phantom(1), 1, taup1(1), x11, ldx11,work(ilarf) ) + call stdlib_${ri}$larf( 'L', p, q, phantom(1), 1, taup1(1), x11, ldx11,work(ilarf) ) - call stdlib_qlarf( 'L', m-p, q, phantom(p+1), 1, taup2(1), x21,ldx21, work(ilarf)& + call stdlib_${ri}$larf( 'L', m-p, q, phantom(p+1), 1, taup2(1), x21,ldx21, work(ilarf)& ) else - call stdlib_qorbdb5( p-i+1, m-p-i+1, q-i+1, x11(i,i-1), 1,x21(i,i-1), 1, x11(i,i)& + call stdlib_${ri}$orbdb5( p-i+1, m-p-i+1, q-i+1, x11(i,i-1), 1,x21(i,i-1), 1, x11(i,i)& , ldx11, x21(i,i),ldx21, work(iorbdb5), lorbdb5, childinfo ) - call stdlib_qscal( p-i+1, negone, x11(i,i-1), 1 ) - call stdlib_qlarfgp( p-i+1, x11(i,i-1), x11(i+1,i-1), 1, taup1(i) ) - call stdlib_qlarfgp( m-p-i+1, x21(i,i-1), x21(i+1,i-1), 1,taup2(i) ) + call stdlib_${ri}$scal( p-i+1, negone, x11(i,i-1), 1 ) + call stdlib_${ri}$larfgp( p-i+1, x11(i,i-1), x11(i+1,i-1), 1, taup1(i) ) + call stdlib_${ri}$larfgp( m-p-i+1, x21(i,i-1), x21(i+1,i-1), 1,taup2(i) ) theta(i) = atan2( x11(i,i-1), x21(i,i-1) ) c = cos( theta(i) ) s = sin( theta(i) ) x11(i,i-1) = one x21(i,i-1) = one - call stdlib_qlarf( 'L', p-i+1, q-i+1, x11(i,i-1), 1, taup1(i),x11(i,i), ldx11, & + call stdlib_${ri}$larf( 'L', p-i+1, q-i+1, x11(i,i-1), 1, taup1(i),x11(i,i), ldx11, & work(ilarf) ) - call stdlib_qlarf( 'L', m-p-i+1, q-i+1, x21(i,i-1), 1, taup2(i),x21(i,i), ldx21, & + call stdlib_${ri}$larf( 'L', m-p-i+1, q-i+1, x21(i,i-1), 1, taup2(i),x21(i,i), ldx21, & work(ilarf) ) end if - call stdlib_qrot( q-i+1, x11(i,i), ldx11, x21(i,i), ldx21, s, -c ) - call stdlib_qlarfgp( q-i+1, x21(i,i), x21(i,i+1), ldx21, tauq1(i) ) + call stdlib_${ri}$rot( q-i+1, x11(i,i), ldx11, x21(i,i), ldx21, s, -c ) + call stdlib_${ri}$larfgp( q-i+1, x21(i,i), x21(i,i+1), ldx21, tauq1(i) ) c = x21(i,i) x21(i,i) = one - call stdlib_qlarf( 'R', p-i, q-i+1, x21(i,i), ldx21, tauq1(i),x11(i+1,i), ldx11, & + call stdlib_${ri}$larf( 'R', p-i, q-i+1, x21(i,i), ldx21, tauq1(i),x11(i+1,i), ldx11, & work(ilarf) ) - call stdlib_qlarf( 'R', m-p-i, q-i+1, x21(i,i), ldx21, tauq1(i),x21(i+1,i), ldx21, & + call stdlib_${ri}$larf( 'R', m-p-i, q-i+1, x21(i,i), ldx21, tauq1(i),x21(i+1,i), ldx21, & work(ilarf) ) if( i < m-q ) then - s = sqrt( stdlib_qnrm2( p-i, x11(i+1,i), 1 )**2+ stdlib_qnrm2( m-p-i, x21(i+1,i),& + s = sqrt( stdlib_${ri}$nrm2( p-i, x11(i+1,i), 1 )**2+ stdlib_${ri}$nrm2( m-p-i, x21(i+1,i),& 1 )**2 ) phi(i) = atan2( s, c ) end if end do ! reduce the bottom-right portion of x11 to [ i 0 ] do i = m - q + 1, p - call stdlib_qlarfgp( q-i+1, x11(i,i), x11(i,i+1), ldx11, tauq1(i) ) + call stdlib_${ri}$larfgp( q-i+1, x11(i,i), x11(i,i+1), ldx11, tauq1(i) ) x11(i,i) = one - call stdlib_qlarf( 'R', p-i, q-i+1, x11(i,i), ldx11, tauq1(i),x11(i+1,i), ldx11, & + call stdlib_${ri}$larf( 'R', p-i, q-i+1, x11(i,i), ldx11, tauq1(i),x11(i+1,i), ldx11, & work(ilarf) ) - call stdlib_qlarf( 'R', q-p, q-i+1, x11(i,i), ldx11, tauq1(i),x21(m-q+1,i), ldx21, & + call stdlib_${ri}$larf( 'R', q-p, q-i+1, x11(i,i), ldx11, tauq1(i),x21(m-q+1,i), ldx21, & work(ilarf) ) end do ! reduce the bottom-right portion of x21 to [ 0 i ] do i = p + 1, q - call stdlib_qlarfgp( q-i+1, x21(m-q+i-p,i), x21(m-q+i-p,i+1), ldx21,tauq1(i) ) + call stdlib_${ri}$larfgp( q-i+1, x21(m-q+i-p,i), x21(m-q+i-p,i+1), ldx21,tauq1(i) ) x21(m-q+i-p,i) = one - call stdlib_qlarf( 'R', q-i, q-i+1, x21(m-q+i-p,i), ldx21, tauq1(i),x21(m-q+i-p+1,i)& + call stdlib_${ri}$larf( 'R', q-i, q-i+1, x21(m-q+i-p,i), ldx21, tauq1(i),x21(m-q+i-p+1,i)& , ldx21, work(ilarf) ) end do return - end subroutine stdlib_qorbdb4 + end subroutine stdlib_${ri}$orbdb4 - pure subroutine stdlib_qorbdb5( m1, m2, n, x1, incx1, x2, incx2, q1, ldq1, q2,ldq2, work, & + pure subroutine stdlib_${ri}$orbdb5( m1, m2, n, x1, incx1, x2, incx2, q1, ldq1, q2,ldq2, work, & !! DORBDB5: orthogonalizes the column vector !! X = [ X1 ] !! [ X2 ] @@ -52287,9 +52288,9 @@ module stdlib_linalg_lapack_q integer(ilp), intent(in) :: incx1, incx2, ldq1, ldq2, lwork, m1, m2, n integer(ilp), intent(out) :: info ! Array Arguments - real(qp), intent(in) :: q1(ldq1,*), q2(ldq2,*) - real(qp), intent(out) :: work(*) - real(qp), intent(inout) :: x1(*), x2(*) + real(${rk}$), intent(in) :: q1(ldq1,*), q2(ldq2,*) + real(${rk}$), intent(out) :: work(*) + real(${rk}$), intent(inout) :: x1(*), x2(*) ! ===================================================================== ! Local Scalars @@ -52321,10 +52322,10 @@ module stdlib_linalg_lapack_q return end if ! project x onto the orthogonal complement of q - call stdlib_qorbdb6( m1, m2, n, x1, incx1, x2, incx2, q1, ldq1, q2, ldq2,work, lwork, & + call stdlib_${ri}$orbdb6( m1, m2, n, x1, incx1, x2, incx2, q1, ldq1, q2, ldq2,work, lwork, & childinfo ) ! if the projection is nonzero, then return - if( stdlib_qnrm2(m1,x1,incx1) /= zero.or. stdlib_qnrm2(m2,x2,incx2) /= zero ) & + if( stdlib_${ri}$nrm2(m1,x1,incx1) /= zero.or. stdlib_${ri}$nrm2(m2,x2,incx2) /= zero ) & then return end if @@ -52338,9 +52339,9 @@ module stdlib_linalg_lapack_q do j = 1, m2 x2(j) = zero end do - call stdlib_qorbdb6( m1, m2, n, x1, incx1, x2, incx2, q1, ldq1, q2,ldq2, work, & + call stdlib_${ri}$orbdb6( m1, m2, n, x1, incx1, x2, incx2, q1, ldq1, q2,ldq2, work, & lwork, childinfo ) - if( stdlib_qnrm2(m1,x1,incx1) /= zero.or. stdlib_qnrm2(m2,x2,incx2) /= zero ) & + if( stdlib_${ri}$nrm2(m1,x1,incx1) /= zero.or. stdlib_${ri}$nrm2(m2,x2,incx2) /= zero ) & then return end if @@ -52355,18 +52356,18 @@ module stdlib_linalg_lapack_q x2(j) = zero end do x2(i) = one - call stdlib_qorbdb6( m1, m2, n, x1, incx1, x2, incx2, q1, ldq1, q2,ldq2, work, & + call stdlib_${ri}$orbdb6( m1, m2, n, x1, incx1, x2, incx2, q1, ldq1, q2,ldq2, work, & lwork, childinfo ) - if( stdlib_qnrm2(m1,x1,incx1) /= zero.or. stdlib_qnrm2(m2,x2,incx2) /= zero ) & + if( stdlib_${ri}$nrm2(m1,x1,incx1) /= zero.or. stdlib_${ri}$nrm2(m2,x2,incx2) /= zero ) & then return end if end do return - end subroutine stdlib_qorbdb5 + end subroutine stdlib_${ri}$orbdb5 - pure subroutine stdlib_qorbdb6( m1, m2, n, x1, incx1, x2, incx2, q1, ldq1, q2,ldq2, work, & + pure subroutine stdlib_${ri}$orbdb6( m1, m2, n, x1, incx1, x2, incx2, q1, ldq1, q2,ldq2, work, & !! DORBDB6: orthogonalizes the column vector !! X = [ X1 ] !! [ X2 ] @@ -52384,19 +52385,19 @@ module stdlib_linalg_lapack_q integer(ilp), intent(in) :: incx1, incx2, ldq1, ldq2, lwork, m1, m2, n integer(ilp), intent(out) :: info ! Array Arguments - real(qp), intent(in) :: q1(ldq1,*), q2(ldq2,*) - real(qp), intent(out) :: work(*) - real(qp), intent(inout) :: x1(*), x2(*) + real(${rk}$), intent(in) :: q1(ldq1,*), q2(ldq2,*) + real(${rk}$), intent(out) :: work(*) + real(${rk}$), intent(inout) :: x1(*), x2(*) ! ===================================================================== ! Parameters - real(qp), parameter :: alphasq = 0.01_qp - real(qp), parameter :: realone = 1.0_qp - real(qp), parameter :: realzero = 0.0_qp + real(${rk}$), parameter :: alphasq = 0.01_${rk}$ + real(${rk}$), parameter :: realone = 1.0_${rk}$ + real(${rk}$), parameter :: realzero = 0.0_${rk}$ ! Local Scalars integer(ilp) :: i - real(qp) :: normsq1, normsq2, scl1, scl2, ssq1, ssq2 + real(${rk}$) :: normsq1, normsq2, scl1, scl2, ssq1, ssq2 ! Intrinsic Function intrinsic :: max ! Executable Statements @@ -52427,27 +52428,27 @@ module stdlib_linalg_lapack_q ! space scl1 = realzero ssq1 = realone - call stdlib_qlassq( m1, x1, incx1, scl1, ssq1 ) + call stdlib_${ri}$lassq( m1, x1, incx1, scl1, ssq1 ) scl2 = realzero ssq2 = realone - call stdlib_qlassq( m2, x2, incx2, scl2, ssq2 ) + call stdlib_${ri}$lassq( m2, x2, incx2, scl2, ssq2 ) normsq1 = scl1**2*ssq1 + scl2**2*ssq2 if( m1 == 0 ) then do i = 1, n work(i) = zero end do else - call stdlib_qgemv( 'C', m1, n, one, q1, ldq1, x1, incx1, zero, work,1 ) + call stdlib_${ri}$gemv( 'C', m1, n, one, q1, ldq1, x1, incx1, zero, work,1 ) end if - call stdlib_qgemv( 'C', m2, n, one, q2, ldq2, x2, incx2, one, work, 1 ) - call stdlib_qgemv( 'N', m1, n, negone, q1, ldq1, work, 1, one, x1,incx1 ) - call stdlib_qgemv( 'N', m2, n, negone, q2, ldq2, work, 1, one, x2,incx2 ) + call stdlib_${ri}$gemv( 'C', m2, n, one, q2, ldq2, x2, incx2, one, work, 1 ) + call stdlib_${ri}$gemv( 'N', m1, n, negone, q1, ldq1, work, 1, one, x1,incx1 ) + call stdlib_${ri}$gemv( 'N', m2, n, negone, q2, ldq2, work, 1, one, x2,incx2 ) scl1 = realzero ssq1 = realone - call stdlib_qlassq( m1, x1, incx1, scl1, ssq1 ) + call stdlib_${ri}$lassq( m1, x1, incx1, scl1, ssq1 ) scl2 = realzero ssq2 = realone - call stdlib_qlassq( m2, x2, incx2, scl2, ssq2 ) + call stdlib_${ri}$lassq( m2, x2, incx2, scl2, ssq2 ) normsq2 = scl1**2*ssq1 + scl2**2*ssq2 ! if projection is sufficiently large in norm, then stop. ! if projection is zero, then stop. @@ -52467,17 +52468,17 @@ module stdlib_linalg_lapack_q work(i) = zero end do else - call stdlib_qgemv( 'C', m1, n, one, q1, ldq1, x1, incx1, zero, work,1 ) + call stdlib_${ri}$gemv( 'C', m1, n, one, q1, ldq1, x1, incx1, zero, work,1 ) end if - call stdlib_qgemv( 'C', m2, n, one, q2, ldq2, x2, incx2, one, work, 1 ) - call stdlib_qgemv( 'N', m1, n, negone, q1, ldq1, work, 1, one, x1,incx1 ) - call stdlib_qgemv( 'N', m2, n, negone, q2, ldq2, work, 1, one, x2,incx2 ) + call stdlib_${ri}$gemv( 'C', m2, n, one, q2, ldq2, x2, incx2, one, work, 1 ) + call stdlib_${ri}$gemv( 'N', m1, n, negone, q1, ldq1, work, 1, one, x1,incx1 ) + call stdlib_${ri}$gemv( 'N', m2, n, negone, q2, ldq2, work, 1, one, x2,incx2 ) scl1 = realzero ssq1 = realone - call stdlib_qlassq( m1, x1, incx1, scl1, ssq1 ) + call stdlib_${ri}$lassq( m1, x1, incx1, scl1, ssq1 ) scl2 = realzero ssq2 = realone - call stdlib_qlassq( m1, x1, incx1, scl1, ssq1 ) + call stdlib_${ri}$lassq( m1, x1, incx1, scl1, ssq1 ) normsq2 = scl1**2*ssq1 + scl2**2*ssq2 ! if second projection is sufficiently large in norm, then do ! nothing more. alternatively, if it shrunk significantly, then @@ -52491,10 +52492,10 @@ module stdlib_linalg_lapack_q end do end if return - end subroutine stdlib_qorbdb6 + end subroutine stdlib_${ri}$orbdb6 - recursive subroutine stdlib_qorcsd( jobu1, jobu2, jobv1t, jobv2t, trans,signs, m, p, q, x11, & + recursive subroutine stdlib_${ri}$orcsd( jobu1, jobu2, jobv1t, jobv2t, trans,signs, m, p, q, x11, & !! DORCSD: computes the CS decomposition of an M-by-M partitioned !! orthogonal matrix X: !! [ I 0 0 | 0 0 0 ] @@ -52520,10 +52521,10 @@ module stdlib_linalg_lapack_q lwork, m, p, q ! Array Arguments integer(ilp), intent(out) :: iwork(*) - real(qp), intent(out) :: theta(*) - real(qp), intent(out) :: u1(ldu1,*), u2(ldu2,*), v1t(ldv1t,*), v2t(ldv2t,*), work(*) + real(${rk}$), intent(out) :: theta(*) + real(${rk}$), intent(out) :: u1(ldu1,*), u2(ldu2,*), v1t(ldv1t,*), v2t(ldv2t,*), work(*) - real(qp), intent(inout) :: x11(ldx11,*), x12(ldx12,*), x21(ldx21,*), x22(ldx22,*) + real(${rk}$), intent(inout) :: x11(ldx11,*), x12(ldx12,*), x21(ldx21,*), x22(ldx22,*) ! =================================================================== @@ -52590,7 +52591,7 @@ module stdlib_linalg_lapack_q else signst = 'D' end if - call stdlib_qorcsd( jobv1t, jobv2t, jobu1, jobu2, transt, signst, m,q, p, x11, & + call stdlib_${ri}$orcsd( jobv1t, jobv2t, jobu1, jobu2, transt, signst, m,q, p, x11, & ldx11, x21, ldx21, x12, ldx12, x22,ldx22, theta, v1t, ldv1t, v2t, ldv2t, u1, ldu1,& u2, ldu2, work, lwork, iwork, info ) return @@ -52603,7 +52604,7 @@ module stdlib_linalg_lapack_q else signst = 'D' end if - call stdlib_qorcsd( jobu2, jobu1, jobv2t, jobv1t, trans, signst, m,m-p, m-q, x22, & + call stdlib_${ri}$orcsd( jobu2, jobu1, jobv2t, jobv1t, trans, signst, m,m-p, m-q, x22, & ldx22, x21, ldx21, x12, ldx12, x11,ldx11, theta, u2, ldu2, u1, ldu1, v2t, ldv2t, & v1t,ldv1t, work, lwork, iwork, info ) return @@ -52616,15 +52617,15 @@ module stdlib_linalg_lapack_q itauq1 = itaup2 + max( 1, m - p ) itauq2 = itauq1 + max( 1, q ) iorgqr = itauq2 + max( 1, m - q ) - call stdlib_qorgqr( m-q, m-q, m-q, u1, max(1,m-q), u1, work, -1,childinfo ) + call stdlib_${ri}$orgqr( m-q, m-q, m-q, u1, max(1,m-q), u1, work, -1,childinfo ) lorgqrworkopt = int( work(1),KIND=ilp) lorgqrworkmin = max( 1, m - q ) iorglq = itauq2 + max( 1, m - q ) - call stdlib_qorglq( m-q, m-q, m-q, u1, max(1,m-q), u1, work, -1,childinfo ) + call stdlib_${ri}$orglq( m-q, m-q, m-q, u1, max(1,m-q), u1, work, -1,childinfo ) lorglqworkopt = int( work(1),KIND=ilp) lorglqworkmin = max( 1, m - q ) iorbdb = itauq2 + max( 1, m - q ) - call stdlib_qorbdb( trans, signs, m, p, q, x11, ldx11, x12, ldx12,x21, ldx21, x22, & + call stdlib_${ri}$orbdb( trans, signs, m, p, q, x11, ldx11, x12, ldx12,x21, ldx21, x22, & ldx22, theta, v1t, u1, u2, v1t,v2t, work, -1, childinfo ) lorbdbworkopt = int( work(1),KIND=ilp) lorbdbworkmin = lorbdbworkopt @@ -52637,7 +52638,7 @@ module stdlib_linalg_lapack_q ib22d = ib21e + max( 1, q - 1 ) ib22e = ib22d + max( 1, q ) ibbcsd = ib22e + max( 1, q - 1 ) - call stdlib_qbbcsd( jobu1, jobu2, jobv1t, jobv2t, trans, m, p, q,theta, theta, u1, & + call stdlib_${ri}$bbcsd( jobu1, jobu2, jobv1t, jobv2t, trans, m, p, q,theta, theta, u1, & ldu1, u2, ldu2, v1t, ldv1t, v2t,ldv2t, u1, u1, u1, u1, u1, u1, u1, u1, work, -1,& childinfo ) lbbcsdworkopt = int( work(1),KIND=ilp) @@ -52664,73 +52665,73 @@ module stdlib_linalg_lapack_q return end if ! transform to bidiagonal block form - call stdlib_qorbdb( trans, signs, m, p, q, x11, ldx11, x12, ldx12, x21,ldx21, x22, & + call stdlib_${ri}$orbdb( trans, signs, m, p, q, x11, ldx11, x12, ldx12, x21,ldx21, x22, & ldx22, theta, work(iphi), work(itaup1),work(itaup2), work(itauq1), work(itauq2),work(& iorbdb), lorbdbwork, childinfo ) ! accumulate householder reflectors if( colmajor ) then if( wantu1 .and. p > 0 ) then - call stdlib_qlacpy( 'L', p, q, x11, ldx11, u1, ldu1 ) - call stdlib_qorgqr( p, p, q, u1, ldu1, work(itaup1), work(iorgqr),lorgqrwork, & + call stdlib_${ri}$lacpy( 'L', p, q, x11, ldx11, u1, ldu1 ) + call stdlib_${ri}$orgqr( p, p, q, u1, ldu1, work(itaup1), work(iorgqr),lorgqrwork, & info) end if if( wantu2 .and. m-p > 0 ) then - call stdlib_qlacpy( 'L', m-p, q, x21, ldx21, u2, ldu2 ) - call stdlib_qorgqr( m-p, m-p, q, u2, ldu2, work(itaup2),work(iorgqr), lorgqrwork,& + call stdlib_${ri}$lacpy( 'L', m-p, q, x21, ldx21, u2, ldu2 ) + call stdlib_${ri}$orgqr( m-p, m-p, q, u2, ldu2, work(itaup2),work(iorgqr), lorgqrwork,& info ) end if if( wantv1t .and. q > 0 ) then - call stdlib_qlacpy( 'U', q-1, q-1, x11(1,2), ldx11, v1t(2,2),ldv1t ) + call stdlib_${ri}$lacpy( 'U', q-1, q-1, x11(1,2), ldx11, v1t(2,2),ldv1t ) v1t(1, 1) = one do j = 2, q v1t(1,j) = zero v1t(j,1) = zero end do - call stdlib_qorglq( q-1, q-1, q-1, v1t(2,2), ldv1t, work(itauq1),work(iorglq), & + call stdlib_${ri}$orglq( q-1, q-1, q-1, v1t(2,2), ldv1t, work(itauq1),work(iorglq), & lorglqwork, info ) end if if( wantv2t .and. m-q > 0 ) then - call stdlib_qlacpy( 'U', p, m-q, x12, ldx12, v2t, ldv2t ) + call stdlib_${ri}$lacpy( 'U', p, m-q, x12, ldx12, v2t, ldv2t ) if (m-p > q) then - call stdlib_qlacpy( 'U', m-p-q, m-p-q, x22(q+1,p+1), ldx22,v2t(p+1,p+1), & + call stdlib_${ri}$lacpy( 'U', m-p-q, m-p-q, x22(q+1,p+1), ldx22,v2t(p+1,p+1), & ldv2t ) end if if (m > q) then - call stdlib_qorglq( m-q, m-q, m-q, v2t, ldv2t, work(itauq2),work(iorglq), & + call stdlib_${ri}$orglq( m-q, m-q, m-q, v2t, ldv2t, work(itauq2),work(iorglq), & lorglqwork, info ) end if end if else if( wantu1 .and. p > 0 ) then - call stdlib_qlacpy( 'U', q, p, x11, ldx11, u1, ldu1 ) - call stdlib_qorglq( p, p, q, u1, ldu1, work(itaup1), work(iorglq),lorglqwork, & + call stdlib_${ri}$lacpy( 'U', q, p, x11, ldx11, u1, ldu1 ) + call stdlib_${ri}$orglq( p, p, q, u1, ldu1, work(itaup1), work(iorglq),lorglqwork, & info) end if if( wantu2 .and. m-p > 0 ) then - call stdlib_qlacpy( 'U', q, m-p, x21, ldx21, u2, ldu2 ) - call stdlib_qorglq( m-p, m-p, q, u2, ldu2, work(itaup2),work(iorglq), lorglqwork,& + call stdlib_${ri}$lacpy( 'U', q, m-p, x21, ldx21, u2, ldu2 ) + call stdlib_${ri}$orglq( m-p, m-p, q, u2, ldu2, work(itaup2),work(iorglq), lorglqwork,& info ) end if if( wantv1t .and. q > 0 ) then - call stdlib_qlacpy( 'L', q-1, q-1, x11(2,1), ldx11, v1t(2,2),ldv1t ) + call stdlib_${ri}$lacpy( 'L', q-1, q-1, x11(2,1), ldx11, v1t(2,2),ldv1t ) v1t(1, 1) = one do j = 2, q v1t(1,j) = zero v1t(j,1) = zero end do - call stdlib_qorgqr( q-1, q-1, q-1, v1t(2,2), ldv1t, work(itauq1),work(iorgqr), & + call stdlib_${ri}$orgqr( q-1, q-1, q-1, v1t(2,2), ldv1t, work(itauq1),work(iorgqr), & lorgqrwork, info ) end if if( wantv2t .and. m-q > 0 ) then - call stdlib_qlacpy( 'L', m-q, p, x12, ldx12, v2t, ldv2t ) - call stdlib_qlacpy( 'L', m-p-q, m-p-q, x22(p+1,q+1), ldx22,v2t(p+1,p+1), ldv2t ) + call stdlib_${ri}$lacpy( 'L', m-q, p, x12, ldx12, v2t, ldv2t ) + call stdlib_${ri}$lacpy( 'L', m-p-q, m-p-q, x22(p+1,q+1), ldx22,v2t(p+1,p+1), ldv2t ) - call stdlib_qorgqr( m-q, m-q, m-q, v2t, ldv2t, work(itauq2),work(iorgqr), & + call stdlib_${ri}$orgqr( m-q, m-q, m-q, v2t, ldv2t, work(itauq2),work(iorgqr), & lorgqrwork, info ) end if end if ! compute the csd of the matrix in bidiagonal-block form - call stdlib_qbbcsd( jobu1, jobu2, jobv1t, jobv2t, trans, m, p, q, theta,work(iphi), u1,& + call stdlib_${ri}$bbcsd( jobu1, jobu2, jobv1t, jobv2t, trans, m, p, q, theta,work(iphi), u1,& ldu1, u2, ldu2, v1t, ldv1t, v2t,ldv2t, work(ib11d), work(ib11e), work(ib12d),work(& ib12e), work(ib21d), work(ib21e), work(ib22d),work(ib22e), work(ibbcsd), lbbcsdwork, & info ) @@ -52746,9 +52747,9 @@ module stdlib_linalg_lapack_q iwork(i) = i - q end do if( colmajor ) then - call stdlib_qlapmt( .false., m-p, m-p, u2, ldu2, iwork ) + call stdlib_${ri}$lapmt( .false., m-p, m-p, u2, ldu2, iwork ) else - call stdlib_qlapmr( .false., m-p, m-p, u2, ldu2, iwork ) + call stdlib_${ri}$lapmr( .false., m-p, m-p, u2, ldu2, iwork ) end if end if if( m > 0 .and. wantv2t ) then @@ -52759,17 +52760,17 @@ module stdlib_linalg_lapack_q iwork(i) = i - p end do if( .not. colmajor ) then - call stdlib_qlapmt( .false., m-q, m-q, v2t, ldv2t, iwork ) + call stdlib_${ri}$lapmt( .false., m-q, m-q, v2t, ldv2t, iwork ) else - call stdlib_qlapmr( .false., m-q, m-q, v2t, ldv2t, iwork ) + call stdlib_${ri}$lapmr( .false., m-q, m-q, v2t, ldv2t, iwork ) end if end if return - ! end stdlib_qorcsd - end subroutine stdlib_qorcsd + ! end stdlib_${ri}$orcsd + end subroutine stdlib_${ri}$orcsd - subroutine stdlib_qorcsd2by1( jobu1, jobu2, jobv1t, m, p, q, x11, ldx11,x21, ldx21, theta, & + subroutine stdlib_${ri}$orcsd2by1( jobu1, jobu2, jobv1t, m, p, q, x11, ldx11,x21, ldx21, theta, & !! DORCSD2BY1: computes the CS decomposition of an M-by-Q matrix X with !! orthonormal columns that has been partitioned into a 2-by-1 block !! structure: @@ -52786,7 +52787,7 @@ module stdlib_linalg_lapack_q !! R = MIN(P,M-P,Q,M-Q). I1 is a K1-by-K1 identity matrix and I2 is a !! K2-by-K2 identity matrix, where K1 = MAX(Q+P-M,0), K2 = MAX(Q-P,0). u1, ldu1, u2, ldu2, v1t,ldv1t, work, lwork, iwork, info ) - ! -- lapack computational routine (3.5.0_qp) -- + ! -- lapack computational routine (3.5.0_${rk}$) -- ! -- lapack is a software package provided by univ. of tennessee, -- ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments @@ -52794,9 +52795,9 @@ module stdlib_linalg_lapack_q integer(ilp), intent(out) :: info integer(ilp), intent(in) :: ldu1, ldu2, ldv1t, lwork, ldx11, ldx21, m, p, q ! Array Arguments - real(qp), intent(out) :: theta(*) - real(qp), intent(out) :: u1(ldu1,*), u2(ldu2,*), v1t(ldv1t,*), work(*) - real(qp), intent(inout) :: x11(ldx11,*), x21(ldx21,*) + real(${rk}$), intent(out) :: theta(*) + real(${rk}$), intent(out) :: u1(ldu1,*), u2(ldu2,*), v1t(ldv1t,*), work(*) + real(${rk}$), intent(inout) :: x11(ldx11,*), x21(ldx21,*) integer(ilp), intent(out) :: iwork(*) ! ===================================================================== @@ -52807,7 +52808,7 @@ module stdlib_linalg_lapack_q r logical(lk) :: lquery, wantu1, wantu2, wantv1t ! Local Arrays - real(qp) :: dum1(1), dum2(1,1) + real(${rk}$) :: dum1(1), dum2(1,1) ! Intrinsic Function intrinsic :: int,max,min ! Executable Statements @@ -52846,11 +52847,11 @@ module stdlib_linalg_lapack_q ! | taup2 (max(1,m-p)) | b11e (r-1) | ! | tauq1 (max(1,q)) | b12d (r) | ! |-----------------------------------------| b12e (r-1) | - ! | stdlib_qorbdb work | stdlib_qorgqr work | stdlib_qorglq work | b21d (r) | + ! | stdlib_${ri}$orbdb work | stdlib_${ri}$orgqr work | stdlib_${ri}$orglq work | b21d (r) | ! | | | | b21e (r-1) | ! | | | | b22d (r) | ! | | | | b22e (r-1) | - ! | | | | stdlib_qbbcsd work | + ! | | | | stdlib_${ri}$bbcsd work | ! |-------------------------------------------------------| if( info == 0 ) then iphi = 2 @@ -52874,100 +52875,100 @@ module stdlib_linalg_lapack_q lorglqmin = 1 lorglqopt = 1 if( r == q ) then - call stdlib_qorbdb1( m, p, q, x11, ldx11, x21, ldx21, theta,dum1, dum1, dum1, & + call stdlib_${ri}$orbdb1( m, p, q, x11, ldx11, x21, ldx21, theta,dum1, dum1, dum1, & dum1, work,-1, childinfo ) lorbdb = int( work(1),KIND=ilp) if( wantu1 .and. p > 0 ) then - call stdlib_qorgqr( p, p, q, u1, ldu1, dum1, work(1), -1,childinfo ) + call stdlib_${ri}$orgqr( p, p, q, u1, ldu1, dum1, work(1), -1,childinfo ) lorgqrmin = max( lorgqrmin, p ) lorgqropt = max( lorgqropt, int( work(1),KIND=ilp) ) endif if( wantu2 .and. m-p > 0 ) then - call stdlib_qorgqr( m-p, m-p, q, u2, ldu2, dum1, work(1),-1, childinfo ) + call stdlib_${ri}$orgqr( m-p, m-p, q, u2, ldu2, dum1, work(1),-1, childinfo ) lorgqrmin = max( lorgqrmin, m-p ) lorgqropt = max( lorgqropt, int( work(1),KIND=ilp) ) end if if( wantv1t .and. q > 0 ) then - call stdlib_qorglq( q-1, q-1, q-1, v1t, ldv1t,dum1, work(1), -1, childinfo ) + call stdlib_${ri}$orglq( q-1, q-1, q-1, v1t, ldv1t,dum1, work(1), -1, childinfo ) lorglqmin = max( lorglqmin, q-1 ) lorglqopt = max( lorglqopt, int( work(1),KIND=ilp) ) end if - call stdlib_qbbcsd( jobu1, jobu2, jobv1t, 'N', 'N', m, p, q, theta,dum1, u1, & + call stdlib_${ri}$bbcsd( jobu1, jobu2, jobv1t, 'N', 'N', m, p, q, theta,dum1, u1, & ldu1, u2, ldu2, v1t, ldv1t,dum2, 1, dum1, dum1, dum1,dum1, dum1, dum1, dum1,dum1,& work(1), -1, childinfo ) lbbcsd = int( work(1),KIND=ilp) else if( r == p ) then - call stdlib_qorbdb2( m, p, q, x11, ldx11, x21, ldx21, theta,dum1, dum1, dum1, & + call stdlib_${ri}$orbdb2( m, p, q, x11, ldx11, x21, ldx21, theta,dum1, dum1, dum1, & dum1,work(1), -1, childinfo ) lorbdb = int( work(1),KIND=ilp) if( wantu1 .and. p > 0 ) then - call stdlib_qorgqr( p-1, p-1, p-1, u1(2,2), ldu1, dum1,work(1), -1, childinfo & + call stdlib_${ri}$orgqr( p-1, p-1, p-1, u1(2,2), ldu1, dum1,work(1), -1, childinfo & ) lorgqrmin = max( lorgqrmin, p-1 ) lorgqropt = max( lorgqropt, int( work(1),KIND=ilp) ) end if if( wantu2 .and. m-p > 0 ) then - call stdlib_qorgqr( m-p, m-p, q, u2, ldu2, dum1, work(1),-1, childinfo ) + call stdlib_${ri}$orgqr( m-p, m-p, q, u2, ldu2, dum1, work(1),-1, childinfo ) lorgqrmin = max( lorgqrmin, m-p ) lorgqropt = max( lorgqropt, int( work(1),KIND=ilp) ) end if if( wantv1t .and. q > 0 ) then - call stdlib_qorglq( q, q, r, v1t, ldv1t, dum1, work(1), -1,childinfo ) + call stdlib_${ri}$orglq( q, q, r, v1t, ldv1t, dum1, work(1), -1,childinfo ) lorglqmin = max( lorglqmin, q ) lorglqopt = max( lorglqopt, int( work(1),KIND=ilp) ) end if - call stdlib_qbbcsd( jobv1t, 'N', jobu1, jobu2, 'T', m, q, p, theta,dum1, v1t, & + call stdlib_${ri}$bbcsd( jobv1t, 'N', jobu1, jobu2, 'T', m, q, p, theta,dum1, v1t, & ldv1t, dum2, 1, u1, ldu1,u2, ldu2, dum1, dum1, dum1,dum1, dum1, dum1, dum1,dum1, & work(1), -1, childinfo ) lbbcsd = int( work(1),KIND=ilp) else if( r == m-p ) then - call stdlib_qorbdb3( m, p, q, x11, ldx11, x21, ldx21, theta,dum1, dum1, dum1, & + call stdlib_${ri}$orbdb3( m, p, q, x11, ldx11, x21, ldx21, theta,dum1, dum1, dum1, & dum1,work(1), -1, childinfo ) lorbdb = int( work(1),KIND=ilp) if( wantu1 .and. p > 0 ) then - call stdlib_qorgqr( p, p, q, u1, ldu1, dum1, work(1), -1,childinfo ) + call stdlib_${ri}$orgqr( p, p, q, u1, ldu1, dum1, work(1), -1,childinfo ) lorgqrmin = max( lorgqrmin, p ) lorgqropt = max( lorgqropt, int( work(1),KIND=ilp) ) end if if( wantu2 .and. m-p > 0 ) then - call stdlib_qorgqr( m-p-1, m-p-1, m-p-1, u2(2,2), ldu2,dum1, work(1), -1, & + call stdlib_${ri}$orgqr( m-p-1, m-p-1, m-p-1, u2(2,2), ldu2,dum1, work(1), -1, & childinfo ) lorgqrmin = max( lorgqrmin, m-p-1 ) lorgqropt = max( lorgqropt, int( work(1),KIND=ilp) ) end if if( wantv1t .and. q > 0 ) then - call stdlib_qorglq( q, q, r, v1t, ldv1t, dum1, work(1), -1,childinfo ) + call stdlib_${ri}$orglq( q, q, r, v1t, ldv1t, dum1, work(1), -1,childinfo ) lorglqmin = max( lorglqmin, q ) lorglqopt = max( lorglqopt, int( work(1),KIND=ilp) ) end if - call stdlib_qbbcsd( 'N', jobv1t, jobu2, jobu1, 'T', m, m-q, m-p,theta, dum1, & + call stdlib_${ri}$bbcsd( 'N', jobv1t, jobu2, jobu1, 'T', m, m-q, m-p,theta, dum1, & dum2, 1, v1t, ldv1t, u2,ldu2, u1, ldu1, dum1, dum1, dum1,dum1, dum1, dum1, dum1,& dum1, work(1), -1, childinfo ) lbbcsd = int( work(1),KIND=ilp) else - call stdlib_qorbdb4( m, p, q, x11, ldx11, x21, ldx21, theta,dum1, dum1, dum1, & + call stdlib_${ri}$orbdb4( m, p, q, x11, ldx11, x21, ldx21, theta,dum1, dum1, dum1, & dum1,dum1, work(1), -1, childinfo ) lorbdb = m + int( work(1),KIND=ilp) if( wantu1 .and. p > 0 ) then - call stdlib_qorgqr( p, p, m-q, u1, ldu1, dum1, work(1), -1,childinfo ) + call stdlib_${ri}$orgqr( p, p, m-q, u1, ldu1, dum1, work(1), -1,childinfo ) lorgqrmin = max( lorgqrmin, p ) lorgqropt = max( lorgqropt, int( work(1),KIND=ilp) ) end if if( wantu2 .and. m-p > 0 ) then - call stdlib_qorgqr( m-p, m-p, m-q, u2, ldu2, dum1, work(1),-1, childinfo ) + call stdlib_${ri}$orgqr( m-p, m-p, m-q, u2, ldu2, dum1, work(1),-1, childinfo ) lorgqrmin = max( lorgqrmin, m-p ) lorgqropt = max( lorgqropt, int( work(1),KIND=ilp) ) end if if( wantv1t .and. q > 0 ) then - call stdlib_qorglq( q, q, q, v1t, ldv1t, dum1, work(1), -1,childinfo ) + call stdlib_${ri}$orglq( q, q, q, v1t, ldv1t, dum1, work(1), -1,childinfo ) lorglqmin = max( lorglqmin, q ) lorglqopt = max( lorglqopt, int( work(1),KIND=ilp) ) end if - call stdlib_qbbcsd( jobu2, jobu1, 'N', jobv1t, 'N', m, m-p, m-q,theta, dum1, u2, & + call stdlib_${ri}$bbcsd( jobu2, jobu1, 'N', jobv1t, 'N', m, m-p, m-q,theta, dum1, u2, & ldu2, u1, ldu1, dum2,1, v1t, ldv1t, dum1, dum1, dum1,dum1, dum1, dum1, dum1,dum1,& work(1), -1, childinfo ) lbbcsd = int( work(1),KIND=ilp) @@ -52994,17 +52995,17 @@ module stdlib_linalg_lapack_q if( r == q ) then ! case 1: r = q ! simultaneously bidiagonalize x11 and x21 - call stdlib_qorbdb1( m, p, q, x11, ldx11, x21, ldx21, theta,work(iphi), work(itaup1)& + call stdlib_${ri}$orbdb1( m, p, q, x11, ldx11, x21, ldx21, theta,work(iphi), work(itaup1)& , work(itaup2),work(itauq1), work(iorbdb), lorbdb, childinfo ) ! accumulate householder reflectors if( wantu1 .and. p > 0 ) then - call stdlib_qlacpy( 'L', p, q, x11, ldx11, u1, ldu1 ) - call stdlib_qorgqr( p, p, q, u1, ldu1, work(itaup1), work(iorgqr),lorgqr, & + call stdlib_${ri}$lacpy( 'L', p, q, x11, ldx11, u1, ldu1 ) + call stdlib_${ri}$orgqr( p, p, q, u1, ldu1, work(itaup1), work(iorgqr),lorgqr, & childinfo ) end if if( wantu2 .and. m-p > 0 ) then - call stdlib_qlacpy( 'L', m-p, q, x21, ldx21, u2, ldu2 ) - call stdlib_qorgqr( m-p, m-p, q, u2, ldu2, work(itaup2),work(iorgqr), lorgqr, & + call stdlib_${ri}$lacpy( 'L', m-p, q, x21, ldx21, u2, ldu2 ) + call stdlib_${ri}$orgqr( m-p, m-p, q, u2, ldu2, work(itaup2),work(iorgqr), lorgqr, & childinfo ) end if if( wantv1t .and. q > 0 ) then @@ -53013,12 +53014,12 @@ module stdlib_linalg_lapack_q v1t(1,j) = zero v1t(j,1) = zero end do - call stdlib_qlacpy( 'U', q-1, q-1, x21(1,2), ldx21, v1t(2,2),ldv1t ) - call stdlib_qorglq( q-1, q-1, q-1, v1t(2,2), ldv1t, work(itauq1),work(iorglq), & + call stdlib_${ri}$lacpy( 'U', q-1, q-1, x21(1,2), ldx21, v1t(2,2),ldv1t ) + call stdlib_${ri}$orglq( q-1, q-1, q-1, v1t(2,2), ldv1t, work(itauq1),work(iorglq), & lorglq, childinfo ) end if ! simultaneously diagonalize x11 and x21. - call stdlib_qbbcsd( jobu1, jobu2, jobv1t, 'N', 'N', m, p, q, theta,work(iphi), u1, & + call stdlib_${ri}$bbcsd( jobu1, jobu2, jobv1t, 'N', 'N', m, p, q, theta,work(iphi), u1, & ldu1, u2, ldu2, v1t, ldv1t,dum2, 1, work(ib11d), work(ib11e),work(ib12d), work(& ib12e), work(ib21d),work(ib21e), work(ib22d), work(ib22e),work(ibbcsd), lbbcsd, & childinfo ) @@ -53031,12 +53032,12 @@ module stdlib_linalg_lapack_q do i = q + 1, m - p iwork(i) = i - q end do - call stdlib_qlapmt( .false., m-p, m-p, u2, ldu2, iwork ) + call stdlib_${ri}$lapmt( .false., m-p, m-p, u2, ldu2, iwork ) end if else if( r == p ) then ! case 2: r = p ! simultaneously bidiagonalize x11 and x21 - call stdlib_qorbdb2( m, p, q, x11, ldx11, x21, ldx21, theta,work(iphi), work(itaup1)& + call stdlib_${ri}$orbdb2( m, p, q, x11, ldx11, x21, ldx21, theta,work(iphi), work(itaup1)& , work(itaup2),work(itauq1), work(iorbdb), lorbdb, childinfo ) ! accumulate householder reflectors if( wantu1 .and. p > 0 ) then @@ -53045,22 +53046,22 @@ module stdlib_linalg_lapack_q u1(1,j) = zero u1(j,1) = zero end do - call stdlib_qlacpy( 'L', p-1, p-1, x11(2,1), ldx11, u1(2,2), ldu1 ) - call stdlib_qorgqr( p-1, p-1, p-1, u1(2,2), ldu1, work(itaup1),work(iorgqr), & + call stdlib_${ri}$lacpy( 'L', p-1, p-1, x11(2,1), ldx11, u1(2,2), ldu1 ) + call stdlib_${ri}$orgqr( p-1, p-1, p-1, u1(2,2), ldu1, work(itaup1),work(iorgqr), & lorgqr, childinfo ) end if if( wantu2 .and. m-p > 0 ) then - call stdlib_qlacpy( 'L', m-p, q, x21, ldx21, u2, ldu2 ) - call stdlib_qorgqr( m-p, m-p, q, u2, ldu2, work(itaup2),work(iorgqr), lorgqr, & + call stdlib_${ri}$lacpy( 'L', m-p, q, x21, ldx21, u2, ldu2 ) + call stdlib_${ri}$orgqr( m-p, m-p, q, u2, ldu2, work(itaup2),work(iorgqr), lorgqr, & childinfo ) end if if( wantv1t .and. q > 0 ) then - call stdlib_qlacpy( 'U', p, q, x11, ldx11, v1t, ldv1t ) - call stdlib_qorglq( q, q, r, v1t, ldv1t, work(itauq1),work(iorglq), lorglq, & + call stdlib_${ri}$lacpy( 'U', p, q, x11, ldx11, v1t, ldv1t ) + call stdlib_${ri}$orglq( q, q, r, v1t, ldv1t, work(itauq1),work(iorglq), lorglq, & childinfo ) end if ! simultaneously diagonalize x11 and x21. - call stdlib_qbbcsd( jobv1t, 'N', jobu1, jobu2, 'T', m, q, p, theta,work(iphi), v1t, & + call stdlib_${ri}$bbcsd( jobv1t, 'N', jobu1, jobu2, 'T', m, q, p, theta,work(iphi), v1t, & ldv1t, dum2, 1, u1, ldu1, u2,ldu2, work(ib11d), work(ib11e), work(ib12d),work(ib12e)& , work(ib21d), work(ib21e),work(ib22d), work(ib22e), work(ibbcsd), lbbcsd,childinfo & ) @@ -53073,17 +53074,17 @@ module stdlib_linalg_lapack_q do i = q + 1, m - p iwork(i) = i - q end do - call stdlib_qlapmt( .false., m-p, m-p, u2, ldu2, iwork ) + call stdlib_${ri}$lapmt( .false., m-p, m-p, u2, ldu2, iwork ) end if else if( r == m-p ) then ! case 3: r = m-p ! simultaneously bidiagonalize x11 and x21 - call stdlib_qorbdb3( m, p, q, x11, ldx11, x21, ldx21, theta,work(iphi), work(itaup1)& + call stdlib_${ri}$orbdb3( m, p, q, x11, ldx11, x21, ldx21, theta,work(iphi), work(itaup1)& , work(itaup2),work(itauq1), work(iorbdb), lorbdb, childinfo ) ! accumulate householder reflectors if( wantu1 .and. p > 0 ) then - call stdlib_qlacpy( 'L', p, q, x11, ldx11, u1, ldu1 ) - call stdlib_qorgqr( p, p, q, u1, ldu1, work(itaup1), work(iorgqr),lorgqr, & + call stdlib_${ri}$lacpy( 'L', p, q, x11, ldx11, u1, ldu1 ) + call stdlib_${ri}$orgqr( p, p, q, u1, ldu1, work(itaup1), work(iorgqr),lorgqr, & childinfo ) end if if( wantu2 .and. m-p > 0 ) then @@ -53092,17 +53093,17 @@ module stdlib_linalg_lapack_q u2(1,j) = zero u2(j,1) = zero end do - call stdlib_qlacpy( 'L', m-p-1, m-p-1, x21(2,1), ldx21, u2(2,2),ldu2 ) - call stdlib_qorgqr( m-p-1, m-p-1, m-p-1, u2(2,2), ldu2,work(itaup2), work(iorgqr)& + call stdlib_${ri}$lacpy( 'L', m-p-1, m-p-1, x21(2,1), ldx21, u2(2,2),ldu2 ) + call stdlib_${ri}$orgqr( m-p-1, m-p-1, m-p-1, u2(2,2), ldu2,work(itaup2), work(iorgqr)& , lorgqr, childinfo ) end if if( wantv1t .and. q > 0 ) then - call stdlib_qlacpy( 'U', m-p, q, x21, ldx21, v1t, ldv1t ) - call stdlib_qorglq( q, q, r, v1t, ldv1t, work(itauq1),work(iorglq), lorglq, & + call stdlib_${ri}$lacpy( 'U', m-p, q, x21, ldx21, v1t, ldv1t ) + call stdlib_${ri}$orglq( q, q, r, v1t, ldv1t, work(itauq1),work(iorglq), lorglq, & childinfo ) end if ! simultaneously diagonalize x11 and x21. - call stdlib_qbbcsd( 'N', jobv1t, jobu2, jobu1, 'T', m, m-q, m-p,theta, work(iphi), & + call stdlib_${ri}$bbcsd( 'N', jobv1t, jobu2, jobu1, 'T', m, m-q, m-p,theta, work(iphi), & dum2, 1, v1t, ldv1t, u2,ldu2, u1, ldu1, work(ib11d), work(ib11e),work(ib12d), work(& ib12e), work(ib21d),work(ib21e), work(ib22d), work(ib22e),work(ibbcsd), lbbcsd, & childinfo ) @@ -53116,50 +53117,50 @@ module stdlib_linalg_lapack_q iwork(i) = i - r end do if( wantu1 ) then - call stdlib_qlapmt( .false., p, q, u1, ldu1, iwork ) + call stdlib_${ri}$lapmt( .false., p, q, u1, ldu1, iwork ) end if if( wantv1t ) then - call stdlib_qlapmr( .false., q, q, v1t, ldv1t, iwork ) + call stdlib_${ri}$lapmr( .false., q, q, v1t, ldv1t, iwork ) end if end if else ! case 4: r = m-q ! simultaneously bidiagonalize x11 and x21 - call stdlib_qorbdb4( m, p, q, x11, ldx11, x21, ldx21, theta,work(iphi), work(itaup1)& + call stdlib_${ri}$orbdb4( m, p, q, x11, ldx11, x21, ldx21, theta,work(iphi), work(itaup1)& , work(itaup2),work(itauq1), work(iorbdb), work(iorbdb+m),lorbdb-m, childinfo ) ! accumulate householder reflectors if( wantu2 .and. m-p > 0 ) then - call stdlib_qcopy( m-p, work(iorbdb+p), 1, u2, 1 ) + call stdlib_${ri}$copy( m-p, work(iorbdb+p), 1, u2, 1 ) end if if( wantu1 .and. p > 0 ) then - call stdlib_qcopy( p, work(iorbdb), 1, u1, 1 ) + call stdlib_${ri}$copy( p, work(iorbdb), 1, u1, 1 ) do j = 2, p u1(1,j) = zero end do - call stdlib_qlacpy( 'L', p-1, m-q-1, x11(2,1), ldx11, u1(2,2),ldu1 ) - call stdlib_qorgqr( p, p, m-q, u1, ldu1, work(itaup1),work(iorgqr), lorgqr, & + call stdlib_${ri}$lacpy( 'L', p-1, m-q-1, x11(2,1), ldx11, u1(2,2),ldu1 ) + call stdlib_${ri}$orgqr( p, p, m-q, u1, ldu1, work(itaup1),work(iorgqr), lorgqr, & childinfo ) end if if( wantu2 .and. m-p > 0 ) then do j = 2, m-p u2(1,j) = zero end do - call stdlib_qlacpy( 'L', m-p-1, m-q-1, x21(2,1), ldx21, u2(2,2),ldu2 ) - call stdlib_qorgqr( m-p, m-p, m-q, u2, ldu2, work(itaup2),work(iorgqr), lorgqr, & + call stdlib_${ri}$lacpy( 'L', m-p-1, m-q-1, x21(2,1), ldx21, u2(2,2),ldu2 ) + call stdlib_${ri}$orgqr( m-p, m-p, m-q, u2, ldu2, work(itaup2),work(iorgqr), lorgqr, & childinfo ) end if if( wantv1t .and. q > 0 ) then - call stdlib_qlacpy( 'U', m-q, q, x21, ldx21, v1t, ldv1t ) - call stdlib_qlacpy( 'U', p-(m-q), q-(m-q), x11(m-q+1,m-q+1), ldx11,v1t(m-q+1,m-q+& + call stdlib_${ri}$lacpy( 'U', m-q, q, x21, ldx21, v1t, ldv1t ) + call stdlib_${ri}$lacpy( 'U', p-(m-q), q-(m-q), x11(m-q+1,m-q+1), ldx11,v1t(m-q+1,m-q+& 1), ldv1t ) - call stdlib_qlacpy( 'U', -p+q, q-p, x21(m-q+1,p+1), ldx21,v1t(p+1,p+1), ldv1t ) + call stdlib_${ri}$lacpy( 'U', -p+q, q-p, x21(m-q+1,p+1), ldx21,v1t(p+1,p+1), ldv1t ) - call stdlib_qorglq( q, q, q, v1t, ldv1t, work(itauq1),work(iorglq), lorglq, & + call stdlib_${ri}$orglq( q, q, q, v1t, ldv1t, work(itauq1),work(iorglq), lorglq, & childinfo ) end if ! simultaneously diagonalize x11 and x21. - call stdlib_qbbcsd( jobu2, jobu1, 'N', jobv1t, 'N', m, m-p, m-q,theta, work(iphi), & + call stdlib_${ri}$bbcsd( jobu2, jobu1, 'N', jobv1t, 'N', m, m-p, m-q,theta, work(iphi), & u2, ldu2, u1, ldu1, dum2,1, v1t, ldv1t, work(ib11d), work(ib11e),work(ib12d), work(& ib12e), work(ib21d),work(ib21e), work(ib22d), work(ib22e),work(ibbcsd), lbbcsd, & childinfo ) @@ -53173,18 +53174,18 @@ module stdlib_linalg_lapack_q iwork(i) = i - r end do if( wantu1 ) then - call stdlib_qlapmt( .false., p, p, u1, ldu1, iwork ) + call stdlib_${ri}$lapmt( .false., p, p, u1, ldu1, iwork ) end if if( wantv1t ) then - call stdlib_qlapmr( .false., p, q, v1t, ldv1t, iwork ) + call stdlib_${ri}$lapmr( .false., p, q, v1t, ldv1t, iwork ) end if end if end if return - end subroutine stdlib_qorcsd2by1 + end subroutine stdlib_${ri}$orcsd2by1 - pure subroutine stdlib_qorg2l( m, n, k, a, lda, tau, work, info ) + pure subroutine stdlib_${ri}$org2l( m, n, k, a, lda, tau, work, info ) !! DORG2L: generates an m by n real matrix Q with orthonormal columns, !! which is defined as the last n columns of a product of k elementary !! reflectors of order m @@ -53197,9 +53198,9 @@ module stdlib_linalg_lapack_q integer(ilp), intent(out) :: info integer(ilp), intent(in) :: k, lda, m, n ! Array Arguments - real(qp), intent(inout) :: a(lda,*) - real(qp), intent(in) :: tau(*) - real(qp), intent(out) :: work(*) + real(${rk}$), intent(inout) :: a(lda,*) + real(${rk}$), intent(in) :: tau(*) + real(${rk}$), intent(out) :: work(*) ! ===================================================================== ! Local Scalars @@ -53235,9 +53236,9 @@ module stdlib_linalg_lapack_q ii = n - k + i ! apply h(i) to a(1:m-k+i,1:n-k+i) from the left a( m-n+ii, ii ) = one - call stdlib_qlarf( 'LEFT', m-n+ii, ii-1, a( 1, ii ), 1, tau( i ), a,lda, work ) + call stdlib_${ri}$larf( 'LEFT', m-n+ii, ii-1, a( 1, ii ), 1, tau( i ), a,lda, work ) - call stdlib_qscal( m-n+ii-1, -tau( i ), a( 1, ii ), 1 ) + call stdlib_${ri}$scal( m-n+ii-1, -tau( i ), a( 1, ii ), 1 ) a( m-n+ii, ii ) = one - tau( i ) ! set a(m-k+i+1:m,n-k+i) to zero do l = m - n + ii + 1, m @@ -53245,10 +53246,10 @@ module stdlib_linalg_lapack_q end do end do return - end subroutine stdlib_qorg2l + end subroutine stdlib_${ri}$org2l - pure subroutine stdlib_qorg2r( m, n, k, a, lda, tau, work, info ) + pure subroutine stdlib_${ri}$org2r( m, n, k, a, lda, tau, work, info ) !! DORG2R: generates an m by n real matrix Q with orthonormal columns, !! which is defined as the first n columns of a product of k elementary !! reflectors of order m @@ -53261,9 +53262,9 @@ module stdlib_linalg_lapack_q integer(ilp), intent(out) :: info integer(ilp), intent(in) :: k, lda, m, n ! Array Arguments - real(qp), intent(inout) :: a(lda,*) - real(qp), intent(in) :: tau(*) - real(qp), intent(out) :: work(*) + real(${rk}$), intent(inout) :: a(lda,*) + real(${rk}$), intent(in) :: tau(*) + real(${rk}$), intent(out) :: work(*) ! ===================================================================== ! Local Scalars @@ -53299,10 +53300,10 @@ module stdlib_linalg_lapack_q ! apply h(i) to a(i:m,i:n) from the left if( i=k ) then - call stdlib_qorgqr( m, n, k, a, lda, tau, work, -1, iinfo ) + call stdlib_${ri}$orgqr( m, n, k, a, lda, tau, work, -1, iinfo ) else if( m>1 ) then - call stdlib_qorgqr( m-1, m-1, m-1, a, lda, tau, work, -1,iinfo ) + call stdlib_${ri}$orgqr( m-1, m-1, m-1, a, lda, tau, work, -1,iinfo ) end if end if else if( k1 ) then - call stdlib_qorglq( n-1, n-1, n-1, a, lda, tau, work, -1,iinfo ) + call stdlib_${ri}$orglq( n-1, n-1, n-1, a, lda, tau, work, -1,iinfo ) end if end if end if @@ -53403,11 +53404,11 @@ module stdlib_linalg_lapack_q return end if if( wantq ) then - ! form q, determined by a call to stdlib_qgebrd to reduce an m-by-k + ! form q, determined by a call to stdlib_${ri}$gebrd to reduce an m-by-k ! matrix if( m>=k ) then ! if m >= k, assume m >= n >= k - call stdlib_qorgqr( m, n, k, a, lda, tau, work, lwork, iinfo ) + call stdlib_${ri}$orgqr( m, n, k, a, lda, tau, work, lwork, iinfo ) else ! if m < k, assume m = n ! shift the vectors which define the elementary reflectors one @@ -53425,16 +53426,16 @@ module stdlib_linalg_lapack_q end do if( m>1 ) then ! form q(2:m,2:m) - call stdlib_qorgqr( m-1, m-1, m-1, a( 2, 2 ), lda, tau, work,lwork, iinfo ) + call stdlib_${ri}$orgqr( m-1, m-1, m-1, a( 2, 2 ), lda, tau, work,lwork, iinfo ) end if end if else - ! form p**t, determined by a call to stdlib_qgebrd to reduce a k-by-n + ! form p**t, determined by a call to stdlib_${ri}$gebrd to reduce a k-by-n ! matrix if( k= n, assume m = n ! shift the vectors which define the elementary reflectors one @@ -53452,17 +53453,17 @@ module stdlib_linalg_lapack_q end do if( n>1 ) then ! form p**t(2:n,2:n) - call stdlib_qorglq( n-1, n-1, n-1, a( 2, 2 ), lda, tau, work,lwork, iinfo ) + call stdlib_${ri}$orglq( n-1, n-1, n-1, a( 2, 2 ), lda, tau, work,lwork, iinfo ) end if end if end if work( 1 ) = lwkopt return - end subroutine stdlib_qorgbr + end subroutine stdlib_${ri}$orgbr - pure subroutine stdlib_qorghr( n, ilo, ihi, a, lda, tau, work, lwork, info ) + pure subroutine stdlib_${ri}$orghr( n, ilo, ihi, a, lda, tau, work, lwork, info ) !! DORGHR: generates a real orthogonal matrix Q which is defined as the !! product of IHI-ILO elementary reflectors of order N, as returned by !! DGEHRD: @@ -53474,9 +53475,9 @@ module stdlib_linalg_lapack_q integer(ilp), intent(in) :: ihi, ilo, lda, lwork, n integer(ilp), intent(out) :: info ! Array Arguments - real(qp), intent(inout) :: a(lda,*) - real(qp), intent(in) :: tau(*) - real(qp), intent(out) :: work(*) + real(${rk}$), intent(inout) :: a(lda,*) + real(${rk}$), intent(in) :: tau(*) + real(${rk}$), intent(out) :: work(*) ! ===================================================================== ! Local Scalars @@ -53544,15 +53545,15 @@ module stdlib_linalg_lapack_q end do if( nh>0 ) then ! generate q(ilo+1:ihi,ilo+1:ihi) - call stdlib_qorgqr( nh, nh, nh, a( ilo+1, ilo+1 ), lda, tau( ilo ),work, lwork, & + call stdlib_${ri}$orgqr( nh, nh, nh, a( ilo+1, ilo+1 ), lda, tau( ilo ),work, lwork, & iinfo ) end if work( 1 ) = lwkopt return - end subroutine stdlib_qorghr + end subroutine stdlib_${ri}$orghr - pure subroutine stdlib_qorgl2( m, n, k, a, lda, tau, work, info ) + pure subroutine stdlib_${ri}$orgl2( m, n, k, a, lda, tau, work, info ) !! DORGL2: generates an m by n real matrix Q with orthonormal rows, !! which is defined as the first m rows of a product of k elementary !! reflectors of order n @@ -53565,9 +53566,9 @@ module stdlib_linalg_lapack_q integer(ilp), intent(out) :: info integer(ilp), intent(in) :: k, lda, m, n ! Array Arguments - real(qp), intent(inout) :: a(lda,*) - real(qp), intent(in) :: tau(*) - real(qp), intent(out) :: work(*) + real(${rk}$), intent(inout) :: a(lda,*) + real(${rk}$), intent(in) :: tau(*) + real(${rk}$), intent(out) :: work(*) ! ===================================================================== ! Local Scalars @@ -53606,10 +53607,10 @@ module stdlib_linalg_lapack_q if( i0 ) then ! use blocked code @@ -53715,15 +53716,15 @@ module stdlib_linalg_lapack_q if( i+ib<=m ) then ! form the triangular factor of the block reflector ! h = h(i) h(i+1) . . . h(i+ib-1) - call stdlib_qlarft( 'FORWARD', 'ROWWISE', n-i+1, ib, a( i, i ),lda, tau( i ), & + call stdlib_${ri}$larft( 'FORWARD', 'ROWWISE', n-i+1, ib, a( i, i ),lda, tau( i ), & work, ldwork ) ! apply h**t to a(i+ib:m,i:n) from the right - call stdlib_qlarfb( 'RIGHT', 'TRANSPOSE', 'FORWARD', 'ROWWISE',m-i-ib+1, n-i+& + call stdlib_${ri}$larfb( 'RIGHT', 'TRANSPOSE', 'FORWARD', 'ROWWISE',m-i-ib+1, n-i+& 1, ib, a( i, i ), lda, work,ldwork, a( i+ib, i ), lda, work( ib+1 ),ldwork ) end if ! apply h**t to columns i:n of current block - call stdlib_qorgl2( ib, n-i+1, ib, a( i, i ), lda, tau( i ), work,iinfo ) + call stdlib_${ri}$orgl2( ib, n-i+1, ib, a( i, i ), lda, tau( i ), work,iinfo ) ! set columns 1:i-1 of current block to zero do j = 1, i - 1 do l = i, i + ib - 1 @@ -53734,10 +53735,10 @@ module stdlib_linalg_lapack_q end if work( 1 ) = iws return - end subroutine stdlib_qorglq + end subroutine stdlib_${ri}$orglq - pure subroutine stdlib_qorgql( m, n, k, a, lda, tau, work, lwork, info ) + pure subroutine stdlib_${ri}$orgql( m, n, k, a, lda, tau, work, lwork, info ) !! DORGQL: generates an M-by-N real matrix Q with orthonormal columns, !! which is defined as the last N columns of a product of K elementary !! reflectors of order M @@ -53750,9 +53751,9 @@ module stdlib_linalg_lapack_q integer(ilp), intent(out) :: info integer(ilp), intent(in) :: k, lda, lwork, m, n ! Array Arguments - real(qp), intent(inout) :: a(lda,*) - real(qp), intent(in) :: tau(*) - real(qp), intent(out) :: work(*) + real(${rk}$), intent(inout) :: a(lda,*) + real(${rk}$), intent(in) :: tau(*) + real(${rk}$), intent(out) :: work(*) ! ===================================================================== ! Local Scalars @@ -53827,7 +53828,7 @@ module stdlib_linalg_lapack_q kk = 0 end if ! use unblocked code for the first or only block. - call stdlib_qorg2l( m-kk, n-kk, k-kk, a, lda, tau, work, iinfo ) + call stdlib_${ri}$org2l( m-kk, n-kk, k-kk, a, lda, tau, work, iinfo ) if( kk>0 ) then ! use blocked code do i = k - kk + 1, k, nb @@ -53835,15 +53836,15 @@ module stdlib_linalg_lapack_q if( n-k+i>1 ) then ! form the triangular factor of the block reflector ! h = h(i+ib-1) . . . h(i+1) h(i) - call stdlib_qlarft( 'BACKWARD', 'COLUMNWISE', m-k+i+ib-1, ib,a( 1, n-k+i ), & + call stdlib_${ri}$larft( 'BACKWARD', 'COLUMNWISE', m-k+i+ib-1, ib,a( 1, n-k+i ), & lda, tau( i ), work, ldwork ) ! apply h to a(1:m-k+i+ib-1,1:n-k+i-1) from the left - call stdlib_qlarfb( 'LEFT', 'NO TRANSPOSE', 'BACKWARD','COLUMNWISE', m-k+i+ib-& + call stdlib_${ri}$larfb( 'LEFT', 'NO TRANSPOSE', 'BACKWARD','COLUMNWISE', m-k+i+ib-& 1, n-k+i-1, ib,a( 1, n-k+i ), lda, work, ldwork, a, lda,work( ib+1 ), ldwork ) end if ! apply h to rows 1:m-k+i+ib-1 of current block - call stdlib_qorg2l( m-k+i+ib-1, ib, ib, a( 1, n-k+i ), lda,tau( i ), work, iinfo & + call stdlib_${ri}$org2l( m-k+i+ib-1, ib, ib, a( 1, n-k+i ), lda,tau( i ), work, iinfo & ) ! set rows m-k+i+ib:m of current block to zero do j = n - k + i, n - k + i + ib - 1 @@ -53855,10 +53856,10 @@ module stdlib_linalg_lapack_q end if work( 1 ) = iws return - end subroutine stdlib_qorgql + end subroutine stdlib_${ri}$orgql - pure subroutine stdlib_qorgqr( m, n, k, a, lda, tau, work, lwork, info ) + pure subroutine stdlib_${ri}$orgqr( m, n, k, a, lda, tau, work, lwork, info ) !! DORGQR: generates an M-by-N real matrix Q with orthonormal columns, !! which is defined as the first N columns of a product of K elementary !! reflectors of order M @@ -53871,9 +53872,9 @@ module stdlib_linalg_lapack_q integer(ilp), intent(out) :: info integer(ilp), intent(in) :: k, lda, lwork, m, n ! Array Arguments - real(qp), intent(inout) :: a(lda,*) - real(qp), intent(in) :: tau(*) - real(qp), intent(out) :: work(*) + real(${rk}$), intent(inout) :: a(lda,*) + real(${rk}$), intent(in) :: tau(*) + real(${rk}$), intent(out) :: work(*) ! ===================================================================== ! Local Scalars @@ -53943,7 +53944,7 @@ module stdlib_linalg_lapack_q kk = 0 end if ! use unblocked code for the last or only block. - if( kk0 ) then ! use blocked code @@ -53952,15 +53953,15 @@ module stdlib_linalg_lapack_q if( i+ib<=n ) then ! form the triangular factor of the block reflector ! h = h(i) h(i+1) . . . h(i+ib-1) - call stdlib_qlarft( 'FORWARD', 'COLUMNWISE', m-i+1, ib,a( i, i ), lda, tau( i & + call stdlib_${ri}$larft( 'FORWARD', 'COLUMNWISE', m-i+1, ib,a( i, i ), lda, tau( i & ), work, ldwork ) ! apply h to a(i:m,i+ib:n) from the left - call stdlib_qlarfb( 'LEFT', 'NO TRANSPOSE', 'FORWARD','COLUMNWISE', m-i+1, n-& + call stdlib_${ri}$larfb( 'LEFT', 'NO TRANSPOSE', 'FORWARD','COLUMNWISE', m-i+1, n-& i-ib+1, ib,a( i, i ), lda, work, ldwork, a( i, i+ib ),lda, work( ib+1 ), & ldwork ) end if ! apply h to rows i:m of current block - call stdlib_qorg2r( m-i+1, ib, ib, a( i, i ), lda, tau( i ), work,iinfo ) + call stdlib_${ri}$org2r( m-i+1, ib, ib, a( i, i ), lda, tau( i ), work,iinfo ) ! set rows 1:i-1 of current block to zero do j = i, i + ib - 1 do l = 1, i - 1 @@ -53971,10 +53972,10 @@ module stdlib_linalg_lapack_q end if work( 1 ) = iws return - end subroutine stdlib_qorgqr + end subroutine stdlib_${ri}$orgqr - pure subroutine stdlib_qorgr2( m, n, k, a, lda, tau, work, info ) + pure subroutine stdlib_${ri}$orgr2( m, n, k, a, lda, tau, work, info ) !! DORGR2: generates an m by n real matrix Q with orthonormal rows, !! which is defined as the last m rows of a product of k elementary !! reflectors of order n @@ -53987,9 +53988,9 @@ module stdlib_linalg_lapack_q integer(ilp), intent(out) :: info integer(ilp), intent(in) :: k, lda, m, n ! Array Arguments - real(qp), intent(inout) :: a(lda,*) - real(qp), intent(in) :: tau(*) - real(qp), intent(out) :: work(*) + real(${rk}$), intent(inout) :: a(lda,*) + real(${rk}$), intent(in) :: tau(*) + real(${rk}$), intent(out) :: work(*) ! ===================================================================== ! Local Scalars @@ -54027,9 +54028,9 @@ module stdlib_linalg_lapack_q ii = m - k + i ! apply h(i) to a(1:m-k+i,1:n-k+i) from the right a( ii, n-m+ii ) = one - call stdlib_qlarf( 'RIGHT', ii-1, n-m+ii, a( ii, 1 ), lda, tau( i ),a, lda, work ) + call stdlib_${ri}$larf( 'RIGHT', ii-1, n-m+ii, a( ii, 1 ), lda, tau( i ),a, lda, work ) - call stdlib_qscal( n-m+ii-1, -tau( i ), a( ii, 1 ), lda ) + call stdlib_${ri}$scal( n-m+ii-1, -tau( i ), a( ii, 1 ), lda ) a( ii, n-m+ii ) = one - tau( i ) ! set a(m-k+i,n-k+i+1:n) to zero do l = n - m + ii + 1, n @@ -54037,10 +54038,10 @@ module stdlib_linalg_lapack_q end do end do return - end subroutine stdlib_qorgr2 + end subroutine stdlib_${ri}$orgr2 - pure subroutine stdlib_qorgrq( m, n, k, a, lda, tau, work, lwork, info ) + pure subroutine stdlib_${ri}$orgrq( m, n, k, a, lda, tau, work, lwork, info ) !! DORGRQ: generates an M-by-N real matrix Q with orthonormal rows, !! which is defined as the last M rows of a product of K elementary !! reflectors of order N @@ -54053,9 +54054,9 @@ module stdlib_linalg_lapack_q integer(ilp), intent(out) :: info integer(ilp), intent(in) :: k, lda, lwork, m, n ! Array Arguments - real(qp), intent(inout) :: a(lda,*) - real(qp), intent(in) :: tau(*) - real(qp), intent(out) :: work(*) + real(${rk}$), intent(inout) :: a(lda,*) + real(${rk}$), intent(in) :: tau(*) + real(${rk}$), intent(out) :: work(*) ! ===================================================================== ! Local Scalars @@ -54130,7 +54131,7 @@ module stdlib_linalg_lapack_q kk = 0 end if ! use unblocked code for the first or only block. - call stdlib_qorgr2( m-kk, n-kk, k-kk, a, lda, tau, work, iinfo ) + call stdlib_${ri}$orgr2( m-kk, n-kk, k-kk, a, lda, tau, work, iinfo ) if( kk>0 ) then ! use blocked code do i = k - kk + 1, k, nb @@ -54139,14 +54140,14 @@ module stdlib_linalg_lapack_q if( ii>1 ) then ! form the triangular factor of the block reflector ! h = h(i+ib-1) . . . h(i+1) h(i) - call stdlib_qlarft( 'BACKWARD', 'ROWWISE', n-k+i+ib-1, ib,a( ii, 1 ), lda, & + call stdlib_${ri}$larft( 'BACKWARD', 'ROWWISE', n-k+i+ib-1, ib,a( ii, 1 ), lda, & tau( i ), work, ldwork ) ! apply h**t to a(1:m-k+i-1,1:n-k+i+ib-1) from the right - call stdlib_qlarfb( 'RIGHT', 'TRANSPOSE', 'BACKWARD', 'ROWWISE',ii-1, n-k+i+& + call stdlib_${ri}$larfb( 'RIGHT', 'TRANSPOSE', 'BACKWARD', 'ROWWISE',ii-1, n-k+i+& ib-1, ib, a( ii, 1 ), lda, work,ldwork, a, lda, work( ib+1 ), ldwork ) end if ! apply h**t to columns 1:n-k+i+ib-1 of current block - call stdlib_qorgr2( ib, n-k+i+ib-1, ib, a( ii, 1 ), lda, tau( i ),work, iinfo ) + call stdlib_${ri}$orgr2( ib, n-k+i+ib-1, ib, a( ii, 1 ), lda, tau( i ),work, iinfo ) ! set columns n-k+i+ib:n of current block to zero do l = n - k + i + ib, n @@ -54158,10 +54159,10 @@ module stdlib_linalg_lapack_q end if work( 1 ) = iws return - end subroutine stdlib_qorgrq + end subroutine stdlib_${ri}$orgrq - pure subroutine stdlib_qorgtr( uplo, n, a, lda, tau, work, lwork, info ) + pure subroutine stdlib_${ri}$orgtr( uplo, n, a, lda, tau, work, lwork, info ) !! DORGTR: generates a real orthogonal matrix Q which is defined as the !! product of n-1 elementary reflectors of order N, as returned by !! DSYTRD: @@ -54175,9 +54176,9 @@ module stdlib_linalg_lapack_q integer(ilp), intent(out) :: info integer(ilp), intent(in) :: lda, lwork, n ! Array Arguments - real(qp), intent(inout) :: a(lda,*) - real(qp), intent(in) :: tau(*) - real(qp), intent(out) :: work(*) + real(${rk}$), intent(inout) :: a(lda,*) + real(${rk}$), intent(in) :: tau(*) + real(${rk}$), intent(out) :: work(*) ! ===================================================================== ! Local Scalars @@ -54220,7 +54221,7 @@ module stdlib_linalg_lapack_q return end if if( upper ) then - ! q was determined by a call to stdlib_qsytrd with uplo = 'u' + ! q was determined by a call to stdlib_${ri}$sytrd with uplo = 'u' ! shift the vectors which define the elementary reflectors one ! column to the left, and set the last row and column of q to ! those of the unit matrix @@ -54235,9 +54236,9 @@ module stdlib_linalg_lapack_q end do a( n, n ) = one ! generate q(1:n-1,1:n-1) - call stdlib_qorgql( n-1, n-1, n-1, a, lda, tau, work, lwork, iinfo ) + call stdlib_${ri}$orgql( n-1, n-1, n-1, a, lda, tau, work, lwork, iinfo ) else - ! q was determined by a call to stdlib_qsytrd with uplo = 'l'. + ! q was determined by a call to stdlib_${ri}$sytrd with uplo = 'l'. ! shift the vectors which define the elementary reflectors one ! column to the right, and set the first row and column of q to ! those of the unit matrix @@ -54253,16 +54254,16 @@ module stdlib_linalg_lapack_q end do if( n>1 ) then ! generate q(2:n,2:n) - call stdlib_qorgqr( n-1, n-1, n-1, a( 2, 2 ), lda, tau, work,lwork, iinfo ) + call stdlib_${ri}$orgqr( n-1, n-1, n-1, a( 2, 2 ), lda, tau, work,lwork, iinfo ) end if end if work( 1 ) = lwkopt return - end subroutine stdlib_qorgtr + end subroutine stdlib_${ri}$orgtr - pure subroutine stdlib_qorgtsqr( m, n, mb, nb, a, lda, t, ldt, work, lwork,info ) + pure subroutine stdlib_${ri}$orgtsqr( m, n, mb, nb, a, lda, t, ldt, work, lwork,info ) !! DORGTSQR: generates an M-by-N real matrix Q_out with orthonormal columns, !! which are the first N columns of a product of real orthogonal !! matrices of order M which are returned by DLATSQR @@ -54275,9 +54276,9 @@ module stdlib_linalg_lapack_q integer(ilp), intent(out) :: info integer(ilp), intent(in) :: lda, ldt, lwork, m, n, mb, nb ! Array Arguments - real(qp), intent(inout) :: a(lda,*) - real(qp), intent(in) :: t(ldt,*) - real(qp), intent(out) :: work(*) + real(${rk}$), intent(inout) :: a(lda,*) + real(${rk}$), intent(in) :: t(ldt,*) + real(${rk}$), intent(out) :: work(*) ! ===================================================================== ! Local Scalars @@ -54304,15 +54305,15 @@ module stdlib_linalg_lapack_q else ! test the input lwork for the dimension of the array work. ! this workspace is used to store array c(ldc, n) and work(lwork) - ! in the call to stdlib_qlamtsqr. see the documentation for stdlib_qlamtsqr. + ! in the call to stdlib_${ri}$lamtsqr. see the documentation for stdlib_${ri}$lamtsqr. if( lwork<2 .and. (.not.lquery) ) then info = -10 else ! set block size for column blocks nblocal = min( nb, n ) ! lwork = -1, then set the size for the array c(ldc,n) - ! in stdlib_qlamtsqr call and set the optimal size of the work array - ! work(lwork) in stdlib_qlamtsqr call. + ! in stdlib_${ri}$lamtsqr call and set the optimal size of the work array + ! work(lwork) in stdlib_${ri}$lamtsqr call. ldc = m lc = ldc*n lw = n * nblocal @@ -54327,40 +54328,40 @@ module stdlib_linalg_lapack_q call stdlib_xerbla( 'DORGTSQR', -info ) return else if ( lquery ) then - work( 1 ) = real( lworkopt,KIND=qp) + work( 1 ) = real( lworkopt,KIND=${rk}$) return end if ! quick return if possible if( min( m, n )==0 ) then - work( 1 ) = real( lworkopt,KIND=qp) + work( 1 ) = real( lworkopt,KIND=${rk}$) return end if ! (1) form explicitly the tall-skinny m-by-n left submatrix q1_in ! of m-by-m orthogonal matrix q_in, which is implicitly stored in ! the subdiagonal part of input array a and in the input array t. - ! perform by the following operation using the routine stdlib_qlamtsqr. + ! perform by the following operation using the routine stdlib_${ri}$lamtsqr. ! q1_in = q_in * ( i ), where i is a n-by-n identity matrix, ! ( 0 ) 0 is a (m-n)-by-n zero matrix. ! (1a) form m-by-n matrix in the array work(1:ldc*n) with ones ! on the diagonal and zeros elsewhere. - call stdlib_qlaset( 'F', m, n, zero, one, work, ldc ) + call stdlib_${ri}$laset( 'F', m, n, zero, one, work, ldc ) ! (1b) on input, work(1:ldc*n) stores ( i ); ! ( 0 ) ! on output, work(1:ldc*n) stores q1_in. - call stdlib_qlamtsqr( 'L', 'N', m, n, n, mb, nblocal, a, lda, t, ldt,work, ldc, work( & + call stdlib_${ri}$lamtsqr( 'L', 'N', m, n, n, mb, nblocal, a, lda, t, ldt,work, ldc, work( & lc+1 ), lw, iinfo ) ! (2) copy the result from the part of the work array (1:m,1:n) ! with the leading dimension ldc that starts at work(1) into ! the output array a(1:m,1:n) column-by-column. do j = 1, n - call stdlib_qcopy( m, work( (j-1)*ldc + 1 ), 1, a( 1, j ), 1 ) + call stdlib_${ri}$copy( m, work( (j-1)*ldc + 1 ), 1, a( 1, j ), 1 ) end do - work( 1 ) = real( lworkopt,KIND=qp) + work( 1 ) = real( lworkopt,KIND=${rk}$) return - end subroutine stdlib_qorgtsqr + end subroutine stdlib_${ri}$orgtsqr - pure subroutine stdlib_qorgtsqr_row( m, n, mb, nb, a, lda, t, ldt, work,lwork, info ) + pure subroutine stdlib_${ri}$orgtsqr_row( m, n, mb, nb, a, lda, t, ldt, work,lwork, info ) !! DORGTSQR_ROW: generates an M-by-N real matrix Q_out with !! orthonormal columns from the output of DLATSQR. These N orthonormal !! columns are the first N columns of a product of complex unitary @@ -54383,9 +54384,9 @@ module stdlib_linalg_lapack_q integer(ilp), intent(out) :: info integer(ilp), intent(in) :: lda, ldt, lwork, m, n, mb, nb ! Array Arguments - real(qp), intent(inout) :: a(lda,*) - real(qp), intent(in) :: t(ldt,*) - real(qp), intent(out) :: work(*) + real(${rk}$), intent(inout) :: a(lda,*) + real(${rk}$), intent(in) :: t(ldt,*) + real(${rk}$), intent(out) :: work(*) ! ===================================================================== ! Local Scalars @@ -54393,7 +54394,7 @@ module stdlib_linalg_lapack_q integer(ilp) :: nblocal, mb2, m_plus_one, itmp, ib_bottom, lworkopt, & num_all_row_blocks, jb_t, ib, imb, kb, kb_last, knb, mb1 ! Local Arrays - real(qp) :: dummy(1,1) + real(${rk}$) :: dummy(1,1) ! Intrinsic Functions intrinsic :: real,max,min ! Executable Statements @@ -54425,17 +54426,17 @@ module stdlib_linalg_lapack_q call stdlib_xerbla( 'DORGTSQR_ROW', -info ) return else if ( lquery ) then - work( 1 ) = real( lworkopt,KIND=qp) + work( 1 ) = real( lworkopt,KIND=${rk}$) return end if ! quick return if possible if( min( m, n )==0 ) then - work( 1 ) = real( lworkopt,KIND=qp) + work( 1 ) = real( lworkopt,KIND=${rk}$) return end if ! (0) set the upper-triangular part of the matrix a to zero and ! its diagonal elements to one. - call stdlib_qlaset('U', m, n, zero, one, a, lda ) + call stdlib_${ri}$laset('U', m, n, zero, one, a, lda ) ! kb_last is the column index of the last column block reflector ! in the matrices t and v. kb_last = ( ( n-1 ) / nblocal ) * nblocal + 1 @@ -54471,7 +54472,7 @@ module stdlib_linalg_lapack_q ! determine the size of the current column block knb in ! the matrices t and v. knb = min( nblocal, n - kb + 1 ) - call stdlib_qlarfb_gett( 'I', imb, n-kb+1, knb,t( 1, jb_t+kb-1 ), ldt, a( kb, & + call stdlib_${ri}$larfb_gett( 'I', imb, n-kb+1, knb,t( 1, jb_t+kb-1 ), ldt, a( kb, & kb ), lda,a( ib, kb ), lda, work, knb ) end do end do @@ -54491,19 +54492,19 @@ module stdlib_linalg_lapack_q ! in stdlib_dlarfb_gett parameters, when m=0, then the matrix b ! does not exist, hence we need to pass a dummy array ! reference dummy(1,1) to b with lddummy=1. - call stdlib_qlarfb_gett( 'N', 0, n-kb+1, knb,t( 1, kb ), ldt, a( kb, kb ), lda,& + call stdlib_${ri}$larfb_gett( 'N', 0, n-kb+1, knb,t( 1, kb ), ldt, a( kb, kb ), lda,& dummy( 1, 1 ), 1, work, knb ) else - call stdlib_qlarfb_gett( 'N', mb1-kb-knb+1, n-kb+1, knb,t( 1, kb ), ldt, a( kb, & + call stdlib_${ri}$larfb_gett( 'N', mb1-kb-knb+1, n-kb+1, knb,t( 1, kb ), ldt, a( kb, & kb ), lda,a( kb+knb, kb), lda, work, knb ) end if end do - work( 1 ) = real( lworkopt,KIND=qp) + work( 1 ) = real( lworkopt,KIND=${rk}$) return - end subroutine stdlib_qorgtsqr_row + end subroutine stdlib_${ri}$orgtsqr_row - pure subroutine stdlib_qorhr_col( m, n, nb, a, lda, t, ldt, d, info ) + pure subroutine stdlib_${ri}$orhr_col( m, n, nb, a, lda, t, ldt, d, info ) !! DORHR_COL: takes an M-by-N real matrix Q_in with orthonormal columns !! as input, stored in A, and performs Householder Reconstruction (HR), !! i.e. reconstructs Householder vectors V(i) implicitly representing @@ -54520,8 +54521,8 @@ module stdlib_linalg_lapack_q integer(ilp), intent(out) :: info integer(ilp), intent(in) :: lda, ldt, m, n, nb ! Array Arguments - real(qp), intent(inout) :: a(lda,*) - real(qp), intent(out) :: d(*), t(ldt,*) + real(${rk}$), intent(inout) :: a(lda,*) + real(${rk}$), intent(out) :: d(*), t(ldt,*) ! ===================================================================== ! Local Scalars @@ -54559,10 +54560,10 @@ module stdlib_linalg_lapack_q ! ( 0 ) ( v2 ) ! where 0 is an (m-n)-by-n zero matrix. ! (1-1) factor v1 and u. - call stdlib_qlaorhr_col_getrfnp( n, n, a, lda, d, iinfo ) + call stdlib_${ri}$laorhr_col_getrfnp( n, n, a, lda, d, iinfo ) ! (1-2) solve for v2. if( m>n ) then - call stdlib_qtrsm( 'R', 'U', 'N', 'N', m-n, n, one, a, lda,a( n+1, 1 ), lda ) + call stdlib_${ri}$trsm( 'R', 'U', 'N', 'N', m-n, n, one, a, lda,a( n+1, 1 ), lda ) end if ! (2) reconstruct the block reflector t stored in t(1:nb, 1:n) @@ -54582,7 +54583,7 @@ module stdlib_linalg_lapack_q ! column-by-column, total jnb*(jnb+1)/2 elements. jbtemp1 = jb - 1 do j = jb, jb+jnb-1 - call stdlib_qcopy( j-jbtemp1, a( jb, j ), 1, t( 1, j ), 1 ) + call stdlib_${ri}$copy( j-jbtemp1, a( jb, j ), 1, t( 1, j ), 1 ) end do ! (2-2) perform on the upper-triangular part of the current ! jnb-by-jnb diagonal block u(jb) (of the n-by-n matrix u) stored @@ -54596,7 +54597,7 @@ module stdlib_linalg_lapack_q ! s(jb), i.e. s(j,j) that is stored in the array element d(j). do j = jb, jb+jnb-1 if( d( j )==one ) then - call stdlib_qscal( j-jbtemp1, -one, t( 1, j ), 1 ) + call stdlib_${ri}$scal( j-jbtemp1, -one, t( 1, j ), 1 ) end if end do ! (2-3) perform the triangular solve for the current block @@ -54620,11 +54621,11 @@ module stdlib_linalg_lapack_q ! upper-triangular block t(jb): ! t(jb) * (v1(jb)**t) = (-1)*u(jb)*s(jb). ! even though the blocks x(jb) and b(jb) are upper- - ! triangular, the routine stdlib_qtrsm will access all jnb**2 + ! triangular, the routine stdlib_${ri}$trsm will access all jnb**2 ! elements of the square t(1:jnb,jb:jb+jnb-1). therefore, ! we need to set to zero the elements of the block ! t(1:jnb,jb:jb+jnb-1) below the diagonal before the call - ! to stdlib_qtrsm. + ! to stdlib_${ri}$trsm. ! (2-3a) set the elements to zero. jbtemp2 = jb - 2 do j = jb, jb+jnb-2 @@ -54633,14 +54634,14 @@ module stdlib_linalg_lapack_q end do end do ! (2-3b) perform the triangular solve. - call stdlib_qtrsm( 'R', 'L', 'T', 'U', jnb, jnb, one,a( jb, jb ), lda, t( 1, jb ), & + call stdlib_${ri}$trsm( 'R', 'L', 'T', 'U', jnb, jnb, one,a( jb, jb ), lda, t( 1, jb ), & ldt ) end do return - end subroutine stdlib_qorhr_col + end subroutine stdlib_${ri}$orhr_col - pure subroutine stdlib_qorm22( side, trans, m, n, n1, n2, q, ldq, c, ldc,work, lwork, info ) + pure subroutine stdlib_${ri}$orm22( side, trans, m, n, n1, n2, q, ldq, c, ldc,work, lwork, info ) ! -- lapack computational routine -- ! -- lapack is a software package provided by univ. of tennessee, -- @@ -54650,9 +54651,9 @@ module stdlib_linalg_lapack_q integer(ilp), intent(in) :: m, n, n1, n2, ldq, ldc, lwork integer(ilp), intent(out) :: info ! Array Arguments - real(qp), intent(in) :: q(ldq,*) - real(qp), intent(inout) :: c(ldc,*) - real(qp), intent(out) :: work(*) + real(${rk}$), intent(in) :: q(ldq,*) + real(${rk}$), intent(inout) :: c(ldc,*) + real(${rk}$), intent(out) :: work(*) ! ===================================================================== ! Local Scalars @@ -54697,7 +54698,7 @@ module stdlib_linalg_lapack_q end if if( info==0 ) then lwkopt = m*n - work( 1 ) = real( lwkopt,KIND=qp) + work( 1 ) = real( lwkopt,KIND=${rk}$) end if if( info/=0 ) then call stdlib_xerbla( 'DORM22', -info ) @@ -54710,14 +54711,14 @@ module stdlib_linalg_lapack_q work( 1 ) = 1 return end if - ! degenerate cases (n1 = 0 or n2 = 0) are handled using stdlib_qtrmm. + ! degenerate cases (n1 = 0 or n2 = 0) are handled using stdlib_${ri}$trmm. if( n1==0 ) then - call stdlib_qtrmm( side, 'UPPER', trans, 'NON-UNIT', m, n, one,q, ldq, c, ldc ) + call stdlib_${ri}$trmm( side, 'UPPER', trans, 'NON-UNIT', m, n, one,q, ldq, c, ldc ) work( 1 ) = one return else if( n2==0 ) then - call stdlib_qtrmm( side, 'LOWER', trans, 'NON-UNIT', m, n, one,q, ldq, c, ldc ) + call stdlib_${ri}$trmm( side, 'LOWER', trans, 'NON-UNIT', m, n, one,q, ldq, c, ldc ) work( 1 ) = one return @@ -54730,44 +54731,44 @@ module stdlib_linalg_lapack_q len = min( nb, n-i+1 ) ldwork = m ! multiply bottom part of c by q12. - call stdlib_qlacpy( 'ALL', n1, len, c( n2+1, i ), ldc, work,ldwork ) - call stdlib_qtrmm( 'LEFT', 'LOWER', 'NO TRANSPOSE', 'NON-UNIT',n1, len, one, & + call stdlib_${ri}$lacpy( 'ALL', n1, len, c( n2+1, i ), ldc, work,ldwork ) + call stdlib_${ri}$trmm( 'LEFT', 'LOWER', 'NO TRANSPOSE', 'NON-UNIT',n1, len, one, & q( 1, n2+1 ), ldq, work,ldwork ) ! multiply top part of c by q11. - call stdlib_qgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', n1, len, n2,one, q, ldq, c(& + call stdlib_${ri}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', n1, len, n2,one, q, ldq, c(& 1, i ), ldc, one, work,ldwork ) ! multiply top part of c by q21. - call stdlib_qlacpy( 'ALL', n2, len, c( 1, i ), ldc,work( n1+1 ), ldwork ) + call stdlib_${ri}$lacpy( 'ALL', n2, len, c( 1, i ), ldc,work( n1+1 ), ldwork ) - call stdlib_qtrmm( 'LEFT', 'UPPER', 'NO TRANSPOSE', 'NON-UNIT',n2, len, one, & + call stdlib_${ri}$trmm( 'LEFT', 'UPPER', 'NO TRANSPOSE', 'NON-UNIT',n2, len, one, & q( n1+1, 1 ), ldq,work( n1+1 ), ldwork ) ! multiply bottom part of c by q22. - call stdlib_qgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', n2, len, n1,one, q( n1+1, & + call stdlib_${ri}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', n2, len, n1,one, q( n1+1, & n2+1 ), ldq, c( n2+1, i ), ldc,one, work( n1+1 ), ldwork ) ! copy everything back. - call stdlib_qlacpy( 'ALL', m, len, work, ldwork, c( 1, i ),ldc ) + call stdlib_${ri}$lacpy( 'ALL', m, len, work, ldwork, c( 1, i ),ldc ) end do else do i = 1, n, nb len = min( nb, n-i+1 ) ldwork = m ! multiply bottom part of c by q21**t. - call stdlib_qlacpy( 'ALL', n2, len, c( n1+1, i ), ldc, work,ldwork ) - call stdlib_qtrmm( 'LEFT', 'UPPER', 'TRANSPOSE', 'NON-UNIT',n2, len, one, q( & + call stdlib_${ri}$lacpy( 'ALL', n2, len, c( n1+1, i ), ldc, work,ldwork ) + call stdlib_${ri}$trmm( 'LEFT', 'UPPER', 'TRANSPOSE', 'NON-UNIT',n2, len, one, q( & n1+1, 1 ), ldq, work,ldwork ) ! multiply top part of c by q11**t. - call stdlib_qgemm( 'TRANSPOSE', 'NO TRANSPOSE', n2, len, n1,one, q, ldq, c( 1,& + call stdlib_${ri}$gemm( 'TRANSPOSE', 'NO TRANSPOSE', n2, len, n1,one, q, ldq, c( 1,& i ), ldc, one, work,ldwork ) ! multiply top part of c by q12**t. - call stdlib_qlacpy( 'ALL', n1, len, c( 1, i ), ldc,work( n2+1 ), ldwork ) + call stdlib_${ri}$lacpy( 'ALL', n1, len, c( 1, i ), ldc,work( n2+1 ), ldwork ) - call stdlib_qtrmm( 'LEFT', 'LOWER', 'TRANSPOSE', 'NON-UNIT',n1, len, one, q( & + call stdlib_${ri}$trmm( 'LEFT', 'LOWER', 'TRANSPOSE', 'NON-UNIT',n1, len, one, q( & 1, n2+1 ), ldq,work( n2+1 ), ldwork ) ! multiply bottom part of c by q22**t. - call stdlib_qgemm( 'TRANSPOSE', 'NO TRANSPOSE', n1, len, n2,one, q( n1+1, n2+& + call stdlib_${ri}$gemm( 'TRANSPOSE', 'NO TRANSPOSE', n1, len, n2,one, q( n1+1, n2+& 1 ), ldq, c( n1+1, i ), ldc,one, work( n2+1 ), ldwork ) ! copy everything back. - call stdlib_qlacpy( 'ALL', m, len, work, ldwork, c( 1, i ),ldc ) + call stdlib_${ri}$lacpy( 'ALL', m, len, work, ldwork, c( 1, i ),ldc ) end do end if else @@ -54776,53 +54777,53 @@ module stdlib_linalg_lapack_q len = min( nb, m-i+1 ) ldwork = len ! multiply right part of c by q21. - call stdlib_qlacpy( 'ALL', len, n2, c( i, n1+1 ), ldc, work,ldwork ) - call stdlib_qtrmm( 'RIGHT', 'UPPER', 'NO TRANSPOSE', 'NON-UNIT',len, n2, one, & + call stdlib_${ri}$lacpy( 'ALL', len, n2, c( i, n1+1 ), ldc, work,ldwork ) + call stdlib_${ri}$trmm( 'RIGHT', 'UPPER', 'NO TRANSPOSE', 'NON-UNIT',len, n2, one, & q( n1+1, 1 ), ldq, work,ldwork ) ! multiply left part of c by q11. - call stdlib_qgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', len, n2, n1,one, c( i, 1 ),& + call stdlib_${ri}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', len, n2, n1,one, c( i, 1 ),& ldc, q, ldq, one, work,ldwork ) ! multiply left part of c by q12. - call stdlib_qlacpy( 'ALL', len, n1, c( i, 1 ), ldc,work( 1 + n2*ldwork ), & + call stdlib_${ri}$lacpy( 'ALL', len, n1, c( i, 1 ), ldc,work( 1 + n2*ldwork ), & ldwork ) - call stdlib_qtrmm( 'RIGHT', 'LOWER', 'NO TRANSPOSE', 'NON-UNIT',len, n1, one, & + call stdlib_${ri}$trmm( 'RIGHT', 'LOWER', 'NO TRANSPOSE', 'NON-UNIT',len, n1, one, & q( 1, n2+1 ), ldq,work( 1 + n2*ldwork ), ldwork ) ! multiply right part of c by q22. - call stdlib_qgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', len, n1, n2,one, c( i, n1+& + call stdlib_${ri}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', len, n1, n2,one, c( i, n1+& 1 ), ldc, q( n1+1, n2+1 ), ldq,one, work( 1 + n2*ldwork ), ldwork ) ! copy everything back. - call stdlib_qlacpy( 'ALL', len, n, work, ldwork, c( i, 1 ),ldc ) + call stdlib_${ri}$lacpy( 'ALL', len, n, work, ldwork, c( i, 1 ),ldc ) end do else do i = 1, m, nb len = min( nb, m-i+1 ) ldwork = len ! multiply right part of c by q12**t. - call stdlib_qlacpy( 'ALL', len, n1, c( i, n2+1 ), ldc, work,ldwork ) - call stdlib_qtrmm( 'RIGHT', 'LOWER', 'TRANSPOSE', 'NON-UNIT',len, n1, one, q( & + call stdlib_${ri}$lacpy( 'ALL', len, n1, c( i, n2+1 ), ldc, work,ldwork ) + call stdlib_${ri}$trmm( 'RIGHT', 'LOWER', 'TRANSPOSE', 'NON-UNIT',len, n1, one, q( & 1, n2+1 ), ldq, work,ldwork ) ! multiply left part of c by q11**t. - call stdlib_qgemm( 'NO TRANSPOSE', 'TRANSPOSE', len, n1, n2,one, c( i, 1 ), & + call stdlib_${ri}$gemm( 'NO TRANSPOSE', 'TRANSPOSE', len, n1, n2,one, c( i, 1 ), & ldc, q, ldq, one, work,ldwork ) ! multiply left part of c by q21**t. - call stdlib_qlacpy( 'ALL', len, n2, c( i, 1 ), ldc,work( 1 + n1*ldwork ), & + call stdlib_${ri}$lacpy( 'ALL', len, n2, c( i, 1 ), ldc,work( 1 + n1*ldwork ), & ldwork ) - call stdlib_qtrmm( 'RIGHT', 'UPPER', 'TRANSPOSE', 'NON-UNIT',len, n2, one, q( & + call stdlib_${ri}$trmm( 'RIGHT', 'UPPER', 'TRANSPOSE', 'NON-UNIT',len, n2, one, q( & n1+1, 1 ), ldq,work( 1 + n1*ldwork ), ldwork ) ! multiply right part of c by q22**t. - call stdlib_qgemm( 'NO TRANSPOSE', 'TRANSPOSE', len, n2, n1,one, c( i, n2+1 ),& + call stdlib_${ri}$gemm( 'NO TRANSPOSE', 'TRANSPOSE', len, n2, n1,one, c( i, n2+1 ),& ldc, q( n1+1, n2+1 ), ldq,one, work( 1 + n1*ldwork ), ldwork ) ! copy everything back. - call stdlib_qlacpy( 'ALL', len, n, work, ldwork, c( i, 1 ),ldc ) + call stdlib_${ri}$lacpy( 'ALL', len, n, work, ldwork, c( i, 1 ),ldc ) end do end if end if - work( 1 ) = real( lwkopt,KIND=qp) + work( 1 ) = real( lwkopt,KIND=${rk}$) return - end subroutine stdlib_qorm22 + end subroutine stdlib_${ri}$orm22 - pure subroutine stdlib_qorm2l( side, trans, m, n, k, a, lda, tau, c, ldc,work, info ) + pure subroutine stdlib_${ri}$orm2l( side, trans, m, n, k, a, lda, tau, c, ldc,work, info ) !! DORM2L: overwrites the general real m by n matrix C with !! Q * C if SIDE = 'L' and TRANS = 'N', or !! Q**T * C if SIDE = 'L' and TRANS = 'T', or @@ -54841,15 +54842,15 @@ module stdlib_linalg_lapack_q integer(ilp), intent(out) :: info integer(ilp), intent(in) :: k, lda, ldc, m, n ! Array Arguments - real(qp), intent(inout) :: a(lda,*), c(ldc,*) - real(qp), intent(in) :: tau(*) - real(qp), intent(out) :: work(*) + real(${rk}$), intent(inout) :: a(lda,*), c(ldc,*) + real(${rk}$), intent(in) :: tau(*) + real(${rk}$), intent(out) :: work(*) ! ===================================================================== ! Local Scalars logical(lk) :: left, notran integer(ilp) :: i, i1, i2, i3, mi, ni, nq - real(qp) :: aii + real(${rk}$) :: aii ! Intrinsic Functions intrinsic :: max ! Executable Statements @@ -54909,14 +54910,14 @@ module stdlib_linalg_lapack_q ! apply h(i) aii = a( nq-k+i, i ) a( nq-k+i, i ) = one - call stdlib_qlarf( side, mi, ni, a( 1, i ), 1, tau( i ), c, ldc,work ) + call stdlib_${ri}$larf( side, mi, ni, a( 1, i ), 1, tau( i ), c, ldc,work ) a( nq-k+i, i ) = aii end do return - end subroutine stdlib_qorm2l + end subroutine stdlib_${ri}$orm2l - pure subroutine stdlib_qorm2r( side, trans, m, n, k, a, lda, tau, c, ldc,work, info ) + pure subroutine stdlib_${ri}$orm2r( side, trans, m, n, k, a, lda, tau, c, ldc,work, info ) !! DORM2R: overwrites the general real m by n matrix C with !! Q * C if SIDE = 'L' and TRANS = 'N', or !! Q**T* C if SIDE = 'L' and TRANS = 'T', or @@ -54935,15 +54936,15 @@ module stdlib_linalg_lapack_q integer(ilp), intent(out) :: info integer(ilp), intent(in) :: k, lda, ldc, m, n ! Array Arguments - real(qp), intent(inout) :: a(lda,*), c(ldc,*) - real(qp), intent(in) :: tau(*) - real(qp), intent(out) :: work(*) + real(${rk}$), intent(inout) :: a(lda,*), c(ldc,*) + real(${rk}$), intent(in) :: tau(*) + real(${rk}$), intent(out) :: work(*) ! ===================================================================== ! Local Scalars logical(lk) :: left, notran integer(ilp) :: i, i1, i2, i3, ic, jc, mi, ni, nq - real(qp) :: aii + real(${rk}$) :: aii ! Intrinsic Functions intrinsic :: max ! Executable Statements @@ -55007,15 +55008,15 @@ module stdlib_linalg_lapack_q ! apply h(i) aii = a( i, i ) a( i, i ) = one - call stdlib_qlarf( side, mi, ni, a( i, i ), 1, tau( i ), c( ic, jc ),ldc, work ) + call stdlib_${ri}$larf( side, mi, ni, a( i, i ), 1, tau( i ), c( ic, jc ),ldc, work ) a( i, i ) = aii end do return - end subroutine stdlib_qorm2r + end subroutine stdlib_${ri}$orm2r - pure subroutine stdlib_qormbr( vect, side, trans, m, n, k, a, lda, tau, c,ldc, work, lwork, & + pure subroutine stdlib_${ri}$ormbr( vect, side, trans, m, n, k, a, lda, tau, c,ldc, work, lwork, & !! If VECT = 'Q', DORMBR: overwrites the general real M-by-N matrix C !! with !! SIDE = 'L' SIDE = 'R' @@ -55047,9 +55048,9 @@ module stdlib_linalg_lapack_q integer(ilp), intent(out) :: info integer(ilp), intent(in) :: k, lda, ldc, lwork, m, n ! Array Arguments - real(qp), intent(inout) :: a(lda,*), c(ldc,*) - real(qp), intent(in) :: tau(*) - real(qp), intent(out) :: work(*) + real(${rk}$), intent(inout) :: a(lda,*), c(ldc,*) + real(${rk}$), intent(in) :: tau(*) + real(${rk}$), intent(out) :: work(*) ! ===================================================================== ! Local Scalars logical(lk) :: applyq, left, lquery, notran @@ -55121,11 +55122,11 @@ module stdlib_linalg_lapack_q if( applyq ) then ! apply q if( nq>=k ) then - ! q was determined by a call to stdlib_qgebrd with nq >= k - call stdlib_qormqr( side, trans, m, n, k, a, lda, tau, c, ldc,work, lwork, iinfo & + ! q was determined by a call to stdlib_${ri}$gebrd with nq >= k + call stdlib_${ri}$ormqr( side, trans, m, n, k, a, lda, tau, c, ldc,work, lwork, iinfo & ) else if( nq>1 ) then - ! q was determined by a call to stdlib_qgebrd with nq < k + ! q was determined by a call to stdlib_${ri}$gebrd with nq < k if( left ) then mi = m - 1 ni = n @@ -55137,7 +55138,7 @@ module stdlib_linalg_lapack_q i1 = 1 i2 = 2 end if - call stdlib_qormqr( side, trans, mi, ni, nq-1, a( 2, 1 ), lda, tau,c( i1, i2 ), & + call stdlib_${ri}$ormqr( side, trans, mi, ni, nq-1, a( 2, 1 ), lda, tau,c( i1, i2 ), & ldc, work, lwork, iinfo ) end if else @@ -55148,11 +55149,11 @@ module stdlib_linalg_lapack_q transt = 'N' end if if( nq>k ) then - ! p was determined by a call to stdlib_qgebrd with nq > k - call stdlib_qormlq( side, transt, m, n, k, a, lda, tau, c, ldc,work, lwork, & + ! p was determined by a call to stdlib_${ri}$gebrd with nq > k + call stdlib_${ri}$ormlq( side, transt, m, n, k, a, lda, tau, c, ldc,work, lwork, & iinfo ) else if( nq>1 ) then - ! p was determined by a call to stdlib_qgebrd with nq <= k + ! p was determined by a call to stdlib_${ri}$gebrd with nq <= k if( left ) then mi = m - 1 ni = n @@ -55164,16 +55165,16 @@ module stdlib_linalg_lapack_q i1 = 1 i2 = 2 end if - call stdlib_qormlq( side, transt, mi, ni, nq-1, a( 1, 2 ), lda,tau, c( i1, i2 ), & + call stdlib_${ri}$ormlq( side, transt, mi, ni, nq-1, a( 1, 2 ), lda,tau, c( i1, i2 ), & ldc, work, lwork, iinfo ) end if end if work( 1 ) = lwkopt return - end subroutine stdlib_qormbr + end subroutine stdlib_${ri}$ormbr - pure subroutine stdlib_qormhr( side, trans, m, n, ilo, ihi, a, lda, tau, c,ldc, work, lwork, & + pure subroutine stdlib_${ri}$ormhr( side, trans, m, n, ilo, ihi, a, lda, tau, c,ldc, work, lwork, & !! DORMHR: overwrites the general real M-by-N matrix C with !! SIDE = 'L' SIDE = 'R' !! TRANS = 'N': Q * C C * Q @@ -55191,9 +55192,9 @@ module stdlib_linalg_lapack_q integer(ilp), intent(in) :: ihi, ilo, lda, ldc, lwork, m, n integer(ilp), intent(out) :: info ! Array Arguments - real(qp), intent(inout) :: a(lda,*), c(ldc,*) - real(qp), intent(in) :: tau(*) - real(qp), intent(out) :: work(*) + real(${rk}$), intent(inout) :: a(lda,*), c(ldc,*) + real(${rk}$), intent(in) :: tau(*) + real(${rk}$), intent(out) :: work(*) ! ===================================================================== ! Local Scalars logical(lk) :: left, lquery @@ -55265,14 +55266,14 @@ module stdlib_linalg_lapack_q i1 = 1 i2 = ilo + 1 end if - call stdlib_qormqr( side, trans, mi, ni, nh, a( ilo+1, ilo ), lda,tau( ilo ), c( i1, & + call stdlib_${ri}$ormqr( side, trans, mi, ni, nh, a( ilo+1, ilo ), lda,tau( ilo ), c( i1, & i2 ), ldc, work, lwork, iinfo ) work( 1 ) = lwkopt return - end subroutine stdlib_qormhr + end subroutine stdlib_${ri}$ormhr - pure subroutine stdlib_qorml2( side, trans, m, n, k, a, lda, tau, c, ldc,work, info ) + pure subroutine stdlib_${ri}$orml2( side, trans, m, n, k, a, lda, tau, c, ldc,work, info ) !! DORML2: overwrites the general real m by n matrix C with !! Q * C if SIDE = 'L' and TRANS = 'N', or !! Q**T* C if SIDE = 'L' and TRANS = 'T', or @@ -55291,15 +55292,15 @@ module stdlib_linalg_lapack_q integer(ilp), intent(out) :: info integer(ilp), intent(in) :: k, lda, ldc, m, n ! Array Arguments - real(qp), intent(inout) :: a(lda,*), c(ldc,*) - real(qp), intent(in) :: tau(*) - real(qp), intent(out) :: work(*) + real(${rk}$), intent(inout) :: a(lda,*), c(ldc,*) + real(${rk}$), intent(in) :: tau(*) + real(${rk}$), intent(out) :: work(*) ! ===================================================================== ! Local Scalars logical(lk) :: left, notran integer(ilp) :: i, i1, i2, i3, ic, jc, mi, ni, nq - real(qp) :: aii + real(${rk}$) :: aii ! Intrinsic Functions intrinsic :: max ! Executable Statements @@ -55363,15 +55364,15 @@ module stdlib_linalg_lapack_q ! apply h(i) aii = a( i, i ) a( i, i ) = one - call stdlib_qlarf( side, mi, ni, a( i, i ), lda, tau( i ),c( ic, jc ), ldc, work ) + call stdlib_${ri}$larf( side, mi, ni, a( i, i ), lda, tau( i ),c( ic, jc ), ldc, work ) a( i, i ) = aii end do return - end subroutine stdlib_qorml2 + end subroutine stdlib_${ri}$orml2 - pure subroutine stdlib_qormlq( side, trans, m, n, k, a, lda, tau, c, ldc,work, lwork, info ) + pure subroutine stdlib_${ri}$ormlq( side, trans, m, n, k, a, lda, tau, c, ldc,work, lwork, info ) !! DORMLQ: overwrites the general real M-by-N matrix C with !! SIDE = 'L' SIDE = 'R' !! TRANS = 'N': Q * C C * Q @@ -55390,9 +55391,9 @@ module stdlib_linalg_lapack_q integer(ilp), intent(out) :: info integer(ilp), intent(in) :: k, lda, ldc, lwork, m, n ! Array Arguments - real(qp), intent(inout) :: a(lda,*), c(ldc,*) - real(qp), intent(in) :: tau(*) - real(qp), intent(out) :: work(*) + real(${rk}$), intent(inout) :: a(lda,*), c(ldc,*) + real(${rk}$), intent(in) :: tau(*) + real(${rk}$), intent(out) :: work(*) ! ===================================================================== ! Parameters integer(ilp), parameter :: nbmax = 64 @@ -55464,7 +55465,7 @@ module stdlib_linalg_lapack_q end if if( nb=k ) then ! use unblocked code - call stdlib_qorml2( side, trans, m, n, k, a, lda, tau, c, ldc, work,iinfo ) + call stdlib_${ri}$orml2( side, trans, m, n, k, a, lda, tau, c, ldc, work,iinfo ) else ! use blocked code iwt = 1 + nw*nb @@ -55493,7 +55494,7 @@ module stdlib_linalg_lapack_q ib = min( nb, k-i+1 ) ! form the triangular factor of the block reflector ! h = h(i) h(i+1) . . . h(i+ib-1) - call stdlib_qlarft( 'FORWARD', 'ROWWISE', nq-i+1, ib, a( i, i ),lda, tau( i ), & + call stdlib_${ri}$larft( 'FORWARD', 'ROWWISE', nq-i+1, ib, a( i, i ),lda, tau( i ), & work( iwt ), ldt ) if( left ) then ! h or h**t is applied to c(i:m,1:n) @@ -55505,16 +55506,16 @@ module stdlib_linalg_lapack_q jc = i end if ! apply h or h**t - call stdlib_qlarfb( side, transt, 'FORWARD', 'ROWWISE', mi, ni, ib,a( i, i ), & + call stdlib_${ri}$larfb( side, transt, 'FORWARD', 'ROWWISE', mi, ni, ib,a( i, i ), & lda, work( iwt ), ldt,c( ic, jc ), ldc, work, ldwork ) end do end if work( 1 ) = lwkopt return - end subroutine stdlib_qormlq + end subroutine stdlib_${ri}$ormlq - pure subroutine stdlib_qormql( side, trans, m, n, k, a, lda, tau, c, ldc,work, lwork, info ) + pure subroutine stdlib_${ri}$ormql( side, trans, m, n, k, a, lda, tau, c, ldc,work, lwork, info ) !! DORMQL: overwrites the general real M-by-N matrix C with !! SIDE = 'L' SIDE = 'R' !! TRANS = 'N': Q * C C * Q @@ -55533,9 +55534,9 @@ module stdlib_linalg_lapack_q integer(ilp), intent(out) :: info integer(ilp), intent(in) :: k, lda, ldc, lwork, m, n ! Array Arguments - real(qp), intent(inout) :: a(lda,*), c(ldc,*) - real(qp), intent(in) :: tau(*) - real(qp), intent(out) :: work(*) + real(${rk}$), intent(inout) :: a(lda,*), c(ldc,*) + real(${rk}$), intent(in) :: tau(*) + real(${rk}$), intent(out) :: work(*) ! ===================================================================== ! Parameters integer(ilp), parameter :: nbmax = 64 @@ -55610,7 +55611,7 @@ module stdlib_linalg_lapack_q end if if( nb=k ) then ! use unblocked code - call stdlib_qorm2l( side, trans, m, n, k, a, lda, tau, c, ldc, work,iinfo ) + call stdlib_${ri}$orm2l( side, trans, m, n, k, a, lda, tau, c, ldc, work,iinfo ) else ! use blocked code iwt = 1 + nw*nb @@ -55632,7 +55633,7 @@ module stdlib_linalg_lapack_q ib = min( nb, k-i+1 ) ! form the triangular factor of the block reflector ! h = h(i+ib-1) . . . h(i+1) h(i) - call stdlib_qlarft( 'BACKWARD', 'COLUMNWISE', nq-k+i+ib-1, ib,a( 1, i ), lda, & + call stdlib_${ri}$larft( 'BACKWARD', 'COLUMNWISE', nq-k+i+ib-1, ib,a( 1, i ), lda, & tau( i ), work( iwt ), ldt ) if( left ) then ! h or h**t is applied to c(1:m-k+i+ib-1,1:n) @@ -55642,16 +55643,16 @@ module stdlib_linalg_lapack_q ni = n - k + i + ib - 1 end if ! apply h or h**t - call stdlib_qlarfb( side, trans, 'BACKWARD', 'COLUMNWISE', mi, ni,ib, a( 1, i ), & + call stdlib_${ri}$larfb( side, trans, 'BACKWARD', 'COLUMNWISE', mi, ni,ib, a( 1, i ), & lda, work( iwt ), ldt, c, ldc,work, ldwork ) end do end if work( 1 ) = lwkopt return - end subroutine stdlib_qormql + end subroutine stdlib_${ri}$ormql - pure subroutine stdlib_qormqr( side, trans, m, n, k, a, lda, tau, c, ldc,work, lwork, info ) + pure subroutine stdlib_${ri}$ormqr( side, trans, m, n, k, a, lda, tau, c, ldc,work, lwork, info ) !! DORMQR: overwrites the general real M-by-N matrix C with !! SIDE = 'L' SIDE = 'R' !! TRANS = 'N': Q * C C * Q @@ -55670,9 +55671,9 @@ module stdlib_linalg_lapack_q integer(ilp), intent(out) :: info integer(ilp), intent(in) :: k, lda, ldc, lwork, m, n ! Array Arguments - real(qp), intent(inout) :: a(lda,*), c(ldc,*) - real(qp), intent(in) :: tau(*) - real(qp), intent(out) :: work(*) + real(${rk}$), intent(inout) :: a(lda,*), c(ldc,*) + real(${rk}$), intent(in) :: tau(*) + real(${rk}$), intent(out) :: work(*) ! ===================================================================== ! Parameters integer(ilp), parameter :: nbmax = 64 @@ -55743,7 +55744,7 @@ module stdlib_linalg_lapack_q end if if( nb=k ) then ! use unblocked code - call stdlib_qorm2r( side, trans, m, n, k, a, lda, tau, c, ldc, work,iinfo ) + call stdlib_${ri}$orm2r( side, trans, m, n, k, a, lda, tau, c, ldc, work,iinfo ) else ! use blocked code iwt = 1 + nw*nb @@ -55767,7 +55768,7 @@ module stdlib_linalg_lapack_q ib = min( nb, k-i+1 ) ! form the triangular factor of the block reflector ! h = h(i) h(i+1) . . . h(i+ib-1) - call stdlib_qlarft( 'FORWARD', 'COLUMNWISE', nq-i+1, ib, a( i, i ),lda, tau( i ),& + call stdlib_${ri}$larft( 'FORWARD', 'COLUMNWISE', nq-i+1, ib, a( i, i ),lda, tau( i ),& work( iwt ), ldt ) if( left ) then ! h or h**t is applied to c(i:m,1:n) @@ -55779,16 +55780,16 @@ module stdlib_linalg_lapack_q jc = i end if ! apply h or h**t - call stdlib_qlarfb( side, trans, 'FORWARD', 'COLUMNWISE', mi, ni,ib, a( i, i ), & + call stdlib_${ri}$larfb( side, trans, 'FORWARD', 'COLUMNWISE', mi, ni,ib, a( i, i ), & lda, work( iwt ), ldt,c( ic, jc ), ldc, work, ldwork ) end do end if work( 1 ) = lwkopt return - end subroutine stdlib_qormqr + end subroutine stdlib_${ri}$ormqr - pure subroutine stdlib_qormr2( side, trans, m, n, k, a, lda, tau, c, ldc,work, info ) + pure subroutine stdlib_${ri}$ormr2( side, trans, m, n, k, a, lda, tau, c, ldc,work, info ) !! DORMR2: overwrites the general real m by n matrix C with !! Q * C if SIDE = 'L' and TRANS = 'N', or !! Q**T* C if SIDE = 'L' and TRANS = 'T', or @@ -55807,15 +55808,15 @@ module stdlib_linalg_lapack_q integer(ilp), intent(out) :: info integer(ilp), intent(in) :: k, lda, ldc, m, n ! Array Arguments - real(qp), intent(inout) :: a(lda,*), c(ldc,*) - real(qp), intent(in) :: tau(*) - real(qp), intent(out) :: work(*) + real(${rk}$), intent(inout) :: a(lda,*), c(ldc,*) + real(${rk}$), intent(in) :: tau(*) + real(${rk}$), intent(out) :: work(*) ! ===================================================================== ! Local Scalars logical(lk) :: left, notran integer(ilp) :: i, i1, i2, i3, mi, ni, nq - real(qp) :: aii + real(${rk}$) :: aii ! Intrinsic Functions intrinsic :: max ! Executable Statements @@ -55875,14 +55876,14 @@ module stdlib_linalg_lapack_q ! apply h(i) aii = a( i, nq-k+i ) a( i, nq-k+i ) = one - call stdlib_qlarf( side, mi, ni, a( i, 1 ), lda, tau( i ), c, ldc,work ) + call stdlib_${ri}$larf( side, mi, ni, a( i, 1 ), lda, tau( i ), c, ldc,work ) a( i, nq-k+i ) = aii end do return - end subroutine stdlib_qormr2 + end subroutine stdlib_${ri}$ormr2 - pure subroutine stdlib_qormr3( side, trans, m, n, k, l, a, lda, tau, c, ldc,work, info ) + pure subroutine stdlib_${ri}$ormr3( side, trans, m, n, k, l, a, lda, tau, c, ldc,work, info ) !! DORMR3: overwrites the general real m by n matrix C with !! Q * C if SIDE = 'L' and TRANS = 'N', or !! Q**T* C if SIDE = 'L' and TRANS = 'C', or @@ -55902,9 +55903,9 @@ module stdlib_linalg_lapack_q integer(ilp), intent(out) :: info integer(ilp), intent(in) :: k, l, lda, ldc, m, n ! Array Arguments - real(qp), intent(in) :: a(lda,*), tau(*) - real(qp), intent(inout) :: c(ldc,*) - real(qp), intent(out) :: work(*) + real(${rk}$), intent(in) :: a(lda,*), tau(*) + real(${rk}$), intent(inout) :: c(ldc,*) + real(${rk}$), intent(out) :: work(*) ! ===================================================================== ! Local Scalars logical(lk) :: left, notran @@ -55974,14 +55975,14 @@ module stdlib_linalg_lapack_q jc = i end if ! apply h(i) or h(i)**t - call stdlib_qlarz( side, mi, ni, l, a( i, ja ), lda, tau( i ),c( ic, jc ), ldc, & + call stdlib_${ri}$larz( side, mi, ni, l, a( i, ja ), lda, tau( i ),c( ic, jc ), ldc, & work ) end do return - end subroutine stdlib_qormr3 + end subroutine stdlib_${ri}$ormr3 - pure subroutine stdlib_qormrq( side, trans, m, n, k, a, lda, tau, c, ldc,work, lwork, info ) + pure subroutine stdlib_${ri}$ormrq( side, trans, m, n, k, a, lda, tau, c, ldc,work, lwork, info ) !! DORMRQ: overwrites the general real M-by-N matrix C with !! SIDE = 'L' SIDE = 'R' !! TRANS = 'N': Q * C C * Q @@ -56000,9 +56001,9 @@ module stdlib_linalg_lapack_q integer(ilp), intent(out) :: info integer(ilp), intent(in) :: k, lda, ldc, lwork, m, n ! Array Arguments - real(qp), intent(inout) :: a(lda,*), c(ldc,*) - real(qp), intent(in) :: tau(*) - real(qp), intent(out) :: work(*) + real(${rk}$), intent(inout) :: a(lda,*), c(ldc,*) + real(${rk}$), intent(in) :: tau(*) + real(${rk}$), intent(out) :: work(*) ! ===================================================================== ! Parameters integer(ilp), parameter :: nbmax = 64 @@ -56078,7 +56079,7 @@ module stdlib_linalg_lapack_q end if if( nb=k ) then ! use unblocked code - call stdlib_qormr2( side, trans, m, n, k, a, lda, tau, c, ldc, work,iinfo ) + call stdlib_${ri}$ormr2( side, trans, m, n, k, a, lda, tau, c, ldc, work,iinfo ) else ! use blocked code iwt = 1 + nw*nb @@ -56105,7 +56106,7 @@ module stdlib_linalg_lapack_q ib = min( nb, k-i+1 ) ! form the triangular factor of the block reflector ! h = h(i+ib-1) . . . h(i+1) h(i) - call stdlib_qlarft( 'BACKWARD', 'ROWWISE', nq-k+i+ib-1, ib,a( i, 1 ), lda, tau( & + call stdlib_${ri}$larft( 'BACKWARD', 'ROWWISE', nq-k+i+ib-1, ib,a( i, 1 ), lda, tau( & i ), work( iwt ), ldt ) if( left ) then ! h or h**t is applied to c(1:m-k+i+ib-1,1:n) @@ -56115,16 +56116,16 @@ module stdlib_linalg_lapack_q ni = n - k + i + ib - 1 end if ! apply h or h**t - call stdlib_qlarfb( side, transt, 'BACKWARD', 'ROWWISE', mi, ni,ib, a( i, 1 ), & + call stdlib_${ri}$larfb( side, transt, 'BACKWARD', 'ROWWISE', mi, ni,ib, a( i, 1 ), & lda, work( iwt ), ldt, c, ldc,work, ldwork ) end do end if work( 1 ) = lwkopt return - end subroutine stdlib_qormrq + end subroutine stdlib_${ri}$ormrq - pure subroutine stdlib_qormrz( side, trans, m, n, k, l, a, lda, tau, c, ldc,work, lwork, & + pure subroutine stdlib_${ri}$ormrz( side, trans, m, n, k, l, a, lda, tau, c, ldc,work, lwork, & !! DORMRZ: overwrites the general real M-by-N matrix C with !! SIDE = 'L' SIDE = 'R' !! TRANS = 'N': Q * C C * Q @@ -56143,9 +56144,9 @@ module stdlib_linalg_lapack_q integer(ilp), intent(out) :: info integer(ilp), intent(in) :: k, l, lda, ldc, lwork, m, n ! Array Arguments - real(qp), intent(inout) :: a(lda,*), c(ldc,*) - real(qp), intent(in) :: tau(*) - real(qp), intent(out) :: work(*) + real(${rk}$), intent(inout) :: a(lda,*), c(ldc,*) + real(${rk}$), intent(in) :: tau(*) + real(${rk}$), intent(out) :: work(*) ! ===================================================================== ! Parameters integer(ilp), parameter :: nbmax = 64 @@ -56224,7 +56225,7 @@ module stdlib_linalg_lapack_q end if if( nb=k ) then ! use unblocked code - call stdlib_qormr3( side, trans, m, n, k, l, a, lda, tau, c, ldc,work, iinfo ) + call stdlib_${ri}$ormr3( side, trans, m, n, k, l, a, lda, tau, c, ldc,work, iinfo ) else ! use blocked code @@ -56256,7 +56257,7 @@ module stdlib_linalg_lapack_q ib = min( nb, k-i+1 ) ! form the triangular factor of the block reflector ! h = h(i+ib-1) . . . h(i+1) h(i) - call stdlib_qlarzt( 'BACKWARD', 'ROWWISE', l, ib, a( i, ja ), lda,tau( i ), work(& + call stdlib_${ri}$larzt( 'BACKWARD', 'ROWWISE', l, ib, a( i, ja ), lda,tau( i ), work(& iwt ), ldt ) if( left ) then ! h or h**t is applied to c(i:m,1:n) @@ -56268,16 +56269,16 @@ module stdlib_linalg_lapack_q jc = i end if ! apply h or h**t - call stdlib_qlarzb( side, transt, 'BACKWARD', 'ROWWISE', mi, ni,ib, l, a( i, ja )& + call stdlib_${ri}$larzb( side, transt, 'BACKWARD', 'ROWWISE', mi, ni,ib, l, a( i, ja )& , lda, work( iwt ), ldt,c( ic, jc ), ldc, work, ldwork ) end do end if work( 1 ) = lwkopt return - end subroutine stdlib_qormrz + end subroutine stdlib_${ri}$ormrz - pure subroutine stdlib_qormtr( side, uplo, trans, m, n, a, lda, tau, c, ldc,work, lwork, & + pure subroutine stdlib_${ri}$ormtr( side, uplo, trans, m, n, a, lda, tau, c, ldc,work, lwork, & !! DORMTR: overwrites the general real M-by-N matrix C with !! SIDE = 'L' SIDE = 'R' !! TRANS = 'N': Q * C C * Q @@ -56296,9 +56297,9 @@ module stdlib_linalg_lapack_q integer(ilp), intent(out) :: info integer(ilp), intent(in) :: lda, ldc, lwork, m, n ! Array Arguments - real(qp), intent(inout) :: a(lda,*), c(ldc,*) - real(qp), intent(in) :: tau(*) - real(qp), intent(out) :: work(*) + real(${rk}$), intent(inout) :: a(lda,*), c(ldc,*) + real(${rk}$), intent(in) :: tau(*) + real(${rk}$), intent(out) :: work(*) ! ===================================================================== ! Local Scalars logical(lk) :: left, lquery, upper @@ -56373,11 +56374,11 @@ module stdlib_linalg_lapack_q ni = n - 1 end if if( upper ) then - ! q was determined by a call to stdlib_qsytrd with uplo = 'u' - call stdlib_qormql( side, trans, mi, ni, nq-1, a( 1, 2 ), lda, tau, c,ldc, work, & + ! q was determined by a call to stdlib_${ri}$sytrd with uplo = 'u' + call stdlib_${ri}$ormql( side, trans, mi, ni, nq-1, a( 1, 2 ), lda, tau, c,ldc, work, & lwork, iinfo ) else - ! q was determined by a call to stdlib_qsytrd with uplo = 'l' + ! q was determined by a call to stdlib_${ri}$sytrd with uplo = 'l' if( left ) then i1 = 2 i2 = 1 @@ -56385,15 +56386,15 @@ module stdlib_linalg_lapack_q i1 = 1 i2 = 2 end if - call stdlib_qormqr( side, trans, mi, ni, nq-1, a( 2, 1 ), lda, tau,c( i1, i2 ), ldc,& + call stdlib_${ri}$ormqr( side, trans, mi, ni, nq-1, a( 2, 1 ), lda, tau,c( i1, i2 ), ldc,& work, lwork, iinfo ) end if work( 1 ) = lwkopt return - end subroutine stdlib_qormtr + end subroutine stdlib_${ri}$ormtr - pure subroutine stdlib_qpbcon( uplo, n, kd, ab, ldab, anorm, rcond, work,iwork, info ) + pure subroutine stdlib_${ri}$pbcon( uplo, n, kd, ab, ldab, anorm, rcond, work,iwork, info ) !! DPBCON: estimates the reciprocal of the condition number (in the !! 1-norm) of a real symmetric positive definite band matrix using the !! Cholesky factorization A = U**T*U or A = L*L**T computed by DPBTRF. @@ -56407,19 +56408,19 @@ module stdlib_linalg_lapack_q character, intent(in) :: uplo integer(ilp), intent(out) :: info integer(ilp), intent(in) :: kd, ldab, n - real(qp), intent(in) :: anorm - real(qp), intent(out) :: rcond + real(${rk}$), intent(in) :: anorm + real(${rk}$), intent(out) :: rcond ! Array Arguments integer(ilp), intent(out) :: iwork(*) - real(qp), intent(in) :: ab(ldab,*) - real(qp), intent(out) :: work(*) + real(${rk}$), intent(in) :: ab(ldab,*) + real(${rk}$), intent(out) :: work(*) ! ===================================================================== ! Local Scalars logical(lk) :: upper character :: normin integer(ilp) :: ix, kase - real(qp) :: ainvnm, scale, scalel, scaleu, smlnum + real(${rk}$) :: ainvnm, scale, scalel, scaleu, smlnum ! Local Arrays integer(ilp) :: isave(3) ! Intrinsic Functions @@ -56451,36 +56452,36 @@ module stdlib_linalg_lapack_q else if( anorm==zero ) then return end if - smlnum = stdlib_qlamch( 'SAFE MINIMUM' ) + smlnum = stdlib_${ri}$lamch( 'SAFE MINIMUM' ) ! estimate the 1-norm of the inverse. kase = 0 normin = 'N' 10 continue - call stdlib_qlacn2( n, work( n+1 ), work, iwork, ainvnm, kase, isave ) + call stdlib_${ri}$lacn2( n, work( n+1 ), work, iwork, ainvnm, kase, isave ) if( kase/=0 ) then if( upper ) then ! multiply by inv(u**t). - call stdlib_qlatbs( 'UPPER', 'TRANSPOSE', 'NON-UNIT', normin, n,kd, ab, ldab, & + call stdlib_${ri}$latbs( 'UPPER', 'TRANSPOSE', 'NON-UNIT', normin, n,kd, ab, ldab, & work, scalel, work( 2*n+1 ),info ) normin = 'Y' ! multiply by inv(u). - call stdlib_qlatbs( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', normin, n,kd, ab, ldab, & + call stdlib_${ri}$latbs( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', normin, n,kd, ab, ldab, & work, scaleu, work( 2*n+1 ),info ) else ! multiply by inv(l). - call stdlib_qlatbs( 'LOWER', 'NO TRANSPOSE', 'NON-UNIT', normin, n,kd, ab, ldab, & + call stdlib_${ri}$latbs( 'LOWER', 'NO TRANSPOSE', 'NON-UNIT', normin, n,kd, ab, ldab, & work, scalel, work( 2*n+1 ),info ) normin = 'Y' ! multiply by inv(l**t). - call stdlib_qlatbs( 'LOWER', 'TRANSPOSE', 'NON-UNIT', normin, n,kd, ab, ldab, & + call stdlib_${ri}$latbs( 'LOWER', 'TRANSPOSE', 'NON-UNIT', normin, n,kd, ab, ldab, & work, scaleu, work( 2*n+1 ),info ) end if ! multiply by 1/scale if doing so will not cause overflow. scale = scalel*scaleu if( scale/=one ) then - ix = stdlib_iqamax( n, work, 1 ) + ix = stdlib_i${ri}$amax( n, work, 1 ) if( scaleeps .and. two*berr( j )<=lstres .and.count<=itmax ) then ! update solution and try again. - call stdlib_qpbtrs( uplo, n, kd, 1, afb, ldafb, work( n+1 ), n,info ) - call stdlib_qaxpy( n, one, work( n+1 ), 1, x( 1, j ), 1 ) + call stdlib_${ri}$pbtrs( uplo, n, kd, 1, afb, ldafb, work( n+1 ), n,info ) + call stdlib_${ri}$axpy( n, one, work( n+1 ), 1, x( 1, j ), 1 ) lstres = berr( j ) count = count + 1 go to 20 @@ -56731,7 +56732,7 @@ module stdlib_linalg_lapack_q ! 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_qlacn2 to estimate the infinity-norm of the matrix + ! 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 @@ -56743,12 +56744,12 @@ module stdlib_linalg_lapack_q end do kase = 0 100 continue - call stdlib_qlacn2( n, work( 2*n+1 ), work( n+1 ), iwork, ferr( j ),kase, isave ) + call stdlib_${ri}$lacn2( n, work( 2*n+1 ), work( n+1 ), iwork, ferr( j ),kase, isave ) if( kase/=0 ) then if( kase==1 ) then ! multiply by diag(w)*inv(a**t). - call stdlib_qpbtrs( uplo, n, kd, 1, afb, ldafb, work( n+1 ), n,info ) + call stdlib_${ri}$pbtrs( uplo, n, kd, 1, afb, ldafb, work( n+1 ), n,info ) do i = 1, n work( n+i ) = work( n+i )*work( i ) end do @@ -56757,7 +56758,7 @@ module stdlib_linalg_lapack_q do i = 1, n work( n+i ) = work( n+i )*work( i ) end do - call stdlib_qpbtrs( uplo, n, kd, 1, afb, ldafb, work( n+1 ), n,info ) + call stdlib_${ri}$pbtrs( uplo, n, kd, 1, afb, ldafb, work( n+1 ), n,info ) end if go to 100 end if @@ -56769,10 +56770,10 @@ module stdlib_linalg_lapack_q if( lstres/=zero )ferr( j ) = ferr( j ) / lstres end do loop_140 return - end subroutine stdlib_qpbrfs + end subroutine stdlib_${ri}$pbrfs - pure subroutine stdlib_qpbstf( uplo, n, kd, ab, ldab, info ) + pure subroutine stdlib_${ri}$pbstf( uplo, n, kd, ab, ldab, info ) !! DPBSTF: computes a split Cholesky factorization of a real !! symmetric positive definite band matrix A. !! This routine is designed to be used in conjunction with DSBGST. @@ -56790,13 +56791,13 @@ module stdlib_linalg_lapack_q integer(ilp), intent(out) :: info integer(ilp), intent(in) :: kd, ldab, n ! Array Arguments - real(qp), intent(inout) :: ab(ldab,*) + real(${rk}$), intent(inout) :: ab(ldab,*) ! ===================================================================== ! Local Scalars logical(lk) :: upper integer(ilp) :: j, kld, km, m - real(qp) :: ajj + real(${rk}$) :: ajj ! Intrinsic Functions intrinsic :: max,min,sqrt ! Executable Statements @@ -56832,8 +56833,8 @@ module stdlib_linalg_lapack_q km = min( j-1, kd ) ! compute elements j-km:j-1 of the j-th column and update the ! the leading submatrix within the band. - call stdlib_qscal( km, one / ajj, ab( kd+1-km, j ), 1 ) - call stdlib_qsyr( 'UPPER', km, -one, ab( kd+1-km, j ), 1,ab( kd+1, j-km ), kld ) + call stdlib_${ri}$scal( km, one / ajj, ab( kd+1-km, j ), 1 ) + call stdlib_${ri}$syr( 'UPPER', km, -one, ab( kd+1-km, j ), 1,ab( kd+1, j-km ), kld ) end do ! factorize the updated submatrix a(1:m,1:m) as u**t*u. @@ -56847,8 +56848,8 @@ module stdlib_linalg_lapack_q ! compute elements j+1:j+km of the j-th row and update the ! trailing submatrix within the band. if( km>0 ) then - call stdlib_qscal( km, one / ajj, ab( kd, j+1 ), kld ) - call stdlib_qsyr( 'UPPER', km, -one, ab( kd, j+1 ), kld,ab( kd+1, j+1 ), kld ) + call stdlib_${ri}$scal( km, one / ajj, ab( kd, j+1 ), kld ) + call stdlib_${ri}$syr( 'UPPER', km, -one, ab( kd, j+1 ), kld,ab( kd+1, j+1 ), kld ) end if end do @@ -56863,8 +56864,8 @@ module stdlib_linalg_lapack_q km = min( j-1, kd ) ! compute elements j-km:j-1 of the j-th row and update the ! trailing submatrix within the band. - call stdlib_qscal( km, one / ajj, ab( km+1, j-km ), kld ) - call stdlib_qsyr( 'LOWER', km, -one, ab( km+1, j-km ), kld,ab( 1, j-km ), kld ) + call stdlib_${ri}$scal( km, one / ajj, ab( km+1, j-km ), kld ) + call stdlib_${ri}$syr( 'LOWER', km, -one, ab( km+1, j-km ), kld,ab( 1, j-km ), kld ) end do ! factorize the updated submatrix a(1:m,1:m) as u**t*u. @@ -56878,8 +56879,8 @@ module stdlib_linalg_lapack_q ! compute elements j+1:j+km of the j-th column and update the ! trailing submatrix within the band. if( km>0 ) then - call stdlib_qscal( km, one / ajj, ab( 2, j ), 1 ) - call stdlib_qsyr( 'LOWER', km, -one, ab( 2, j ), 1,ab( 1, j+1 ), kld ) + call stdlib_${ri}$scal( km, one / ajj, ab( 2, j ), 1 ) + call stdlib_${ri}$syr( 'LOWER', km, -one, ab( 2, j ), 1,ab( 1, j+1 ), kld ) end if end do end if @@ -56887,10 +56888,10 @@ module stdlib_linalg_lapack_q 50 continue info = j return - end subroutine stdlib_qpbstf + end subroutine stdlib_${ri}$pbstf - pure subroutine stdlib_qpbsv( uplo, n, kd, nrhs, ab, ldab, b, ldb, info ) + pure subroutine stdlib_${ri}$pbsv( uplo, n, kd, nrhs, ab, ldab, b, ldb, info ) !! DPBSV: computes the solution to a real system of linear equations !! A * X = B, !! where A is an N-by-N symmetric positive definite band matrix and X @@ -56910,7 +56911,7 @@ module stdlib_linalg_lapack_q integer(ilp), intent(out) :: info integer(ilp), intent(in) :: kd, ldab, ldb, n, nrhs ! Array Arguments - real(qp), intent(inout) :: ab(ldab,*), b(ldb,*) + real(${rk}$), intent(inout) :: ab(ldab,*), b(ldb,*) ! ===================================================================== ! Intrinsic Functions intrinsic :: max @@ -56935,16 +56936,16 @@ module stdlib_linalg_lapack_q return end if ! compute the cholesky factorization a = u**t*u or a = l*l**t. - call stdlib_qpbtrf( uplo, n, kd, ab, ldab, info ) + call stdlib_${ri}$pbtrf( uplo, n, kd, ab, ldab, info ) if( info==0 ) then ! solve the system a*x = b, overwriting b with x. - call stdlib_qpbtrs( uplo, n, kd, nrhs, ab, ldab, b, ldb, info ) + call stdlib_${ri}$pbtrs( uplo, n, kd, nrhs, ab, ldab, b, ldb, info ) end if return - end subroutine stdlib_qpbsv + end subroutine stdlib_${ri}$pbsv - subroutine stdlib_qpbsvx( fact, uplo, n, kd, nrhs, ab, ldab, afb, ldafb,equed, s, b, ldb, x, & + subroutine stdlib_${ri}$pbsvx( fact, uplo, n, kd, nrhs, ab, ldab, afb, ldafb,equed, s, b, ldb, x, & !! DPBSVX: uses the Cholesky factorization A = U**T*U or A = L*L**T to !! compute the solution to a real system of linear equations !! A * X = B, @@ -56961,17 +56962,17 @@ module stdlib_linalg_lapack_q character, intent(in) :: fact, uplo integer(ilp), intent(out) :: info integer(ilp), intent(in) :: kd, ldab, ldafb, ldb, ldx, n, nrhs - real(qp), intent(out) :: rcond + real(${rk}$), intent(out) :: rcond ! Array Arguments integer(ilp), intent(out) :: iwork(*) - real(qp), intent(inout) :: ab(ldab,*), afb(ldafb,*), b(ldb,*), s(*) - real(qp), intent(out) :: berr(*), ferr(*), work(*), x(ldx,*) + real(${rk}$), intent(inout) :: ab(ldab,*), afb(ldafb,*), b(ldb,*), s(*) + real(${rk}$), intent(out) :: berr(*), ferr(*), work(*), x(ldx,*) ! ===================================================================== ! Local Scalars logical(lk) :: equil, nofact, rcequ, upper integer(ilp) :: i, infequ, j, j1, j2 - real(qp) :: amax, anorm, bignum, scond, smax, smin, smlnum + real(${rk}$) :: amax, anorm, bignum, scond, smax, smin, smlnum ! Intrinsic Functions intrinsic :: max,min ! Executable Statements @@ -56984,7 +56985,7 @@ module stdlib_linalg_lapack_q rcequ = .false. else rcequ = stdlib_lsame( equed, 'Y' ) - smlnum = stdlib_qlamch( 'SAFE MINIMUM' ) + smlnum = stdlib_${ri}$lamch( 'SAFE MINIMUM' ) bignum = one / smlnum end if ! test the input parameters. @@ -57035,10 +57036,10 @@ module stdlib_linalg_lapack_q end if if( equil ) then ! compute row and column scalings to equilibrate the matrix a. - call stdlib_qpbequ( uplo, n, kd, ab, ldab, s, scond, amax, infequ ) + call stdlib_${ri}$pbequ( uplo, n, kd, ab, ldab, s, scond, amax, infequ ) if( infequ==0 ) then ! equilibrate the matrix. - call stdlib_qlaqsb( uplo, n, kd, ab, ldab, s, scond, amax, equed ) + call stdlib_${ri}$laqsb( uplo, n, kd, ab, ldab, s, scond, amax, equed ) rcequ = stdlib_lsame( equed, 'Y' ) end if end if @@ -57055,16 +57056,16 @@ module stdlib_linalg_lapack_q if( upper ) then do j = 1, n j1 = max( j-kd, 1 ) - call stdlib_qcopy( j-j1+1, ab( kd+1-j+j1, j ), 1,afb( kd+1-j+j1, j ), 1 ) + call stdlib_${ri}$copy( j-j1+1, ab( kd+1-j+j1, j ), 1,afb( kd+1-j+j1, j ), 1 ) end do else do j = 1, n j2 = min( j+kd, n ) - call stdlib_qcopy( j2-j+1, ab( 1, j ), 1, afb( 1, j ), 1 ) + call stdlib_${ri}$copy( j2-j+1, ab( 1, j ), 1, afb( 1, j ), 1 ) end do end if - call stdlib_qpbtrf( uplo, n, kd, afb, ldafb, info ) + call stdlib_${ri}$pbtrf( uplo, n, kd, afb, ldafb, info ) ! return if info is non-zero. if( info>0 )then rcond = zero @@ -57072,15 +57073,15 @@ module stdlib_linalg_lapack_q end if end if ! compute the norm of the matrix a. - anorm = stdlib_qlansb( '1', uplo, n, kd, ab, ldab, work ) + anorm = stdlib_${ri}$lansb( '1', uplo, n, kd, ab, ldab, work ) ! compute the reciprocal of the condition number of a. - call stdlib_qpbcon( uplo, n, kd, afb, ldafb, anorm, rcond, work, iwork,info ) + call stdlib_${ri}$pbcon( uplo, n, kd, afb, ldafb, anorm, rcond, work, iwork,info ) ! compute the solution matrix x. - call stdlib_qlacpy( 'FULL', n, nrhs, b, ldb, x, ldx ) - call stdlib_qpbtrs( uplo, n, kd, nrhs, afb, ldafb, x, ldx, info ) + call stdlib_${ri}$lacpy( 'FULL', n, nrhs, b, ldb, x, ldx ) + call stdlib_${ri}$pbtrs( uplo, n, kd, nrhs, afb, ldafb, x, ldx, info ) ! use iterative refinement to improve the computed solution and ! compute error bounds and backward error estimates for it. - call stdlib_qpbrfs( uplo, n, kd, nrhs, ab, ldab, afb, ldafb, b, ldb, x,ldx, ferr, berr,& + call stdlib_${ri}$pbrfs( uplo, n, kd, nrhs, ab, ldab, afb, ldafb, b, ldb, x,ldx, ferr, berr,& work, iwork, info ) ! transform the solution matrix x to a solution of the original ! system. @@ -57095,12 +57096,12 @@ module stdlib_linalg_lapack_q end do end if ! set info = n+1 if the matrix is singular to working precision. - if( rcond0 ) then - call stdlib_qscal( kn, one / ajj, ab( kd, j+1 ), kld ) - call stdlib_qsyr( 'UPPER', kn, -one, ab( kd, j+1 ), kld,ab( kd+1, j+1 ), kld ) + call stdlib_${ri}$scal( kn, one / ajj, ab( kd, j+1 ), kld ) + call stdlib_${ri}$syr( 'UPPER', kn, -one, ab( kd, j+1 ), kld,ab( kd+1, j+1 ), kld ) end if end do @@ -57175,8 +57176,8 @@ module stdlib_linalg_lapack_q ! trailing submatrix within the band. kn = min( kd, n-j ) if( kn>0 ) then - call stdlib_qscal( kn, one / ajj, ab( 2, j ), 1 ) - call stdlib_qsyr( 'LOWER', kn, -one, ab( 2, j ), 1,ab( 1, j+1 ), kld ) + call stdlib_${ri}$scal( kn, one / ajj, ab( 2, j ), 1 ) + call stdlib_${ri}$syr( 'LOWER', kn, -one, ab( 2, j ), 1,ab( 1, j+1 ), kld ) end if end do end if @@ -57184,10 +57185,10 @@ module stdlib_linalg_lapack_q 30 continue info = j return - end subroutine stdlib_qpbtf2 + end subroutine stdlib_${ri}$pbtf2 - pure subroutine stdlib_qpbtrf( uplo, n, kd, ab, ldab, info ) + pure subroutine stdlib_${ri}$pbtrf( uplo, n, kd, ab, ldab, info ) !! DPBTRF: computes the Cholesky factorization of a real symmetric !! positive definite band matrix A. !! The factorization has the form @@ -57202,7 +57203,7 @@ module stdlib_linalg_lapack_q integer(ilp), intent(out) :: info integer(ilp), intent(in) :: kd, ldab, n ! Array Arguments - real(qp), intent(inout) :: ab(ldab,*) + real(${rk}$), intent(inout) :: ab(ldab,*) ! ===================================================================== ! Parameters integer(ilp), parameter :: nbmax = 32 @@ -57212,7 +57213,7 @@ module stdlib_linalg_lapack_q ! Local Scalars integer(ilp) :: i, i2, i3, ib, ii, j, jj, nb ! Local Arrays - real(qp) :: work(ldwork,nbmax) + real(${rk}$) :: work(ldwork,nbmax) ! Intrinsic Functions intrinsic :: min ! Executable Statements @@ -57241,7 +57242,7 @@ module stdlib_linalg_lapack_q nb = min( nb, nbmax ) if( nb<=1 .or. nb>kd ) then ! use unblocked code - call stdlib_qpbtf2( uplo, n, kd, ab, ldab, info ) + call stdlib_${ri}$pbtf2( uplo, n, kd, ab, ldab, info ) else ! use blocked code if( stdlib_lsame( uplo, 'U' ) ) then @@ -57258,7 +57259,7 @@ module stdlib_linalg_lapack_q loop_70: do i = 1, n, nb ib = min( nb, n-i+1 ) ! factorize the diagonal block - call stdlib_qpotf2( uplo, ib, ab( kd+1, i ), ldab-1, ii ) + call stdlib_${ri}$potf2( uplo, ib, ab( kd+1, i ), ldab-1, ii ) if( ii/=0 ) then info = i + ii - 1 go to 150 @@ -57279,10 +57280,10 @@ module stdlib_linalg_lapack_q i3 = min( ib, n-i-kd+1 ) if( i2>0 ) then ! update a12 - call stdlib_qtrsm( 'LEFT', 'UPPER', 'TRANSPOSE','NON-UNIT', ib, i2, one,& + call stdlib_${ri}$trsm( 'LEFT', 'UPPER', 'TRANSPOSE','NON-UNIT', ib, i2, one,& ab( kd+1, i ),ldab-1, ab( kd+1-ib, i+ib ), ldab-1 ) ! update a22 - call stdlib_qsyrk( 'UPPER', 'TRANSPOSE', i2, ib, -one,ab( kd+1-ib, i+ib & + call stdlib_${ri}$syrk( 'UPPER', 'TRANSPOSE', i2, ib, -one,ab( kd+1-ib, i+ib & ), ldab-1, one,ab( kd+1, i+ib ), ldab-1 ) end if if( i3>0 ) then @@ -57293,14 +57294,14 @@ module stdlib_linalg_lapack_q end do end do ! update a13 (in the work array). - call stdlib_qtrsm( 'LEFT', 'UPPER', 'TRANSPOSE','NON-UNIT', ib, i3, one,& + call stdlib_${ri}$trsm( 'LEFT', 'UPPER', 'TRANSPOSE','NON-UNIT', ib, i3, one,& ab( kd+1, i ),ldab-1, work, ldwork ) ! update a23 - if( i2>0 )call stdlib_qgemm( 'TRANSPOSE', 'NO TRANSPOSE', i2, i3,ib, -& + if( i2>0 )call stdlib_${ri}$gemm( 'TRANSPOSE', 'NO TRANSPOSE', i2, i3,ib, -& one, ab( kd+1-ib, i+ib ),ldab-1, work, ldwork, one,ab( 1+ib, i+kd ), & ldab-1 ) ! update a33 - call stdlib_qsyrk( 'UPPER', 'TRANSPOSE', i3, ib, -one,work, ldwork, one,& + call stdlib_${ri}$syrk( 'UPPER', 'TRANSPOSE', i3, ib, -one,work, ldwork, one,& ab( kd+1, i+kd ),ldab-1 ) ! copy the lower triangle of a13 back into place. do jj = 1, i3 @@ -57325,7 +57326,7 @@ module stdlib_linalg_lapack_q loop_140: do i = 1, n, nb ib = min( nb, n-i+1 ) ! factorize the diagonal block - call stdlib_qpotf2( uplo, ib, ab( 1, i ), ldab-1, ii ) + call stdlib_${ri}$potf2( uplo, ib, ab( 1, i ), ldab-1, ii ) if( ii/=0 ) then info = i + ii - 1 go to 150 @@ -57346,10 +57347,10 @@ module stdlib_linalg_lapack_q i3 = min( ib, n-i-kd+1 ) if( i2>0 ) then ! update a21 - call stdlib_qtrsm( 'RIGHT', 'LOWER', 'TRANSPOSE','NON-UNIT', i2, ib, & + call stdlib_${ri}$trsm( 'RIGHT', 'LOWER', 'TRANSPOSE','NON-UNIT', i2, ib, & one, ab( 1, i ),ldab-1, ab( 1+ib, i ), ldab-1 ) ! update a22 - call stdlib_qsyrk( 'LOWER', 'NO TRANSPOSE', i2, ib, -one,ab( 1+ib, i ), & + call stdlib_${ri}$syrk( 'LOWER', 'NO TRANSPOSE', i2, ib, -one,ab( 1+ib, i ), & ldab-1, one,ab( 1, i+ib ), ldab-1 ) end if if( i3>0 ) then @@ -57360,14 +57361,14 @@ module stdlib_linalg_lapack_q end do end do ! update a31 (in the work array). - call stdlib_qtrsm( 'RIGHT', 'LOWER', 'TRANSPOSE','NON-UNIT', i3, ib, & + call stdlib_${ri}$trsm( 'RIGHT', 'LOWER', 'TRANSPOSE','NON-UNIT', i3, ib, & one, ab( 1, i ),ldab-1, work, ldwork ) ! update a32 - if( i2>0 )call stdlib_qgemm( 'NO TRANSPOSE', 'TRANSPOSE', i3, i2,ib, -& + if( i2>0 )call stdlib_${ri}$gemm( 'NO TRANSPOSE', 'TRANSPOSE', i3, i2,ib, -& one, work, ldwork,ab( 1+ib, i ), ldab-1, one,ab( 1+kd-ib, i+ib ), ldab-& 1 ) ! update a33 - call stdlib_qsyrk( 'LOWER', 'NO TRANSPOSE', i3, ib, -one,work, ldwork, & + call stdlib_${ri}$syrk( 'LOWER', 'NO TRANSPOSE', i3, ib, -one,work, ldwork, & one, ab( 1, i+kd ),ldab-1 ) ! copy the upper triangle of a31 back into place. do jj = 1, ib @@ -57383,10 +57384,10 @@ module stdlib_linalg_lapack_q return 150 continue return - end subroutine stdlib_qpbtrf + end subroutine stdlib_${ri}$pbtrf - pure subroutine stdlib_qpbtrs( uplo, n, kd, nrhs, ab, ldab, b, ldb, info ) + pure subroutine stdlib_${ri}$pbtrs( uplo, n, kd, nrhs, ab, ldab, b, ldb, info ) !! DPBTRS: solves a system of linear equations A*X = B with a symmetric !! positive definite band matrix A using the Cholesky factorization !! A = U**T*U or A = L*L**T computed by DPBTRF. @@ -57398,8 +57399,8 @@ module stdlib_linalg_lapack_q integer(ilp), intent(out) :: info integer(ilp), intent(in) :: kd, ldab, ldb, n, nrhs ! Array Arguments - real(qp), intent(in) :: ab(ldab,*) - real(qp), intent(inout) :: b(ldb,*) + real(${rk}$), intent(in) :: ab(ldab,*) + real(${rk}$), intent(inout) :: b(ldb,*) ! ===================================================================== ! Local Scalars logical(lk) :: upper @@ -57433,28 +57434,28 @@ module stdlib_linalg_lapack_q ! solve a*x = b where a = u**t *u. do j = 1, nrhs ! solve u**t *x = b, overwriting b with x. - call stdlib_qtbsv( 'UPPER', 'TRANSPOSE', 'NON-UNIT', n, kd, ab,ldab, b( 1, j ), & + call stdlib_${ri}$tbsv( 'UPPER', 'TRANSPOSE', 'NON-UNIT', n, kd, ab,ldab, b( 1, j ), & 1 ) ! solve u*x = b, overwriting b with x. - call stdlib_qtbsv( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', n, kd, ab,ldab, b( 1, j )& + call stdlib_${ri}$tbsv( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', n, kd, ab,ldab, b( 1, j )& , 1 ) end do else ! solve a*x = b where a = l*l**t. do j = 1, nrhs ! solve l*x = b, overwriting b with x. - call stdlib_qtbsv( 'LOWER', 'NO TRANSPOSE', 'NON-UNIT', n, kd, ab,ldab, b( 1, j )& + call stdlib_${ri}$tbsv( 'LOWER', 'NO TRANSPOSE', 'NON-UNIT', n, kd, ab,ldab, b( 1, j )& , 1 ) ! solve l**t *x = b, overwriting b with x. - call stdlib_qtbsv( 'LOWER', 'TRANSPOSE', 'NON-UNIT', n, kd, ab,ldab, b( 1, j ), & + call stdlib_${ri}$tbsv( 'LOWER', 'TRANSPOSE', 'NON-UNIT', n, kd, ab,ldab, b( 1, j ), & 1 ) end do end if return - end subroutine stdlib_qpbtrs + end subroutine stdlib_${ri}$pbtrs - pure subroutine stdlib_qpftrf( transr, uplo, n, a, info ) + pure subroutine stdlib_${ri}$pftrf( transr, uplo, n, a, info ) !! DPFTRF: computes the Cholesky factorization of a real symmetric !! positive definite matrix A. !! The factorization has the form @@ -57470,7 +57471,7 @@ module stdlib_linalg_lapack_q integer(ilp), intent(in) :: n integer(ilp), intent(out) :: info ! Array Arguments - real(qp), intent(inout) :: a(0:*) + real(${rk}$), intent(inout) :: a(0:*) ! ===================================================================== ! Local Scalars @@ -57521,23 +57522,23 @@ module stdlib_linalg_lapack_q ! srpa for lower, normal and n is odd ( a(0:n-1,0:n1-1) ) ! t1 -> a(0,0), t2 -> a(0,1), s -> a(n1,0) ! t1 -> a(0), t2 -> a(n), s -> a(n1) - call stdlib_qpotrf( 'L', n1, a( 0 ), n, info ) + call stdlib_${ri}$potrf( 'L', n1, a( 0 ), n, info ) if( info>0 )return - call stdlib_qtrsm( 'R', 'L', 'T', 'N', n2, n1, one, a( 0 ), n,a( n1 ), n ) + call stdlib_${ri}$trsm( 'R', 'L', 'T', 'N', n2, n1, one, a( 0 ), n,a( n1 ), n ) - call stdlib_qsyrk( 'U', 'N', n2, n1, -one, a( n1 ), n, one,a( n ), n ) - call stdlib_qpotrf( 'U', n2, a( n ), n, info ) + call stdlib_${ri}$syrk( 'U', 'N', n2, n1, -one, a( n1 ), n, one,a( n ), n ) + call stdlib_${ri}$potrf( 'U', n2, a( n ), n, info ) if( info>0 )info = info + n1 else ! srpa for upper, normal and n is odd ( a(0:n-1,0:n2-1) ! t1 -> a(n1+1,0), t2 -> a(n1,0), s -> a(0,0) ! t1 -> a(n2), t2 -> a(n1), s -> a(0) - call stdlib_qpotrf( 'L', n1, a( n2 ), n, info ) + call stdlib_${ri}$potrf( 'L', n1, a( n2 ), n, info ) if( info>0 )return - call stdlib_qtrsm( 'L', 'L', 'N', 'N', n1, n2, one, a( n2 ), n,a( 0 ), n ) + call stdlib_${ri}$trsm( 'L', 'L', 'N', 'N', n1, n2, one, a( n2 ), n,a( 0 ), n ) - call stdlib_qsyrk( 'U', 'T', n2, n1, -one, a( 0 ), n, one,a( n1 ), n ) - call stdlib_qpotrf( 'U', n2, a( n1 ), n, info ) + call stdlib_${ri}$syrk( 'U', 'T', n2, n1, -one, a( 0 ), n, one,a( n1 ), n ) + call stdlib_${ri}$potrf( 'U', n2, a( n1 ), n, info ) if( info>0 )info = info + n1 end if else @@ -57546,25 +57547,25 @@ module stdlib_linalg_lapack_q ! srpa for lower, transpose and n is odd ! t1 -> a(0,0) , t2 -> a(1,0) , s -> a(0,n1) ! t1 -> a(0+0) , t2 -> a(1+0) , s -> a(0+n1*n1); lda=n1 - call stdlib_qpotrf( 'U', n1, a( 0 ), n1, info ) + call stdlib_${ri}$potrf( 'U', n1, a( 0 ), n1, info ) if( info>0 )return - call stdlib_qtrsm( 'L', 'U', 'T', 'N', n1, n2, one, a( 0 ), n1,a( n1*n1 ), n1 & + call stdlib_${ri}$trsm( 'L', 'U', 'T', 'N', n1, n2, one, a( 0 ), n1,a( n1*n1 ), n1 & ) - call stdlib_qsyrk( 'L', 'T', n2, n1, -one, a( n1*n1 ), n1, one,a( 1 ), n1 ) + call stdlib_${ri}$syrk( 'L', 'T', n2, n1, -one, a( n1*n1 ), n1, one,a( 1 ), n1 ) - call stdlib_qpotrf( 'L', n2, a( 1 ), n1, info ) + call stdlib_${ri}$potrf( 'L', n2, a( 1 ), n1, info ) if( info>0 )info = info + n1 else ! srpa for upper, transpose and n is odd ! t1 -> a(0,n1+1), t2 -> a(0,n1), s -> a(0,0) ! t1 -> a(n2*n2), t2 -> a(n1*n2), s -> a(0); lda = n2 - call stdlib_qpotrf( 'U', n1, a( n2*n2 ), n2, info ) + call stdlib_${ri}$potrf( 'U', n1, a( n2*n2 ), n2, info ) if( info>0 )return - call stdlib_qtrsm( 'R', 'U', 'N', 'N', n2, n1, one, a( n2*n2 ),n2, a( 0 ), n2 & + call stdlib_${ri}$trsm( 'R', 'U', 'N', 'N', n2, n1, one, a( n2*n2 ),n2, a( 0 ), n2 & ) - call stdlib_qsyrk( 'L', 'N', n2, n1, -one, a( 0 ), n2, one,a( n1*n2 ), n2 ) + call stdlib_${ri}$syrk( 'L', 'N', n2, n1, -one, a( 0 ), n2, one,a( n1*n2 ), n2 ) - call stdlib_qpotrf( 'L', n2, a( n1*n2 ), n2, info ) + call stdlib_${ri}$potrf( 'L', n2, a( n1*n2 ), n2, info ) if( info>0 )info = info + n1 end if end if @@ -57576,25 +57577,25 @@ module stdlib_linalg_lapack_q ! srpa for lower, normal, and n is even ( a(0:n,0:k-1) ) ! t1 -> a(1,0), t2 -> a(0,0), s -> a(k+1,0) ! t1 -> a(1), t2 -> a(0), s -> a(k+1) - call stdlib_qpotrf( 'L', k, a( 1 ), n+1, info ) + call stdlib_${ri}$potrf( 'L', k, a( 1 ), n+1, info ) if( info>0 )return - call stdlib_qtrsm( 'R', 'L', 'T', 'N', k, k, one, a( 1 ), n+1,a( k+1 ), n+1 ) + call stdlib_${ri}$trsm( 'R', 'L', 'T', 'N', k, k, one, a( 1 ), n+1,a( k+1 ), n+1 ) - call stdlib_qsyrk( 'U', 'N', k, k, -one, a( k+1 ), n+1, one,a( 0 ), n+1 ) + call stdlib_${ri}$syrk( 'U', 'N', k, k, -one, a( k+1 ), n+1, one,a( 0 ), n+1 ) - call stdlib_qpotrf( 'U', k, a( 0 ), n+1, info ) + call stdlib_${ri}$potrf( 'U', k, a( 0 ), n+1, info ) if( info>0 )info = info + k else ! srpa for upper, normal, and n is even ( a(0:n,0:k-1) ) ! t1 -> a(k+1,0) , t2 -> a(k,0), s -> a(0,0) ! t1 -> a(k+1), t2 -> a(k), s -> a(0) - call stdlib_qpotrf( 'L', k, a( k+1 ), n+1, info ) + call stdlib_${ri}$potrf( 'L', k, a( k+1 ), n+1, info ) if( info>0 )return - call stdlib_qtrsm( 'L', 'L', 'N', 'N', k, k, one, a( k+1 ),n+1, a( 0 ), n+1 ) + call stdlib_${ri}$trsm( 'L', 'L', 'N', 'N', k, k, one, a( k+1 ),n+1, a( 0 ), n+1 ) - call stdlib_qsyrk( 'U', 'T', k, k, -one, a( 0 ), n+1, one,a( k ), n+1 ) + call stdlib_${ri}$syrk( 'U', 'T', k, k, -one, a( 0 ), n+1, one,a( k ), n+1 ) - call stdlib_qpotrf( 'U', k, a( k ), n+1, info ) + call stdlib_${ri}$potrf( 'U', k, a( k ), n+1, info ) if( info>0 )info = info + k end if else @@ -57603,33 +57604,33 @@ module stdlib_linalg_lapack_q ! srpa for lower, transpose and n is even (see paper) ! t1 -> b(0,1), t2 -> b(0,0), s -> b(0,k+1) ! t1 -> a(0+k), t2 -> a(0+0), s -> a(0+k*(k+1)); lda=k - call stdlib_qpotrf( 'U', k, a( 0+k ), k, info ) + call stdlib_${ri}$potrf( 'U', k, a( 0+k ), k, info ) if( info>0 )return - call stdlib_qtrsm( 'L', 'U', 'T', 'N', k, k, one, a( k ), n1,a( k*( k+1 ) ), & + call stdlib_${ri}$trsm( 'L', 'U', 'T', 'N', k, k, one, a( k ), n1,a( k*( k+1 ) ), & k ) - call stdlib_qsyrk( 'L', 'T', k, k, -one, a( k*( k+1 ) ), k, one,a( 0 ), k ) + call stdlib_${ri}$syrk( 'L', 'T', k, k, -one, a( k*( k+1 ) ), k, one,a( 0 ), k ) - call stdlib_qpotrf( 'L', k, a( 0 ), k, info ) + call stdlib_${ri}$potrf( 'L', k, a( 0 ), k, info ) if( info>0 )info = info + k else ! srpa for upper, transpose and n is even (see paper) ! t1 -> b(0,k+1), t2 -> b(0,k), s -> b(0,0) ! t1 -> a(0+k*(k+1)), t2 -> a(0+k*k), s -> a(0+0)); lda=k - call stdlib_qpotrf( 'U', k, a( k*( k+1 ) ), k, info ) + call stdlib_${ri}$potrf( 'U', k, a( k*( k+1 ) ), k, info ) if( info>0 )return - call stdlib_qtrsm( 'R', 'U', 'N', 'N', k, k, one,a( k*( k+1 ) ), k, a( 0 ), k & + call stdlib_${ri}$trsm( 'R', 'U', 'N', 'N', k, k, one,a( k*( k+1 ) ), k, a( 0 ), k & ) - call stdlib_qsyrk( 'L', 'N', k, k, -one, a( 0 ), k, one,a( k*k ), k ) - call stdlib_qpotrf( 'L', k, a( k*k ), k, info ) + call stdlib_${ri}$syrk( 'L', 'N', k, k, -one, a( 0 ), k, one,a( k*k ), k ) + call stdlib_${ri}$potrf( 'L', k, a( k*k ), k, info ) if( info>0 )info = info + k end if end if end if return - end subroutine stdlib_qpftrf + end subroutine stdlib_${ri}$pftrf - pure subroutine stdlib_qpftri( transr, uplo, n, a, info ) + pure subroutine stdlib_${ri}$pftri( transr, uplo, n, a, info ) !! DPFTRI: computes the inverse of a (real) symmetric positive definite !! matrix A using the Cholesky factorization A = U**T*U or A = L*L**T !! computed by DPFTRF. @@ -57641,7 +57642,7 @@ module stdlib_linalg_lapack_q integer(ilp), intent(out) :: info integer(ilp), intent(in) :: n ! Array Arguments - real(qp), intent(inout) :: a(0:*) + real(${rk}$), intent(inout) :: a(0:*) ! ===================================================================== ! Local Scalars @@ -57668,7 +57669,7 @@ module stdlib_linalg_lapack_q ! quick return if possible if( n==0 )return ! invert the triangular cholesky factor u or l. - call stdlib_qtftri( transr, uplo, 'N', n, a, info ) + call stdlib_${ri}$tftri( transr, uplo, 'N', n, a, info ) if( info>0 )return ! if n is odd, set nisodd = .true. ! if n is even, set k = n/2 and nisodd = .false. @@ -57696,41 +57697,41 @@ module stdlib_linalg_lapack_q ! srpa for lower, normal and n is odd ( a(0:n-1,0:n1-1) ) ! t1 -> a(0,0), t2 -> a(0,1), s -> a(n1,0) ! t1 -> a(0), t2 -> a(n), s -> a(n1) - call stdlib_qlauum( 'L', n1, a( 0 ), n, info ) - call stdlib_qsyrk( 'L', 'T', n1, n2, one, a( n1 ), n, one,a( 0 ), n ) - call stdlib_qtrmm( 'L', 'U', 'N', 'N', n2, n1, one, a( n ), n,a( n1 ), n ) + call stdlib_${ri}$lauum( 'L', n1, a( 0 ), n, info ) + call stdlib_${ri}$syrk( 'L', 'T', n1, n2, one, a( n1 ), n, one,a( 0 ), n ) + call stdlib_${ri}$trmm( 'L', 'U', 'N', 'N', n2, n1, one, a( n ), n,a( n1 ), n ) - call stdlib_qlauum( 'U', n2, a( n ), n, info ) + call stdlib_${ri}$lauum( 'U', n2, a( n ), n, info ) else ! srpa for upper, normal and n is odd ( a(0:n-1,0:n2-1) ! t1 -> a(n1+1,0), t2 -> a(n1,0), s -> a(0,0) ! t1 -> a(n2), t2 -> a(n1), s -> a(0) - call stdlib_qlauum( 'L', n1, a( n2 ), n, info ) - call stdlib_qsyrk( 'L', 'N', n1, n2, one, a( 0 ), n, one,a( n2 ), n ) - call stdlib_qtrmm( 'R', 'U', 'T', 'N', n1, n2, one, a( n1 ), n,a( 0 ), n ) + call stdlib_${ri}$lauum( 'L', n1, a( n2 ), n, info ) + call stdlib_${ri}$syrk( 'L', 'N', n1, n2, one, a( 0 ), n, one,a( n2 ), n ) + call stdlib_${ri}$trmm( 'R', 'U', 'T', 'N', n1, n2, one, a( n1 ), n,a( 0 ), n ) - call stdlib_qlauum( 'U', n2, a( n1 ), n, info ) + call stdlib_${ri}$lauum( 'U', n2, a( n1 ), n, info ) end if else ! n is odd and transr = 't' if( lower ) then ! srpa for lower, transpose, and n is odd ! t1 -> a(0), t2 -> a(1), s -> a(0+n1*n1) - call stdlib_qlauum( 'U', n1, a( 0 ), n1, info ) - call stdlib_qsyrk( 'U', 'N', n1, n2, one, a( n1*n1 ), n1, one,a( 0 ), n1 ) + call stdlib_${ri}$lauum( 'U', n1, a( 0 ), n1, info ) + call stdlib_${ri}$syrk( 'U', 'N', n1, n2, one, a( n1*n1 ), n1, one,a( 0 ), n1 ) - call stdlib_qtrmm( 'R', 'L', 'N', 'N', n1, n2, one, a( 1 ), n1,a( n1*n1 ), n1 & + call stdlib_${ri}$trmm( 'R', 'L', 'N', 'N', n1, n2, one, a( 1 ), n1,a( n1*n1 ), n1 & ) - call stdlib_qlauum( 'L', n2, a( 1 ), n1, info ) + call stdlib_${ri}$lauum( 'L', n2, a( 1 ), n1, info ) else ! srpa for upper, transpose, and n is odd ! t1 -> a(0+n2*n2), t2 -> a(0+n1*n2), s -> a(0) - call stdlib_qlauum( 'U', n1, a( n2*n2 ), n2, info ) - call stdlib_qsyrk( 'U', 'T', n1, n2, one, a( 0 ), n2, one,a( n2*n2 ), n2 ) + call stdlib_${ri}$lauum( 'U', n1, a( n2*n2 ), n2, info ) + call stdlib_${ri}$syrk( 'U', 'T', n1, n2, one, a( 0 ), n2, one,a( n2*n2 ), n2 ) - call stdlib_qtrmm( 'L', 'L', 'T', 'N', n2, n1, one, a( n1*n2 ),n2, a( 0 ), n2 & + call stdlib_${ri}$trmm( 'L', 'L', 'T', 'N', n2, n1, one, a( n1*n2 ),n2, a( 0 ), n2 & ) - call stdlib_qlauum( 'L', n2, a( n1*n2 ), n2, info ) + call stdlib_${ri}$lauum( 'L', n2, a( n1*n2 ), n2, info ) end if end if else @@ -57741,22 +57742,22 @@ module stdlib_linalg_lapack_q ! srpa for lower, normal, and n is even ( a(0:n,0:k-1) ) ! t1 -> a(1,0), t2 -> a(0,0), s -> a(k+1,0) ! t1 -> a(1), t2 -> a(0), s -> a(k+1) - call stdlib_qlauum( 'L', k, a( 1 ), n+1, info ) - call stdlib_qsyrk( 'L', 'T', k, k, one, a( k+1 ), n+1, one,a( 1 ), n+1 ) + call stdlib_${ri}$lauum( 'L', k, a( 1 ), n+1, info ) + call stdlib_${ri}$syrk( 'L', 'T', k, k, one, a( k+1 ), n+1, one,a( 1 ), n+1 ) - call stdlib_qtrmm( 'L', 'U', 'N', 'N', k, k, one, a( 0 ), n+1,a( k+1 ), n+1 ) + call stdlib_${ri}$trmm( 'L', 'U', 'N', 'N', k, k, one, a( 0 ), n+1,a( k+1 ), n+1 ) - call stdlib_qlauum( 'U', k, a( 0 ), n+1, info ) + call stdlib_${ri}$lauum( 'U', k, a( 0 ), n+1, info ) else ! srpa for upper, normal, and n is even ( a(0:n,0:k-1) ) ! t1 -> a(k+1,0) , t2 -> a(k,0), s -> a(0,0) ! t1 -> a(k+1), t2 -> a(k), s -> a(0) - call stdlib_qlauum( 'L', k, a( k+1 ), n+1, info ) - call stdlib_qsyrk( 'L', 'N', k, k, one, a( 0 ), n+1, one,a( k+1 ), n+1 ) + call stdlib_${ri}$lauum( 'L', k, a( k+1 ), n+1, info ) + call stdlib_${ri}$syrk( 'L', 'N', k, k, one, a( 0 ), n+1, one,a( k+1 ), n+1 ) - call stdlib_qtrmm( 'R', 'U', 'T', 'N', k, k, one, a( k ), n+1,a( 0 ), n+1 ) + call stdlib_${ri}$trmm( 'R', 'U', 'T', 'N', k, k, one, a( k ), n+1,a( 0 ), n+1 ) - call stdlib_qlauum( 'U', k, a( k ), n+1, info ) + call stdlib_${ri}$lauum( 'U', k, a( k ), n+1, info ) end if else ! n is even and transr = 't' @@ -57764,30 +57765,30 @@ module stdlib_linalg_lapack_q ! srpa for lower, transpose, and n is even (see paper) ! t1 -> b(0,1), t2 -> b(0,0), s -> b(0,k+1), ! t1 -> a(0+k), t2 -> a(0+0), s -> a(0+k*(k+1)); lda=k - call stdlib_qlauum( 'U', k, a( k ), k, info ) - call stdlib_qsyrk( 'U', 'N', k, k, one, a( k*( k+1 ) ), k, one,a( k ), k ) + call stdlib_${ri}$lauum( 'U', k, a( k ), k, info ) + call stdlib_${ri}$syrk( 'U', 'N', k, k, one, a( k*( k+1 ) ), k, one,a( k ), k ) - call stdlib_qtrmm( 'R', 'L', 'N', 'N', k, k, one, a( 0 ), k,a( k*( k+1 ) ), k & + call stdlib_${ri}$trmm( 'R', 'L', 'N', 'N', k, k, one, a( 0 ), k,a( k*( k+1 ) ), k & ) - call stdlib_qlauum( 'L', k, a( 0 ), k, info ) + call stdlib_${ri}$lauum( 'L', k, a( 0 ), k, info ) else ! srpa for upper, transpose, and n is even (see paper) ! t1 -> b(0,k+1), t2 -> b(0,k), s -> b(0,0), ! t1 -> a(0+k*(k+1)), t2 -> a(0+k*k), s -> a(0+0)); lda=k - call stdlib_qlauum( 'U', k, a( k*( k+1 ) ), k, info ) - call stdlib_qsyrk( 'U', 'T', k, k, one, a( 0 ), k, one,a( k*( k+1 ) ), k ) + call stdlib_${ri}$lauum( 'U', k, a( k*( k+1 ) ), k, info ) + call stdlib_${ri}$syrk( 'U', 'T', k, k, one, a( 0 ), k, one,a( k*( k+1 ) ), k ) - call stdlib_qtrmm( 'L', 'L', 'T', 'N', k, k, one, a( k*k ), k,a( 0 ), k ) + call stdlib_${ri}$trmm( 'L', 'L', 'T', 'N', k, k, one, a( k*k ), k,a( 0 ), k ) - call stdlib_qlauum( 'L', k, a( k*k ), k, info ) + call stdlib_${ri}$lauum( 'L', k, a( k*k ), k, info ) end if end if end if return - end subroutine stdlib_qpftri + end subroutine stdlib_${ri}$pftri - pure subroutine stdlib_qpftrs( transr, uplo, n, nrhs, a, b, ldb, info ) + pure subroutine stdlib_${ri}$pftrs( transr, uplo, n, nrhs, a, b, ldb, info ) !! DPFTRS: solves a system of linear equations A*X = B with a symmetric !! positive definite matrix A using the Cholesky factorization !! A = U**T*U or A = L*L**T computed by DPFTRF. @@ -57799,8 +57800,8 @@ module stdlib_linalg_lapack_q integer(ilp), intent(out) :: info integer(ilp), intent(in) :: ldb, n, nrhs ! Array Arguments - real(qp), intent(in) :: a(0:*) - real(qp), intent(inout) :: b(ldb,*) + real(${rk}$), intent(in) :: a(0:*) + real(${rk}$), intent(inout) :: b(ldb,*) ! ===================================================================== ! Local Scalars @@ -57831,17 +57832,17 @@ module stdlib_linalg_lapack_q if( n==0 .or. nrhs==0 )return ! start execution: there are two triangular solves if( lower ) then - call stdlib_qtfsm( transr, 'L', uplo, 'N', 'N', n, nrhs, one, a, b,ldb ) - call stdlib_qtfsm( transr, 'L', uplo, 'T', 'N', n, nrhs, one, a, b,ldb ) + call stdlib_${ri}$tfsm( transr, 'L', uplo, 'N', 'N', n, nrhs, one, a, b,ldb ) + call stdlib_${ri}$tfsm( transr, 'L', uplo, 'T', 'N', n, nrhs, one, a, b,ldb ) else - call stdlib_qtfsm( transr, 'L', uplo, 'T', 'N', n, nrhs, one, a, b,ldb ) - call stdlib_qtfsm( transr, 'L', uplo, 'N', 'N', n, nrhs, one, a, b,ldb ) + call stdlib_${ri}$tfsm( transr, 'L', uplo, 'T', 'N', n, nrhs, one, a, b,ldb ) + call stdlib_${ri}$tfsm( transr, 'L', uplo, 'N', 'N', n, nrhs, one, a, b,ldb ) end if return - end subroutine stdlib_qpftrs + end subroutine stdlib_${ri}$pftrs - pure subroutine stdlib_qpocon( uplo, n, a, lda, anorm, rcond, work, iwork,info ) + pure subroutine stdlib_${ri}$pocon( uplo, n, a, lda, anorm, rcond, work, iwork,info ) !! DPOCON: estimates the reciprocal of the condition number (in the !! 1-norm) of a real symmetric positive definite matrix using the !! Cholesky factorization A = U**T*U or A = L*L**T computed by DPOTRF. @@ -57854,19 +57855,19 @@ module stdlib_linalg_lapack_q character, intent(in) :: uplo integer(ilp), intent(out) :: info integer(ilp), intent(in) :: lda, n - real(qp), intent(in) :: anorm - real(qp), intent(out) :: rcond + real(${rk}$), intent(in) :: anorm + real(${rk}$), intent(out) :: rcond ! Array Arguments integer(ilp), intent(out) :: iwork(*) - real(qp), intent(inout) :: a(lda,*) - real(qp), intent(out) :: work(*) + real(${rk}$), intent(inout) :: a(lda,*) + real(${rk}$), intent(out) :: work(*) ! ===================================================================== ! Local Scalars logical(lk) :: upper character :: normin integer(ilp) :: ix, kase - real(qp) :: ainvnm, scale, scalel, scaleu, smlnum + real(${rk}$) :: ainvnm, scale, scalel, scaleu, smlnum ! Local Arrays integer(ilp) :: isave(3) ! Intrinsic Functions @@ -57896,36 +57897,36 @@ module stdlib_linalg_lapack_q else if( anorm==zero ) then return end if - smlnum = stdlib_qlamch( 'SAFE MINIMUM' ) + smlnum = stdlib_${ri}$lamch( 'SAFE MINIMUM' ) ! estimate the 1-norm of inv(a). kase = 0 normin = 'N' 10 continue - call stdlib_qlacn2( n, work( n+1 ), work, iwork, ainvnm, kase, isave ) + call stdlib_${ri}$lacn2( n, work( n+1 ), work, iwork, ainvnm, kase, isave ) if( kase/=0 ) then if( upper ) then ! multiply by inv(u**t). - call stdlib_qlatrs( 'UPPER', 'TRANSPOSE', 'NON-UNIT', normin, n, a,lda, work, & + call stdlib_${ri}$latrs( 'UPPER', 'TRANSPOSE', 'NON-UNIT', normin, n, a,lda, work, & scalel, work( 2*n+1 ), info ) normin = 'Y' ! multiply by inv(u). - call stdlib_qlatrs( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', normin, n,a, lda, work, & + call stdlib_${ri}$latrs( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', normin, n,a, lda, work, & scaleu, work( 2*n+1 ), info ) else ! multiply by inv(l). - call stdlib_qlatrs( 'LOWER', 'NO TRANSPOSE', 'NON-UNIT', normin, n,a, lda, work, & + call stdlib_${ri}$latrs( 'LOWER', 'NO TRANSPOSE', 'NON-UNIT', normin, n,a, lda, work, & scalel, work( 2*n+1 ), info ) normin = 'Y' ! multiply by inv(l**t). - call stdlib_qlatrs( 'LOWER', 'TRANSPOSE', 'NON-UNIT', normin, n, a,lda, work, & + call stdlib_${ri}$latrs( 'LOWER', 'TRANSPOSE', 'NON-UNIT', normin, n, a,lda, work, & scaleu, work( 2*n+1 ), info ) end if ! multiply by 1/scale if doing so will not cause overflow. scale = scalel*scaleu if( scale/=one ) then - ix = stdlib_iqamax( n, work, 1 ) + ix = stdlib_i${ri}$amax( n, work, 1 ) if( scaleeps .and. two*berr( j )<=lstres .and.count<=itmax ) then ! update solution and try again. - call stdlib_qpotrs( uplo, n, 1, af, ldaf, work( n+1 ), n, info ) - call stdlib_qaxpy( n, one, work( n+1 ), 1, x( 1, j ), 1 ) + call stdlib_${ri}$potrs( uplo, n, 1, af, ldaf, work( n+1 ), n, info ) + call stdlib_${ri}$axpy( n, one, work( n+1 ), 1, x( 1, j ), 1 ) lstres = berr( j ) count = count + 1 go to 20 @@ -58240,7 +58241,7 @@ module stdlib_linalg_lapack_q ! 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_qlacn2 to estimate the infinity-norm of the matrix + ! 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 @@ -58252,12 +58253,12 @@ module stdlib_linalg_lapack_q end do kase = 0 100 continue - call stdlib_qlacn2( n, work( 2*n+1 ), work( n+1 ), iwork, ferr( j ),kase, isave ) + call stdlib_${ri}$lacn2( n, work( 2*n+1 ), work( n+1 ), iwork, ferr( j ),kase, isave ) if( kase/=0 ) then if( kase==1 ) then ! multiply by diag(w)*inv(a**t). - call stdlib_qpotrs( uplo, n, 1, af, ldaf, work( n+1 ), n, info ) + call stdlib_${ri}$potrs( uplo, n, 1, af, ldaf, work( n+1 ), n, info ) do i = 1, n work( n+i ) = work( i )*work( n+i ) end do @@ -58266,7 +58267,7 @@ module stdlib_linalg_lapack_q do i = 1, n work( n+i ) = work( i )*work( n+i ) end do - call stdlib_qpotrs( uplo, n, 1, af, ldaf, work( n+1 ), n, info ) + call stdlib_${ri}$potrs( uplo, n, 1, af, ldaf, work( n+1 ), n, info ) end if go to 100 end if @@ -58278,10 +58279,10 @@ module stdlib_linalg_lapack_q if( lstres/=zero )ferr( j ) = ferr( j ) / lstres end do loop_140 return - end subroutine stdlib_qporfs + end subroutine stdlib_${ri}$porfs - pure subroutine stdlib_qposv( uplo, n, nrhs, a, lda, b, ldb, info ) + pure subroutine stdlib_${ri}$posv( uplo, n, nrhs, a, lda, b, ldb, info ) !! DPOSV: computes the solution to a real system of linear equations !! A * X = B, !! where A is an N-by-N symmetric positive definite matrix and X and B @@ -58300,7 +58301,7 @@ module stdlib_linalg_lapack_q integer(ilp), intent(out) :: info integer(ilp), intent(in) :: lda, ldb, n, nrhs ! Array Arguments - real(qp), intent(inout) :: a(lda,*), b(ldb,*) + real(${rk}$), intent(inout) :: a(lda,*), b(ldb,*) ! ===================================================================== ! Intrinsic Functions intrinsic :: max @@ -58323,16 +58324,16 @@ module stdlib_linalg_lapack_q return end if ! compute the cholesky factorization a = u**t*u or a = l*l**t. - call stdlib_qpotrf( uplo, n, a, lda, info ) + call stdlib_${ri}$potrf( uplo, n, a, lda, info ) if( info==0 ) then ! solve the system a*x = b, overwriting b with x. - call stdlib_qpotrs( uplo, n, nrhs, a, lda, b, ldb, info ) + call stdlib_${ri}$potrs( uplo, n, nrhs, a, lda, b, ldb, info ) end if return - end subroutine stdlib_qposv + end subroutine stdlib_${ri}$posv - subroutine stdlib_qposvx( fact, uplo, n, nrhs, a, lda, af, ldaf, equed,s, b, ldb, x, ldx, & + subroutine stdlib_${ri}$posvx( fact, uplo, n, nrhs, a, lda, af, ldaf, equed,s, b, ldb, x, ldx, & !! DPOSVX: uses the Cholesky factorization A = U**T*U or A = L*L**T to !! compute the solution to a real system of linear equations !! A * X = B, @@ -58349,17 +58350,17 @@ module stdlib_linalg_lapack_q character, intent(in) :: fact, uplo integer(ilp), intent(out) :: info integer(ilp), intent(in) :: lda, ldaf, ldb, ldx, n, nrhs - real(qp), intent(out) :: rcond + real(${rk}$), intent(out) :: rcond ! Array Arguments integer(ilp), intent(out) :: iwork(*) - real(qp), intent(inout) :: a(lda,*), af(ldaf,*), b(ldb,*), s(*) - real(qp), intent(out) :: berr(*), ferr(*), work(*), x(ldx,*) + real(${rk}$), intent(inout) :: a(lda,*), af(ldaf,*), b(ldb,*), s(*) + real(${rk}$), intent(out) :: berr(*), ferr(*), work(*), x(ldx,*) ! ===================================================================== ! Local Scalars logical(lk) :: equil, nofact, rcequ integer(ilp) :: i, infequ, j - real(qp) :: amax, anorm, bignum, scond, smax, smin, smlnum + real(${rk}$) :: amax, anorm, bignum, scond, smax, smin, smlnum ! Intrinsic Functions intrinsic :: max,min ! Executable Statements @@ -58371,7 +58372,7 @@ module stdlib_linalg_lapack_q rcequ = .false. else rcequ = stdlib_lsame( equed, 'Y' ) - smlnum = stdlib_qlamch( 'SAFE MINIMUM' ) + smlnum = stdlib_${ri}$lamch( 'SAFE MINIMUM' ) bignum = one / smlnum end if ! test the input parameters. @@ -58421,10 +58422,10 @@ module stdlib_linalg_lapack_q end if if( equil ) then ! compute row and column scalings to equilibrate the matrix a. - call stdlib_qpoequ( n, a, lda, s, scond, amax, infequ ) + call stdlib_${ri}$poequ( n, a, lda, s, scond, amax, infequ ) if( infequ==0 ) then ! equilibrate the matrix. - call stdlib_qlaqsy( uplo, n, a, lda, s, scond, amax, equed ) + call stdlib_${ri}$laqsy( uplo, n, a, lda, s, scond, amax, equed ) rcequ = stdlib_lsame( equed, 'Y' ) end if end if @@ -58438,8 +58439,8 @@ module stdlib_linalg_lapack_q end if if( nofact .or. equil ) then ! compute the cholesky factorization a = u**t *u or a = l*l**t. - call stdlib_qlacpy( uplo, n, n, a, lda, af, ldaf ) - call stdlib_qpotrf( uplo, n, af, ldaf, info ) + call stdlib_${ri}$lacpy( uplo, n, n, a, lda, af, ldaf ) + call stdlib_${ri}$potrf( uplo, n, af, ldaf, info ) ! return if info is non-zero. if( info>0 )then rcond = zero @@ -58447,15 +58448,15 @@ module stdlib_linalg_lapack_q end if end if ! compute the norm of the matrix a. - anorm = stdlib_qlansy( '1', uplo, n, a, lda, work ) + anorm = stdlib_${ri}$lansy( '1', uplo, n, a, lda, work ) ! compute the reciprocal of the condition number of a. - call stdlib_qpocon( uplo, n, af, ldaf, anorm, rcond, work, iwork, info ) + call stdlib_${ri}$pocon( uplo, n, af, ldaf, anorm, rcond, work, iwork, info ) ! compute the solution matrix x. - call stdlib_qlacpy( 'FULL', n, nrhs, b, ldb, x, ldx ) - call stdlib_qpotrs( uplo, n, nrhs, af, ldaf, x, ldx, info ) + call stdlib_${ri}$lacpy( 'FULL', n, nrhs, b, ldb, x, ldx ) + call stdlib_${ri}$potrs( uplo, n, nrhs, af, ldaf, x, ldx, info ) ! use iterative refinement to improve the computed solution and ! compute error bounds and backward error estimates for it. - call stdlib_qporfs( uplo, n, nrhs, a, lda, af, ldaf, b, ldb, x, ldx,ferr, berr, work, & + call stdlib_${ri}$porfs( uplo, n, nrhs, a, lda, af, ldaf, b, ldb, x, ldx,ferr, berr, work, & iwork, info ) ! transform the solution matrix x to a solution of the original ! system. @@ -58470,12 +58471,12 @@ module stdlib_linalg_lapack_q end do end if ! set info = n+1 if the matrix is singular to working precision. - if( rcond=n ) then ! use unblocked code. - call stdlib_qpotrf2( uplo, n, a, lda, info ) + call stdlib_${ri}$potrf2( uplo, n, a, lda, info ) else ! use blocked code. if( upper ) then @@ -58616,15 +58617,15 @@ module stdlib_linalg_lapack_q ! update and factorize the current diagonal block and test ! for non-positive-definiteness. jb = min( nb, n-j+1 ) - call stdlib_qsyrk( 'UPPER', 'TRANSPOSE', jb, j-1, -one,a( 1, j ), lda, one, a(& + call stdlib_${ri}$syrk( 'UPPER', 'TRANSPOSE', jb, j-1, -one,a( 1, j ), lda, one, a(& j, j ), lda ) - call stdlib_qpotrf2( 'UPPER', jb, a( j, j ), lda, info ) + call stdlib_${ri}$potrf2( 'UPPER', jb, a( j, j ), lda, info ) if( info/=0 )go to 30 if( j+jb<=n ) then ! compute the current block row. - call stdlib_qgemm( 'TRANSPOSE', 'NO TRANSPOSE', jb, n-j-jb+1,j-1, -one, a( & + call stdlib_${ri}$gemm( 'TRANSPOSE', 'NO TRANSPOSE', jb, n-j-jb+1,j-1, -one, a( & 1, j ), lda, a( 1, j+jb ),lda, one, a( j, j+jb ), lda ) - call stdlib_qtrsm( 'LEFT', 'UPPER', 'TRANSPOSE', 'NON-UNIT',jb, n-j-jb+1, & + call stdlib_${ri}$trsm( 'LEFT', 'UPPER', 'TRANSPOSE', 'NON-UNIT',jb, n-j-jb+1, & one, a( j, j ), lda,a( j, j+jb ), lda ) end if end do @@ -58634,15 +58635,15 @@ module stdlib_linalg_lapack_q ! update and factorize the current diagonal block and test ! for non-positive-definiteness. jb = min( nb, n-j+1 ) - call stdlib_qsyrk( 'LOWER', 'NO TRANSPOSE', jb, j-1, -one,a( j, 1 ), lda, one,& + call stdlib_${ri}$syrk( 'LOWER', 'NO TRANSPOSE', jb, j-1, -one,a( j, 1 ), lda, one,& a( j, j ), lda ) - call stdlib_qpotrf2( 'LOWER', jb, a( j, j ), lda, info ) + call stdlib_${ri}$potrf2( 'LOWER', jb, a( j, j ), lda, info ) if( info/=0 )go to 30 if( j+jb<=n ) then ! compute the current block column. - call stdlib_qgemm( 'NO TRANSPOSE', 'TRANSPOSE', n-j-jb+1, jb,j-1, -one, a( & + call stdlib_${ri}$gemm( 'NO TRANSPOSE', 'TRANSPOSE', n-j-jb+1, jb,j-1, -one, a( & j+jb, 1 ), lda, a( j, 1 ),lda, one, a( j+jb, j ), lda ) - call stdlib_qtrsm( 'RIGHT', 'LOWER', 'TRANSPOSE', 'NON-UNIT',n-j-jb+1, jb, & + call stdlib_${ri}$trsm( 'RIGHT', 'LOWER', 'TRANSPOSE', 'NON-UNIT',n-j-jb+1, jb, & one, a( j, j ), lda,a( j+jb, j ), lda ) end if end do @@ -58653,10 +58654,10 @@ module stdlib_linalg_lapack_q info = info + j - 1 40 continue return - end subroutine stdlib_qpotrf + end subroutine stdlib_${ri}$potrf - pure recursive subroutine stdlib_qpotrf2( uplo, n, a, lda, info ) + pure recursive subroutine stdlib_${ri}$potrf2( uplo, n, a, lda, info ) !! DPOTRF2: computes the Cholesky factorization of a real symmetric !! positive definite matrix A using the recursive algorithm. !! The factorization has the form @@ -58678,7 +58679,7 @@ module stdlib_linalg_lapack_q integer(ilp), intent(out) :: info integer(ilp), intent(in) :: lda, n ! Array Arguments - real(qp), intent(inout) :: a(lda,*) + real(${rk}$), intent(inout) :: a(lda,*) ! ===================================================================== ! Local Scalars @@ -58706,7 +58707,7 @@ module stdlib_linalg_lapack_q ! n=1 case if( n==1 ) then ! test for non-positive-definiteness - if( a( 1, 1 )<=zero.or.stdlib_qisnan( a( 1, 1 ) ) ) then + if( a( 1, 1 )<=zero.or.stdlib_${ri}$isnan( a( 1, 1 ) ) ) then info = 1 return end if @@ -58717,7 +58718,7 @@ module stdlib_linalg_lapack_q n1 = n/2 n2 = n-n1 ! factor a11 - call stdlib_qpotrf2( uplo, n1, a( 1, 1 ), lda, iinfo ) + call stdlib_${ri}$potrf2( uplo, n1, a( 1, 1 ), lda, iinfo ) if ( iinfo/=0 ) then info = iinfo return @@ -58725,12 +58726,12 @@ module stdlib_linalg_lapack_q ! compute the cholesky factorization a = u**t*u if( upper ) then ! update and scale a12 - call stdlib_qtrsm( 'L', 'U', 'T', 'N', n1, n2, one,a( 1, 1 ), lda, a( 1, n1+1 ), & + call stdlib_${ri}$trsm( 'L', 'U', 'T', 'N', n1, n2, one,a( 1, 1 ), lda, a( 1, n1+1 ), & lda ) ! update and factor a22 - call stdlib_qsyrk( uplo, 'T', n2, n1, -one, a( 1, n1+1 ), lda,one, a( n1+1, n1+1 & + call stdlib_${ri}$syrk( uplo, 'T', n2, n1, -one, a( 1, n1+1 ), lda,one, a( n1+1, n1+1 & ), lda ) - call stdlib_qpotrf2( uplo, n2, a( n1+1, n1+1 ), lda, iinfo ) + call stdlib_${ri}$potrf2( uplo, n2, a( n1+1, n1+1 ), lda, iinfo ) if ( iinfo/=0 ) then info = iinfo + n1 return @@ -58738,12 +58739,12 @@ module stdlib_linalg_lapack_q ! compute the cholesky factorization a = l*l**t else ! update and scale a21 - call stdlib_qtrsm( 'R', 'L', 'T', 'N', n2, n1, one,a( 1, 1 ), lda, a( n1+1, 1 ), & + call stdlib_${ri}$trsm( 'R', 'L', 'T', 'N', n2, n1, one,a( 1, 1 ), lda, a( n1+1, 1 ), & lda ) ! update and factor a22 - call stdlib_qsyrk( uplo, 'N', n2, n1, -one, a( n1+1, 1 ), lda,one, a( n1+1, n1+1 & + call stdlib_${ri}$syrk( uplo, 'N', n2, n1, -one, a( n1+1, 1 ), lda,one, a( n1+1, n1+1 & ), lda ) - call stdlib_qpotrf2( uplo, n2, a( n1+1, n1+1 ), lda, iinfo ) + call stdlib_${ri}$potrf2( uplo, n2, a( n1+1, n1+1 ), lda, iinfo ) if ( iinfo/=0 ) then info = iinfo + n1 return @@ -58751,10 +58752,10 @@ module stdlib_linalg_lapack_q end if end if return - end subroutine stdlib_qpotrf2 + end subroutine stdlib_${ri}$potrf2 - pure subroutine stdlib_qpotri( uplo, n, a, lda, info ) + pure subroutine stdlib_${ri}$potri( uplo, n, a, lda, info ) !! DPOTRI: computes the inverse of a real symmetric positive definite !! matrix A using the Cholesky factorization A = U**T*U or A = L*L**T !! computed by DPOTRF. @@ -58766,7 +58767,7 @@ module stdlib_linalg_lapack_q integer(ilp), intent(out) :: info integer(ilp), intent(in) :: lda, n ! Array Arguments - real(qp), intent(inout) :: a(lda,*) + real(${rk}$), intent(inout) :: a(lda,*) ! ===================================================================== ! Intrinsic Functions intrinsic :: max @@ -58787,15 +58788,15 @@ module stdlib_linalg_lapack_q ! quick return if possible if( n==0 )return ! invert the triangular cholesky factor u or l. - call stdlib_qtrtri( uplo, 'NON-UNIT', n, a, lda, info ) + call stdlib_${ri}$trtri( uplo, 'NON-UNIT', n, a, lda, info ) if( info>0 )return ! form inv(u) * inv(u)**t or inv(l)**t * inv(l). - call stdlib_qlauum( uplo, n, a, lda, info ) + call stdlib_${ri}$lauum( uplo, n, a, lda, info ) return - end subroutine stdlib_qpotri + end subroutine stdlib_${ri}$potri - pure subroutine stdlib_qpotrs( uplo, n, nrhs, a, lda, b, ldb, info ) + pure subroutine stdlib_${ri}$potrs( uplo, n, nrhs, a, lda, b, ldb, info ) !! DPOTRS: solves a system of linear equations A*X = B with a symmetric !! positive definite matrix A using the Cholesky factorization !! A = U**T*U or A = L*L**T computed by DPOTRF. @@ -58807,8 +58808,8 @@ module stdlib_linalg_lapack_q integer(ilp), intent(out) :: info integer(ilp), intent(in) :: lda, ldb, n, nrhs ! Array Arguments - real(qp), intent(in) :: a(lda,*) - real(qp), intent(inout) :: b(ldb,*) + real(${rk}$), intent(in) :: a(lda,*) + real(${rk}$), intent(inout) :: b(ldb,*) ! ===================================================================== ! Local Scalars @@ -58839,25 +58840,25 @@ module stdlib_linalg_lapack_q if( upper ) then ! solve a*x = b where a = u**t *u. ! solve u**t *x = b, overwriting b with x. - call stdlib_qtrsm( 'LEFT', 'UPPER', 'TRANSPOSE', 'NON-UNIT', n, nrhs,one, a, lda, b,& + call stdlib_${ri}$trsm( 'LEFT', 'UPPER', 'TRANSPOSE', 'NON-UNIT', n, nrhs,one, a, lda, b,& ldb ) ! solve u*x = b, overwriting b with x. - call stdlib_qtrsm( 'LEFT', 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', n,nrhs, one, a, lda,& + call stdlib_${ri}$trsm( 'LEFT', 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', n,nrhs, one, a, lda,& b, ldb ) else ! solve a*x = b where a = l*l**t. ! solve l*x = b, overwriting b with x. - call stdlib_qtrsm( 'LEFT', 'LOWER', 'NO TRANSPOSE', 'NON-UNIT', n,nrhs, one, a, lda,& + call stdlib_${ri}$trsm( 'LEFT', 'LOWER', 'NO TRANSPOSE', 'NON-UNIT', n,nrhs, one, a, lda,& b, ldb ) ! solve l**t *x = b, overwriting b with x. - call stdlib_qtrsm( 'LEFT', 'LOWER', 'TRANSPOSE', 'NON-UNIT', n, nrhs,one, a, lda, b,& + call stdlib_${ri}$trsm( 'LEFT', 'LOWER', 'TRANSPOSE', 'NON-UNIT', n, nrhs,one, a, lda, b,& ldb ) end if return - end subroutine stdlib_qpotrs + end subroutine stdlib_${ri}$potrs - pure subroutine stdlib_qppcon( uplo, n, ap, anorm, rcond, work, iwork, info ) + pure subroutine stdlib_${ri}$ppcon( uplo, n, ap, anorm, rcond, work, iwork, info ) !! DPPCON: estimates the reciprocal of the condition number (in the !! 1-norm) of a real symmetric positive definite packed matrix using !! the Cholesky factorization A = U**T*U or A = L*L**T computed by @@ -58871,19 +58872,19 @@ module stdlib_linalg_lapack_q character, intent(in) :: uplo integer(ilp), intent(out) :: info integer(ilp), intent(in) :: n - real(qp), intent(in) :: anorm - real(qp), intent(out) :: rcond + real(${rk}$), intent(in) :: anorm + real(${rk}$), intent(out) :: rcond ! Array Arguments integer(ilp), intent(out) :: iwork(*) - real(qp), intent(in) :: ap(*) - real(qp), intent(out) :: work(*) + real(${rk}$), intent(in) :: ap(*) + real(${rk}$), intent(out) :: work(*) ! ===================================================================== ! Local Scalars logical(lk) :: upper character :: normin integer(ilp) :: ix, kase - real(qp) :: ainvnm, scale, scalel, scaleu, smlnum + real(${rk}$) :: ainvnm, scale, scalel, scaleu, smlnum ! Local Arrays integer(ilp) :: isave(3) ! Intrinsic Functions @@ -58911,36 +58912,36 @@ module stdlib_linalg_lapack_q else if( anorm==zero ) then return end if - smlnum = stdlib_qlamch( 'SAFE MINIMUM' ) + smlnum = stdlib_${ri}$lamch( 'SAFE MINIMUM' ) ! estimate the 1-norm of the inverse. kase = 0 normin = 'N' 10 continue - call stdlib_qlacn2( n, work( n+1 ), work, iwork, ainvnm, kase, isave ) + call stdlib_${ri}$lacn2( n, work( n+1 ), work, iwork, ainvnm, kase, isave ) if( kase/=0 ) then if( upper ) then ! multiply by inv(u**t). - call stdlib_qlatps( 'UPPER', 'TRANSPOSE', 'NON-UNIT', normin, n,ap, work, scalel,& + call stdlib_${ri}$latps( 'UPPER', 'TRANSPOSE', 'NON-UNIT', normin, n,ap, work, scalel,& work( 2*n+1 ), info ) normin = 'Y' ! multiply by inv(u). - call stdlib_qlatps( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', normin, n,ap, work, & + call stdlib_${ri}$latps( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', normin, n,ap, work, & scaleu, work( 2*n+1 ), info ) else ! multiply by inv(l). - call stdlib_qlatps( 'LOWER', 'NO TRANSPOSE', 'NON-UNIT', normin, n,ap, work, & + call stdlib_${ri}$latps( 'LOWER', 'NO TRANSPOSE', 'NON-UNIT', normin, n,ap, work, & scalel, work( 2*n+1 ), info ) normin = 'Y' ! multiply by inv(l**t). - call stdlib_qlatps( 'LOWER', 'TRANSPOSE', 'NON-UNIT', normin, n,ap, work, scaleu,& + call stdlib_${ri}$latps( 'LOWER', 'TRANSPOSE', 'NON-UNIT', normin, n,ap, work, scaleu,& work( 2*n+1 ), info ) end if ! multiply by 1/scale if doing so will not cause overflow. scale = scalel*scaleu if( scale/=one ) then - ix = stdlib_iqamax( n, work, 1 ) + ix = stdlib_i${ri}$amax( n, work, 1 ) if( scaleeps .and. two*berr( j )<=lstres .and.count<=itmax ) then ! update solution and try again. - call stdlib_qpptrs( uplo, n, 1, afp, work( n+1 ), n, info ) - call stdlib_qaxpy( n, one, work( n+1 ), 1, x( 1, j ), 1 ) + call stdlib_${ri}$pptrs( uplo, n, 1, afp, work( n+1 ), n, info ) + call stdlib_${ri}$axpy( n, one, work( n+1 ), 1, x( 1, j ), 1 ) lstres = berr( j ) count = count + 1 go to 20 @@ -59195,7 +59196,7 @@ module stdlib_linalg_lapack_q ! 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_qlacn2 to estimate the infinity-norm of the matrix + ! 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 @@ -59207,12 +59208,12 @@ module stdlib_linalg_lapack_q end do kase = 0 100 continue - call stdlib_qlacn2( n, work( 2*n+1 ), work( n+1 ), iwork, ferr( j ),kase, isave ) + call stdlib_${ri}$lacn2( n, work( 2*n+1 ), work( n+1 ), iwork, ferr( j ),kase, isave ) if( kase/=0 ) then if( kase==1 ) then ! multiply by diag(w)*inv(a**t). - call stdlib_qpptrs( uplo, n, 1, afp, work( n+1 ), n, info ) + call stdlib_${ri}$pptrs( uplo, n, 1, afp, work( n+1 ), n, info ) do i = 1, n work( n+i ) = work( i )*work( n+i ) end do @@ -59221,7 +59222,7 @@ module stdlib_linalg_lapack_q do i = 1, n work( n+i ) = work( i )*work( n+i ) end do - call stdlib_qpptrs( uplo, n, 1, afp, work( n+1 ), n, info ) + call stdlib_${ri}$pptrs( uplo, n, 1, afp, work( n+1 ), n, info ) end if go to 100 end if @@ -59233,10 +59234,10 @@ module stdlib_linalg_lapack_q if( lstres/=zero )ferr( j ) = ferr( j ) / lstres end do loop_140 return - end subroutine stdlib_qpprfs + end subroutine stdlib_${ri}$pprfs - pure subroutine stdlib_qppsv( uplo, n, nrhs, ap, b, ldb, info ) + pure subroutine stdlib_${ri}$ppsv( uplo, n, nrhs, ap, b, ldb, info ) !! DPPSV: computes the solution to a real system of linear equations !! A * X = B, !! where A is an N-by-N symmetric positive definite matrix stored in @@ -59255,7 +59256,7 @@ module stdlib_linalg_lapack_q integer(ilp), intent(out) :: info integer(ilp), intent(in) :: ldb, n, nrhs ! Array Arguments - real(qp), intent(inout) :: ap(*), b(ldb,*) + real(${rk}$), intent(inout) :: ap(*), b(ldb,*) ! ===================================================================== ! Intrinsic Functions intrinsic :: max @@ -59276,16 +59277,16 @@ module stdlib_linalg_lapack_q return end if ! compute the cholesky factorization a = u**t*u or a = l*l**t. - call stdlib_qpptrf( uplo, n, ap, info ) + call stdlib_${ri}$pptrf( uplo, n, ap, info ) if( info==0 ) then ! solve the system a*x = b, overwriting b with x. - call stdlib_qpptrs( uplo, n, nrhs, ap, b, ldb, info ) + call stdlib_${ri}$pptrs( uplo, n, nrhs, ap, b, ldb, info ) end if return - end subroutine stdlib_qppsv + end subroutine stdlib_${ri}$ppsv - subroutine stdlib_qppsvx( fact, uplo, n, nrhs, ap, afp, equed, s, b, ldb,x, ldx, rcond, ferr,& + subroutine stdlib_${ri}$ppsvx( fact, uplo, n, nrhs, ap, afp, equed, s, b, ldb,x, ldx, rcond, ferr,& !! DPPSVX: uses the Cholesky factorization A = U**T*U or A = L*L**T to !! compute the solution to a real system of linear equations !! A * X = B, @@ -59302,17 +59303,17 @@ module stdlib_linalg_lapack_q character, intent(in) :: fact, uplo integer(ilp), intent(out) :: info integer(ilp), intent(in) :: ldb, ldx, n, nrhs - real(qp), intent(out) :: rcond + real(${rk}$), intent(out) :: rcond ! Array Arguments integer(ilp), intent(out) :: iwork(*) - real(qp), intent(inout) :: afp(*), ap(*), b(ldb,*), s(*) - real(qp), intent(out) :: berr(*), ferr(*), work(*), x(ldx,*) + real(${rk}$), intent(inout) :: afp(*), ap(*), b(ldb,*), s(*) + real(${rk}$), intent(out) :: berr(*), ferr(*), work(*), x(ldx,*) ! ===================================================================== ! Local Scalars logical(lk) :: equil, nofact, rcequ integer(ilp) :: i, infequ, j - real(qp) :: amax, anorm, bignum, scond, smax, smin, smlnum + real(${rk}$) :: amax, anorm, bignum, scond, smax, smin, smlnum ! Intrinsic Functions intrinsic :: max,min ! Executable Statements @@ -59324,7 +59325,7 @@ module stdlib_linalg_lapack_q rcequ = .false. else rcequ = stdlib_lsame( equed, 'Y' ) - smlnum = stdlib_qlamch( 'SAFE MINIMUM' ) + smlnum = stdlib_${ri}$lamch( 'SAFE MINIMUM' ) bignum = one / smlnum end if ! test the input parameters. @@ -59370,10 +59371,10 @@ module stdlib_linalg_lapack_q end if if( equil ) then ! compute row and column scalings to equilibrate the matrix a. - call stdlib_qppequ( uplo, n, ap, s, scond, amax, infequ ) + call stdlib_${ri}$ppequ( uplo, n, ap, s, scond, amax, infequ ) if( infequ==0 ) then ! equilibrate the matrix. - call stdlib_qlaqsp( uplo, n, ap, s, scond, amax, equed ) + call stdlib_${ri}$laqsp( uplo, n, ap, s, scond, amax, equed ) rcequ = stdlib_lsame( equed, 'Y' ) end if end if @@ -59387,8 +59388,8 @@ module stdlib_linalg_lapack_q end if if( nofact .or. equil ) then ! compute the cholesky factorization a = u**t * u or a = l * l**t. - call stdlib_qcopy( n*( n+1 ) / 2, ap, 1, afp, 1 ) - call stdlib_qpptrf( uplo, n, afp, info ) + call stdlib_${ri}$copy( n*( n+1 ) / 2, ap, 1, afp, 1 ) + call stdlib_${ri}$pptrf( uplo, n, afp, info ) ! return if info is non-zero. if( info>0 )then rcond = zero @@ -59396,15 +59397,15 @@ module stdlib_linalg_lapack_q end if end if ! compute the norm of the matrix a. - anorm = stdlib_qlansp( 'I', uplo, n, ap, work ) + anorm = stdlib_${ri}$lansp( 'I', uplo, n, ap, work ) ! compute the reciprocal of the condition number of a. - call stdlib_qppcon( uplo, n, afp, anorm, rcond, work, iwork, info ) + call stdlib_${ri}$ppcon( uplo, n, afp, anorm, rcond, work, iwork, info ) ! compute the solution matrix x. - call stdlib_qlacpy( 'FULL', n, nrhs, b, ldb, x, ldx ) - call stdlib_qpptrs( uplo, n, nrhs, afp, x, ldx, info ) + call stdlib_${ri}$lacpy( 'FULL', n, nrhs, b, ldb, x, ldx ) + call stdlib_${ri}$pptrs( uplo, n, nrhs, afp, x, ldx, info ) ! use iterative refinement to improve the computed solution and ! compute error bounds and backward error estimates for it. - call stdlib_qpprfs( uplo, n, nrhs, ap, afp, b, ldb, x, ldx, ferr, berr,work, iwork, & + call stdlib_${ri}$pprfs( uplo, n, nrhs, ap, afp, b, ldb, x, ldx, ferr, berr,work, iwork, & info ) ! transform the solution matrix x to a solution of the original ! system. @@ -59419,12 +59420,12 @@ module stdlib_linalg_lapack_q end do end if ! set info = n+1 if the matrix is singular to working precision. - if( rcond1 )call stdlib_qtpsv( 'UPPER', 'TRANSPOSE', 'NON-UNIT', j-1, ap,ap( jc ), & + if( j>1 )call stdlib_${ri}$tpsv( 'UPPER', 'TRANSPOSE', 'NON-UNIT', j-1, ap,ap( jc ), & 1 ) ! compute u(j,j) and test for non-positive-definiteness. - ajj = ap( jj ) - stdlib_qdot( j-1, ap( jc ), 1, ap( jc ), 1 ) + ajj = ap( jj ) - stdlib_${ri}$dot( j-1, ap( jc ), 1, ap( jc ), 1 ) if( ajj<=zero ) then ap( jj ) = ajj go to 30 @@ -59495,8 +59496,8 @@ module stdlib_linalg_lapack_q ! compute elements j+1:n of column j and update the trailing ! submatrix. if( j0 )return if( upper ) then ! compute the product inv(u) * inv(u)**t. @@ -59552,26 +59553,26 @@ module stdlib_linalg_lapack_q do j = 1, n jc = jj + 1 jj = jj + j - if( j>1 )call stdlib_qspr( 'UPPER', j-1, one, ap( jc ), 1, ap ) + if( j>1 )call stdlib_${ri}$spr( 'UPPER', j-1, one, ap( jc ), 1, ap ) ajj = ap( jj ) - call stdlib_qscal( j, ajj, ap( jc ), 1 ) + call stdlib_${ri}$scal( j, ajj, ap( jc ), 1 ) end do else ! compute the product inv(l)**t * inv(l). jj = 1 do j = 1, n jjn = jj + n - j + 1 - ap( jj ) = stdlib_qdot( n-j+1, ap( jj ), 1, ap( jj ), 1 ) - if( j=n ) then ! use unblocked code - call stdlib_qpstf2( uplo, n, a( 1, 1 ), lda, piv, rank, tol, work,info ) + call stdlib_${ri}$pstf2( uplo, n, a( 1, 1 ), lda, piv, rank, tol, work,info ) go to 200 else ! initialize piv @@ -59879,14 +59880,14 @@ module stdlib_linalg_lapack_q ajj = a( pvt, pvt ) end if end do - if( ajj<=zero.or.stdlib_qisnan( ajj ) ) then + if( ajj<=zero.or.stdlib_${ri}$isnan( ajj ) ) then rank = 0 info = 1 go to 200 end if ! compute stopping value if not supplied if( tol0 )z( 1, 1 ) = one return end if - if( icompz==2 )call stdlib_qlaset( 'FULL', n, n, zero, one, z, ldz ) - ! call stdlib_qpttrf to factor the matrix. - call stdlib_qpttrf( n, d, e, info ) + if( icompz==2 )call stdlib_${ri}$laset( 'FULL', n, n, zero, one, z, ldz ) + ! call stdlib_${ri}$pttrf to factor the matrix. + call stdlib_${ri}$pttrf( n, d, e, info ) if( info/=0 )return do i = 1, n d( i ) = sqrt( d( i ) ) @@ -60169,14 +60170,14 @@ module stdlib_linalg_lapack_q do i = 1, n - 1 e( i ) = e( i )*d( i ) end do - ! call stdlib_qbdsqr to compute the singular values/vectors of the + ! call stdlib_${ri}$bdsqr to compute the singular values/vectors of the ! bidiagonal factor. if( icompz>0 ) then nru = n else nru = 0 end if - call stdlib_qbdsqr( 'LOWER', n, 0, nru, 0, d, e, vt, 1, z, ldz, c, 1,work, info ) + call stdlib_${ri}$bdsqr( 'LOWER', n, 0, nru, 0, d, e, vt, 1, z, ldz, c, 1,work, info ) ! square the singular values. if( info==0 ) then @@ -60187,10 +60188,10 @@ module stdlib_linalg_lapack_q info = n + info end if return - end subroutine stdlib_qpteqr + end subroutine stdlib_${ri}$pteqr - pure subroutine stdlib_qptrfs( n, nrhs, d, e, df, ef, b, ldb, x, ldx, ferr,berr, work, info ) + pure subroutine stdlib_${ri}$ptrfs( n, nrhs, d, e, df, ef, b, ldb, x, ldx, ferr,berr, work, info ) !! DPTRFS: improves the computed solution to a system of linear !! equations when the coefficient matrix is symmetric positive definite !! and tridiagonal, and provides error bounds and backward error @@ -60203,9 +60204,9 @@ module stdlib_linalg_lapack_q integer(ilp), intent(out) :: info integer(ilp), intent(in) :: ldb, ldx, n, nrhs ! Array Arguments - real(qp), intent(in) :: b(ldb,*), d(*), df(*), e(*), ef(*) - real(qp), intent(out) :: berr(*), ferr(*), work(*) - real(qp), intent(inout) :: x(ldx,*) + real(${rk}$), intent(in) :: b(ldb,*), d(*), df(*), e(*), ef(*) + real(${rk}$), intent(out) :: berr(*), ferr(*), work(*) + real(${rk}$), intent(inout) :: x(ldx,*) ! ===================================================================== ! Parameters integer(ilp), parameter :: itmax = 5 @@ -60216,7 +60217,7 @@ module stdlib_linalg_lapack_q ! Local Scalars integer(ilp) :: count, i, ix, j, nz - real(qp) :: bi, cx, dx, eps, ex, lstres, s, safe1, safe2, safmin + real(${rk}$) :: bi, cx, dx, eps, ex, lstres, s, safe1, safe2, safmin ! Intrinsic Functions intrinsic :: abs,max ! Executable Statements @@ -60245,8 +60246,8 @@ module stdlib_linalg_lapack_q end if ! nz = maximum number of nonzero elements in each row of a, plus 1 nz = 4 - eps = stdlib_qlamch( 'EPSILON' ) - safmin = stdlib_qlamch( 'SAFE MINIMUM' ) + eps = stdlib_${ri}$lamch( 'EPSILON' ) + safmin = stdlib_${ri}$lamch( 'SAFE MINIMUM' ) safe1 = nz*safmin safe2 = safe1 / eps ! do for each right hand side @@ -60304,8 +60305,8 @@ module stdlib_linalg_lapack_q ! 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_qpttrs( n, 1, df, ef, work( n+1 ), n, info ) - call stdlib_qaxpy( n, one, work( n+1 ), 1, x( 1, j ), 1 ) + call stdlib_${ri}$pttrs( n, 1, df, ef, work( n+1 ), n, info ) + call stdlib_${ri}$axpy( n, one, work( n+1 ), 1, x( 1, j ), 1 ) lstres = berr( j ) count = count + 1 go to 20 @@ -60331,7 +60332,7 @@ module stdlib_linalg_lapack_q work( i ) = abs( work( n+i ) ) + nz*eps*work( i ) + safe1 end if end do - ix = stdlib_iqamax( n, work, 1 ) + ix = stdlib_i${ri}$amax( n, work, 1 ) ferr( j ) = work( ix ) ! estimate the norm of inv(a). ! solve m(a) * x = e, where m(a) = (m(i,j)) is given by @@ -60349,7 +60350,7 @@ module stdlib_linalg_lapack_q work( i ) = work( i ) / df( i ) + work( i+1 )*abs( ef( i ) ) end do ! compute norm(inv(a)) = max(x(i)), 1<=i<=n. - ix = stdlib_iqamax( n, work, 1 ) + ix = stdlib_i${ri}$amax( n, work, 1 ) ferr( j ) = ferr( j )*abs( work( ix ) ) ! normalize error. lstres = zero @@ -60359,10 +60360,10 @@ module stdlib_linalg_lapack_q if( lstres/=zero )ferr( j ) = ferr( j ) / lstres end do loop_90 return - end subroutine stdlib_qptrfs + end subroutine stdlib_${ri}$ptrfs - pure subroutine stdlib_qptsv( n, nrhs, d, e, b, ldb, info ) + pure subroutine stdlib_${ri}$ptsv( n, nrhs, d, e, b, ldb, info ) !! DPTSV: computes the solution to a real system of linear equations !! A*X = B, where A is an N-by-N symmetric positive definite tridiagonal !! matrix, and X and B are N-by-NRHS matrices. @@ -60375,7 +60376,7 @@ module stdlib_linalg_lapack_q integer(ilp), intent(out) :: info integer(ilp), intent(in) :: ldb, n, nrhs ! Array Arguments - real(qp), intent(inout) :: b(ldb,*), d(*), e(*) + real(${rk}$), intent(inout) :: b(ldb,*), d(*), e(*) ! ===================================================================== ! Intrinsic Functions intrinsic :: max @@ -60394,16 +60395,16 @@ module stdlib_linalg_lapack_q return end if ! compute the l*d*l**t (or u**t*d*u) factorization of a. - call stdlib_qpttrf( n, d, e, info ) + call stdlib_${ri}$pttrf( n, d, e, info ) if( info==0 ) then ! solve the system a*x = b, overwriting b with x. - call stdlib_qpttrs( n, nrhs, d, e, b, ldb, info ) + call stdlib_${ri}$pttrs( n, nrhs, d, e, b, ldb, info ) end if return - end subroutine stdlib_qptsv + end subroutine stdlib_${ri}$ptsv - pure subroutine stdlib_qptsvx( fact, n, nrhs, d, e, df, ef, b, ldb, x, ldx,rcond, ferr, berr,& + pure subroutine stdlib_${ri}$ptsvx( fact, n, nrhs, d, e, df, ef, b, ldb, x, ldx,rcond, ferr, berr,& !! DPTSVX: uses the factorization A = L*D*L**T to compute the solution !! to a real system of linear equations A*X = B, where A is an N-by-N !! symmetric positive definite tridiagonal matrix and X and B are @@ -60418,16 +60419,16 @@ module stdlib_linalg_lapack_q character, intent(in) :: fact integer(ilp), intent(out) :: info integer(ilp), intent(in) :: ldb, ldx, n, nrhs - real(qp), intent(out) :: rcond + real(${rk}$), intent(out) :: rcond ! Array Arguments - real(qp), intent(in) :: b(ldb,*), d(*), e(*) - real(qp), intent(out) :: berr(*), ferr(*), work(*), x(ldx,*) - real(qp), intent(inout) :: df(*), ef(*) + real(${rk}$), intent(in) :: b(ldb,*), d(*), e(*) + real(${rk}$), intent(out) :: berr(*), ferr(*), work(*), x(ldx,*) + real(${rk}$), intent(inout) :: df(*), ef(*) ! ===================================================================== ! Local Scalars logical(lk) :: nofact - real(qp) :: anorm + real(${rk}$) :: anorm ! Intrinsic Functions intrinsic :: max ! Executable Statements @@ -60451,9 +60452,9 @@ module stdlib_linalg_lapack_q end if if( nofact ) then ! compute the l*d*l**t (or u**t*d*u) factorization of a. - call stdlib_qcopy( n, d, 1, df, 1 ) - if( n>1 )call stdlib_qcopy( n-1, e, 1, ef, 1 ) - call stdlib_qpttrf( n, df, ef, info ) + call stdlib_${ri}$copy( n, d, 1, df, 1 ) + if( n>1 )call stdlib_${ri}$copy( n-1, e, 1, ef, 1 ) + call stdlib_${ri}$pttrf( n, df, ef, info ) ! return if info is non-zero. if( info>0 )then rcond = zero @@ -60461,23 +60462,23 @@ module stdlib_linalg_lapack_q end if end if ! compute the norm of the matrix a. - anorm = stdlib_qlanst( '1', n, d, e ) + anorm = stdlib_${ri}$lanst( '1', n, d, e ) ! compute the reciprocal of the condition number of a. - call stdlib_qptcon( n, df, ef, anorm, rcond, work, info ) + call stdlib_${ri}$ptcon( n, df, ef, anorm, rcond, work, info ) ! compute the solution vectors x. - call stdlib_qlacpy( 'FULL', n, nrhs, b, ldb, x, ldx ) - call stdlib_qpttrs( n, nrhs, df, ef, x, ldx, info ) + call stdlib_${ri}$lacpy( 'FULL', n, nrhs, b, ldb, x, ldx ) + call stdlib_${ri}$pttrs( n, nrhs, df, ef, x, ldx, info ) ! use iterative refinement to improve the computed solutions and ! compute error bounds and backward error estimates for them. - call stdlib_qptrfs( n, nrhs, d, e, df, ef, b, ldb, x, ldx, ferr, berr,work, info ) + call stdlib_${ri}$ptrfs( n, nrhs, d, e, df, ef, b, ldb, x, ldx, ferr, berr,work, info ) ! set info = n+1 if the matrix is singular to working precision. - if( rcond=nrhs ) then - call stdlib_qptts2( n, nrhs, d, e, b, ldb ) + call stdlib_${ri}$ptts2( n, nrhs, d, e, b, ldb ) else do j = 1, nrhs, nb jb = min( nrhs-j+1, nb ) - call stdlib_qptts2( n, jb, d, e, b( 1, j ), ldb ) + call stdlib_${ri}$ptts2( n, jb, d, e, b( 1, j ), ldb ) end do end if return - end subroutine stdlib_qpttrs + end subroutine stdlib_${ri}$pttrs - pure subroutine stdlib_qptts2( n, nrhs, d, e, b, ldb ) + pure subroutine stdlib_${ri}$ptts2( n, nrhs, d, e, b, ldb ) !! DPTTS2: solves a tridiagonal system of the form !! A * X = B !! using the L*D*L**T factorization of A computed by DPTTRF. D is a @@ -60628,15 +60629,15 @@ module stdlib_linalg_lapack_q ! Scalar Arguments integer(ilp), intent(in) :: ldb, n, nrhs ! Array Arguments - real(qp), intent(inout) :: b(ldb,*) - real(qp), intent(in) :: d(*), e(*) + real(${rk}$), intent(inout) :: b(ldb,*) + real(${rk}$), intent(in) :: d(*), e(*) ! ===================================================================== ! Local Scalars integer(ilp) :: i, j ! Executable Statements ! quick return if possible if( n<=1 ) then - if( n==1 )call stdlib_qscal( nrhs, 1._qp / d( 1 ), b, ldb ) + if( n==1 )call stdlib_${ri}$scal( nrhs, 1._${rk}$ / d( 1 ), b, ldb ) return end if ! solve a * x = b using the factorization a = l*d*l**t, @@ -60653,10 +60654,10 @@ module stdlib_linalg_lapack_q end do end do return - end subroutine stdlib_qptts2 + end subroutine stdlib_${ri}$ptts2 - pure subroutine stdlib_qrscl( n, sa, sx, incx ) + pure subroutine stdlib_${ri}$rscl( n, sa, sx, incx ) !! DRSCL: multiplies an n-element real vector x by the real scalar 1/a. !! This is done without overflow or underflow as long as !! the final result x/a does not overflow or underflow. @@ -60665,23 +60666,23 @@ module stdlib_linalg_lapack_q ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments integer(ilp), intent(in) :: incx, n - real(qp), intent(in) :: sa + real(${rk}$), intent(in) :: sa ! Array Arguments - real(qp), intent(inout) :: sx(*) + real(${rk}$), intent(inout) :: sx(*) ! ===================================================================== ! Local Scalars logical(lk) :: done - real(qp) :: bignum, cden, cden1, cnum, cnum1, mul, smlnum + real(${rk}$) :: bignum, cden, cden1, cnum, cnum1, mul, smlnum ! Intrinsic Functions intrinsic :: abs ! Executable Statements ! quick return if possible if( n<=0 )return ! get machine parameters - smlnum = stdlib_qlamch( 'S' ) + smlnum = stdlib_${ri}$lamch( 'S' ) bignum = one / smlnum - call stdlib_qlabad( smlnum, bignum ) + call stdlib_${ri}$labad( smlnum, bignum ) ! initialize the denominator to sa and the numerator to 1. cden = sa cnum = one @@ -60704,13 +60705,13 @@ module stdlib_linalg_lapack_q done = .true. end if ! scale the vector x by mul - call stdlib_qscal( n, mul, sx, incx ) + call stdlib_${ri}$scal( n, mul, sx, incx ) if( .not.done )go to 10 return - end subroutine stdlib_qrscl + end subroutine stdlib_${ri}$rscl - pure subroutine stdlib_qsb2st_kernels( uplo, wantz, ttype,st, ed, sweep, n, nb, ib,a, lda, & + pure subroutine stdlib_${ri}$sb2st_kernels( uplo, wantz, ttype,st, ed, sweep, n, nb, ib,a, lda, & !! DSB2ST_KERNELS: is an internal routine used by the DSYTRD_SB2ST !! subroutine. v, tau, ldvt, work) @@ -60722,14 +60723,14 @@ module stdlib_linalg_lapack_q logical(lk), intent(in) :: wantz integer(ilp), intent(in) :: ttype, st, ed, sweep, n, nb, ib, lda, ldvt ! Array Arguments - real(qp), intent(inout) :: a(lda,*) - real(qp), intent(out) :: v(*), tau(*), work(*) + real(${rk}$), intent(inout) :: a(lda,*) + real(${rk}$), intent(out) :: v(*), tau(*), work(*) ! ===================================================================== ! Local Scalars logical(lk) :: upper integer(ilp) :: i, j1, j2, lm, ln, vpos, taupos, dpos, ofdpos, ajeter - real(qp) :: ctmp + real(${rk}$) :: ctmp ! Intrinsic Functions intrinsic :: mod ! Executable Statements @@ -60759,15 +60760,15 @@ module stdlib_linalg_lapack_q a( ofdpos-i, st+i ) = zero end do ctmp = ( a( ofdpos, st ) ) - call stdlib_qlarfg( lm, ctmp, v( vpos+1 ), 1,tau( taupos ) ) + call stdlib_${ri}$larfg( lm, ctmp, v( vpos+1 ), 1,tau( taupos ) ) a( ofdpos, st ) = ctmp lm = ed - st + 1 - call stdlib_qlarfy( uplo, lm, v( vpos ), 1,( tau( taupos ) ),a( dpos, st ), & + call stdlib_${ri}$larfy( uplo, lm, v( vpos ), 1,( tau( taupos ) ),a( dpos, st ), & lda-1, work) endif if( ttype==3 ) then lm = ed - st + 1 - call stdlib_qlarfy( uplo, lm, v( vpos ), 1,( tau( taupos ) ),a( dpos, st ), & + call stdlib_${ri}$larfy( uplo, lm, v( vpos ), 1,( tau( taupos ) ),a( dpos, st ), & lda-1, work) endif if( ttype==2 ) then @@ -60776,7 +60777,7 @@ module stdlib_linalg_lapack_q ln = ed-st+1 lm = j2-j1+1 if( lm>0) then - call stdlib_qlarfx( 'LEFT', ln, lm, v( vpos ),( tau( taupos ) ),a( dpos-nb,& + call stdlib_${ri}$larfx( 'LEFT', ln, lm, v( vpos ),( tau( taupos ) ),a( dpos-nb,& j1 ), lda-1, work) if( wantz ) then vpos = mod( sweep-1, 2 ) * n + j1 @@ -60791,9 +60792,9 @@ module stdlib_linalg_lapack_q a( dpos-nb-i, j1+i ) = zero end do ctmp = ( a( dpos-nb, j1 ) ) - call stdlib_qlarfg( lm, ctmp, v( vpos+1 ), 1, tau( taupos ) ) + call stdlib_${ri}$larfg( lm, ctmp, v( vpos+1 ), 1, tau( taupos ) ) a( dpos-nb, j1 ) = ctmp - call stdlib_qlarfx( 'RIGHT', ln-1, lm, v( vpos ),tau( taupos ),a( dpos-nb+& + call stdlib_${ri}$larfx( 'RIGHT', ln-1, lm, v( vpos ),tau( taupos ),a( dpos-nb+& 1, j1 ), lda-1, work) endif endif @@ -60813,15 +60814,15 @@ module stdlib_linalg_lapack_q v( vpos+i ) = a( ofdpos+i, st-1 ) a( ofdpos+i, st-1 ) = zero end do - call stdlib_qlarfg( lm, a( ofdpos, st-1 ), v( vpos+1 ), 1,tau( taupos ) ) + call stdlib_${ri}$larfg( lm, a( ofdpos, st-1 ), v( vpos+1 ), 1,tau( taupos ) ) lm = ed - st + 1 - call stdlib_qlarfy( uplo, lm, v( vpos ), 1,( tau( taupos ) ),a( dpos, st ), & + call stdlib_${ri}$larfy( uplo, lm, v( vpos ), 1,( tau( taupos ) ),a( dpos, st ), & lda-1, work) endif if( ttype==3 ) then lm = ed - st + 1 - call stdlib_qlarfy( uplo, lm, v( vpos ), 1,( tau( taupos ) ),a( dpos, st ), & + call stdlib_${ri}$larfy( uplo, lm, v( vpos ), 1,( tau( taupos ) ),a( dpos, st ), & lda-1, work) endif if( ttype==2 ) then @@ -60830,7 +60831,7 @@ module stdlib_linalg_lapack_q ln = ed-st+1 lm = j2-j1+1 if( lm>0) then - call stdlib_qlarfx( 'RIGHT', lm, ln, v( vpos ),tau( taupos ), a( dpos+nb, & + call stdlib_${ri}$larfx( 'RIGHT', lm, ln, v( vpos ),tau( taupos ), a( dpos+nb, & st ),lda-1, work) if( wantz ) then vpos = mod( sweep-1, 2 ) * n + j1 @@ -60844,18 +60845,18 @@ module stdlib_linalg_lapack_q v( vpos+i ) = a( dpos+nb+i, st ) a( dpos+nb+i, st ) = zero end do - call stdlib_qlarfg( lm, a( dpos+nb, st ), v( vpos+1 ), 1,tau( taupos ) ) + call stdlib_${ri}$larfg( lm, a( dpos+nb, st ), v( vpos+1 ), 1,tau( taupos ) ) - call stdlib_qlarfx( 'LEFT', lm, ln-1, v( vpos ),( tau( taupos ) ),a( dpos+& + call stdlib_${ri}$larfx( 'LEFT', lm, ln-1, v( vpos ),( tau( taupos ) ),a( dpos+& nb-1, st+1 ), lda-1, work) endif endif endif return - end subroutine stdlib_qsb2st_kernels + end subroutine stdlib_${ri}$sb2st_kernels - subroutine stdlib_qsbev( jobz, uplo, n, kd, ab, ldab, w, z, ldz, work,info ) + subroutine stdlib_${ri}$sbev( jobz, uplo, n, kd, ab, ldab, w, z, ldz, work,info ) !! DSBEV: computes all the eigenvalues and, optionally, eigenvectors of !! a real symmetric band matrix A. ! -- lapack driver routine -- @@ -60866,14 +60867,14 @@ module stdlib_linalg_lapack_q integer(ilp), intent(out) :: info integer(ilp), intent(in) :: kd, ldab, ldz, n ! Array Arguments - real(qp), intent(inout) :: ab(ldab,*) - real(qp), intent(out) :: w(*), work(*), z(ldz,*) + real(${rk}$), intent(inout) :: ab(ldab,*) + real(${rk}$), intent(out) :: w(*), work(*), z(ldz,*) ! ===================================================================== ! Local Scalars logical(lk) :: lower, wantz integer(ilp) :: iinfo, imax, inde, indwrk, iscale - real(qp) :: anrm, bignum, eps, rmax, rmin, safmin, sigma, smlnum + real(${rk}$) :: anrm, bignum, eps, rmax, rmin, safmin, sigma, smlnum ! Intrinsic Functions intrinsic :: sqrt ! Executable Statements @@ -60910,14 +60911,14 @@ module stdlib_linalg_lapack_q return end if ! get machine constants. - safmin = stdlib_qlamch( 'SAFE MINIMUM' ) - eps = stdlib_qlamch( 'PRECISION' ) + safmin = stdlib_${ri}$lamch( 'SAFE MINIMUM' ) + eps = stdlib_${ri}$lamch( 'PRECISION' ) smlnum = safmin / eps bignum = one / smlnum rmin = sqrt( smlnum ) rmax = sqrt( bignum ) ! scale matrix to allowable range, if necessary. - anrm = stdlib_qlansb( 'M', uplo, n, kd, ab, ldab, work ) + anrm = stdlib_${ri}$lansb( 'M', uplo, n, kd, ab, ldab, work ) iscale = 0 if( anrm>zero .and. anrmzero .and. anrmzero .and. anrm0 )abstll = abstol*sigma if( valeig ) then @@ -61214,15 +61215,15 @@ module stdlib_linalg_lapack_q vuu = vu*sigma end if end if - ! call stdlib_qsbtrd to reduce symmetric band matrix to tridiagonal form. + ! call stdlib_${ri}$sbtrd to reduce symmetric band matrix to tridiagonal form. indd = 1 inde = indd + n indwrk = inde + n - call stdlib_qsbtrd( jobz, uplo, n, kd, ab, ldab, work( indd ),work( inde ), q, ldq, & + call stdlib_${ri}$sbtrd( jobz, uplo, n, kd, ab, ldab, work( indd ),work( inde ), q, ldq, & work( indwrk ), iinfo ) ! if all eigenvalues are desired and abstol is less than or equal - ! to zero, then call stdlib_qsterf or stdlib_dsteqr. if this fails for some - ! eigenvalue, then try stdlib_qstebz. + ! to zero, then call stdlib_${ri}$sterf or stdlib_dsteqr. if this fails for some + ! eigenvalue, then try stdlib_${ri}$stebz. test = .false. if (indeig) then if (il==1 .and. iu==n) then @@ -61230,15 +61231,15 @@ module stdlib_linalg_lapack_q end if end if if ((alleig .or. test) .and. (abstol<=zero)) then - call stdlib_qcopy( n, work( indd ), 1, w, 1 ) + call stdlib_${ri}$copy( n, work( indd ), 1, w, 1 ) indee = indwrk + 2*n if( .not.wantz ) then - call stdlib_qcopy( n-1, work( inde ), 1, work( indee ), 1 ) - call stdlib_qsterf( n, w, work( indee ), info ) + call stdlib_${ri}$copy( n-1, work( inde ), 1, work( indee ), 1 ) + call stdlib_${ri}$sterf( n, w, work( indee ), info ) else - call stdlib_qlacpy( 'A', n, n, q, ldq, z, ldz ) - call stdlib_qcopy( n-1, work( inde ), 1, work( indee ), 1 ) - call stdlib_qsteqr( jobz, n, w, work( indee ), z, ldz,work( indwrk ), info ) + call stdlib_${ri}$lacpy( 'A', n, n, q, ldq, z, ldz ) + call stdlib_${ri}$copy( n-1, work( inde ), 1, work( indee ), 1 ) + call stdlib_${ri}$steqr( jobz, n, w, work( indee ), z, ldz,work( indwrk ), info ) if( info==0 ) then do i = 1, n @@ -61252,7 +61253,7 @@ module stdlib_linalg_lapack_q end if info = 0 end if - ! otherwise, call stdlib_qstebz and, if eigenvectors are desired, stdlib_dstein. + ! otherwise, call stdlib_${ri}$stebz and, if eigenvectors are desired, stdlib_dstein. if( wantz ) then order = 'B' else @@ -61261,17 +61262,17 @@ module stdlib_linalg_lapack_q indibl = 1 indisp = indibl + n indiwo = indisp + n - call stdlib_qstebz( range, order, n, vll, vuu, il, iu, abstll,work( indd ), work( inde & + call stdlib_${ri}$stebz( range, order, n, vll, vuu, il, iu, abstll,work( indd ), work( inde & ), m, nsplit, w,iwork( indibl ), iwork( indisp ), work( indwrk ),iwork( indiwo ), info & ) if( wantz ) then - call stdlib_qstein( n, work( indd ), work( inde ), m, w,iwork( indibl ), iwork( & + call stdlib_${ri}$stein( n, work( indd ), work( inde ), m, w,iwork( indibl ), iwork( & indisp ), z, ldz,work( indwrk ), iwork( indiwo ), ifail, info ) ! apply orthogonal matrix used in reduction to tridiagonal - ! form to eigenvectors returned by stdlib_qstein. + ! form to eigenvectors returned by stdlib_${ri}$stein. do j = 1, m - call stdlib_qcopy( n, z( 1, j ), 1, work( 1 ), 1 ) - call stdlib_qgemv( 'N', n, n, one, q, ldq, work, 1, zero,z( 1, j ), 1 ) + call stdlib_${ri}$copy( n, z( 1, j ), 1, work( 1 ), 1 ) + call stdlib_${ri}$gemv( 'N', n, n, one, q, ldq, work, 1, zero,z( 1, j ), 1 ) end do end if ! if matrix was scaled, then rescale eigenvalues appropriately. @@ -61282,7 +61283,7 @@ module stdlib_linalg_lapack_q else imax = info - 1 end if - call stdlib_qscal( imax, one / sigma, w, 1 ) + call stdlib_${ri}$scal( imax, one / sigma, w, 1 ) end if ! if eigenvalues are not in order, then sort them, along with ! eigenvectors. @@ -61302,7 +61303,7 @@ module stdlib_linalg_lapack_q iwork( indibl+i-1 ) = iwork( indibl+j-1 ) w( j ) = tmp1 iwork( indibl+j-1 ) = itmp1 - call stdlib_qswap( n, z( 1, i ), 1, z( 1, j ), 1 ) + call stdlib_${ri}$swap( n, z( 1, i ), 1, z( 1, j ), 1 ) if( info/=0 ) then itmp1 = ifail( i ) ifail( i ) = ifail( j ) @@ -61312,10 +61313,10 @@ module stdlib_linalg_lapack_q end do end if return - end subroutine stdlib_qsbevx + end subroutine stdlib_${ri}$sbevx - pure subroutine stdlib_qsbgst( vect, uplo, n, ka, kb, ab, ldab, bb, ldbb, x,ldx, work, info ) + pure subroutine stdlib_${ri}$sbgst( vect, uplo, n, ka, kb, ab, ldab, bb, ldbb, x,ldx, work, info ) !! DSBGST: reduces a real symmetric-definite banded generalized !! eigenproblem A*x = lambda*B*x to standard form C*y = lambda*y, !! such that C has the same bandwidth as A. @@ -61332,16 +61333,16 @@ module stdlib_linalg_lapack_q integer(ilp), intent(out) :: info integer(ilp), intent(in) :: ka, kb, ldab, ldbb, ldx, n ! Array Arguments - real(qp), intent(inout) :: ab(ldab,*) - real(qp), intent(in) :: bb(ldbb,*) - real(qp), intent(out) :: work(*), x(ldx,*) + real(${rk}$), intent(inout) :: ab(ldab,*) + real(${rk}$), intent(in) :: bb(ldbb,*) + real(${rk}$), intent(out) :: work(*), x(ldx,*) ! ===================================================================== ! Local Scalars logical(lk) :: update, upper, wantx integer(ilp) :: i, i0, i1, i2, inca, j, j1, j1t, j2, j2t, k, ka1, kb1, kbt, l, m, nr, & nrt, nx - real(qp) :: bii, ra, ra1, t + real(${rk}$) :: bii, ra, ra1, t ! Intrinsic Functions intrinsic :: max,min ! Executable Statements @@ -61376,9 +61377,9 @@ module stdlib_linalg_lapack_q if( n==0 )return inca = ldab*ka1 ! initialize x to the unit matrix, if needed - if( wantx )call stdlib_qlaset( 'FULL', n, n, zero, one, x, ldx ) + if( wantx )call stdlib_${ri}$laset( 'FULL', n, n, zero, one, x, ldx ) ! set m to the splitting point m. it must be the same value as is - ! used in stdlib_qpbstf. the chosen value allows the arrays work and rwork + ! used in stdlib_${ri}$pbstf. the chosen value allows the arrays work and rwork ! to be of dimension (n). m = ( n+kb ) / 2 ! the routine works in two phases, corresponding to the two halves @@ -61476,8 +61477,8 @@ module stdlib_linalg_lapack_q end do if( wantx ) then ! post-multiply x by inv(s(i)) - call stdlib_qscal( n-m, one / bii, x( m+1, i ), 1 ) - if( kbt>0 )call stdlib_qger( n-m, kbt, -one, x( m+1, i ), 1,bb( kb1-kbt, i ), & + call stdlib_${ri}$scal( n-m, one / bii, x( m+1, i ), 1 ) + if( kbt>0 )call stdlib_${ri}$ger( n-m, kbt, -one, x( m+1, i ), 1,bb( kb1-kbt, i ), & 1, x( m+1, i-kbt ), ldx ) end if ! store a(i,i1) in ra1 for use in next loop over k @@ -61492,7 +61493,7 @@ module stdlib_linalg_lapack_q ! which has in theory just been created if( i-k+ka1 ) then ! generate rotation to annihilate a(i,i-k+ka+1) - call stdlib_qlartg( ab( k+1, i-k+ka ), ra1,work( n+i-k+ka-m ), work( i-k+& + call stdlib_${ri}$lartg( ab( k+1, i-k+ka ), ra1,work( n+i-k+ka-m ), work( i-k+& ka-m ),ra ) ! create nonzero element a(i-k,i-k+ka+1) outside the ! band and store it in work(i-k) @@ -61521,29 +61522,29 @@ module stdlib_linalg_lapack_q end do ! generate rotations in 1st set to annihilate elements which ! have been created outside the band - if( nrt>0 )call stdlib_qlargv( nrt, ab( 1, j2t ), inca, work( j2t-m ), ka1,work( & + if( nrt>0 )call stdlib_${ri}$largv( nrt, ab( 1, j2t ), inca, work( j2t-m ), ka1,work( & n+j2t-m ), ka1 ) if( nr>0 ) then ! apply rotations in 1st set from the right do l = 1, ka - 1 - call stdlib_qlartv( nr, ab( ka1-l, j2 ), inca,ab( ka-l, j2+1 ), inca, work(& + call stdlib_${ri}$lartv( nr, ab( ka1-l, j2 ), inca,ab( ka-l, j2+1 ), inca, work(& n+j2-m ),work( j2-m ), ka1 ) end do ! apply rotations in 1st set from both sides to diagonal ! blocks - call stdlib_qlar2v( nr, ab( ka1, j2 ), ab( ka1, j2+1 ),ab( ka, j2+1 ), inca, & + call stdlib_${ri}$lar2v( nr, ab( ka1, j2 ), ab( ka1, j2+1 ),ab( ka, j2+1 ), inca, & work( n+j2-m ),work( j2-m ), ka1 ) end if ! start applying rotations in 1st set from the left do l = ka - 1, kb - k + 1, -1 nrt = ( n-j2+l ) / ka1 - if( nrt>0 )call stdlib_qlartv( nrt, ab( l, j2+ka1-l ), inca,ab( l+1, j2+ka1-l & + if( nrt>0 )call stdlib_${ri}$lartv( nrt, ab( l, j2+ka1-l ), inca,ab( l+1, j2+ka1-l & ), inca,work( n+j2-m ), work( j2-m ), ka1 ) end do if( wantx ) then ! post-multiply x by product of rotations in 1st set do j = j2, j1, ka1 - call stdlib_qrot( n-m, x( m+1, j ), 1, x( m+1, j+1 ), 1,work( n+j-m ), & + call stdlib_${ri}$rot( n-m, x( m+1, j ), 1, x( m+1, j+1 ), 1,work( n+j-m ), & work( j-m ) ) end do end if @@ -61564,7 +61565,7 @@ module stdlib_linalg_lapack_q ! finish applying rotations in 2nd set from the left do l = kb - k, 1, -1 nrt = ( n-j2+ka+l ) / ka1 - if( nrt>0 )call stdlib_qlartv( nrt, ab( l, j2-l+1 ), inca,ab( l+1, j2-l+1 ), & + if( nrt>0 )call stdlib_${ri}$lartv( nrt, ab( l, j2-l+1 ), inca,ab( l+1, j2-l+1 ), & inca, work( n+j2-ka ),work( j2-ka ), ka1 ) end do nr = ( n-j2+ka ) / ka1 @@ -61590,28 +61591,28 @@ module stdlib_linalg_lapack_q if( nr>0 ) then ! generate rotations in 2nd set to annihilate elements ! which have been created outside the band - call stdlib_qlargv( nr, ab( 1, j2 ), inca, work( j2 ), ka1,work( n+j2 ), ka1 ) + call stdlib_${ri}$largv( nr, ab( 1, j2 ), inca, work( j2 ), ka1,work( n+j2 ), ka1 ) ! apply rotations in 2nd set from the right do l = 1, ka - 1 - call stdlib_qlartv( nr, ab( ka1-l, j2 ), inca,ab( ka-l, j2+1 ), inca, work(& + call stdlib_${ri}$lartv( nr, ab( ka1-l, j2 ), inca,ab( ka-l, j2+1 ), inca, work(& n+j2 ),work( j2 ), ka1 ) end do ! apply rotations in 2nd set from both sides to diagonal ! blocks - call stdlib_qlar2v( nr, ab( ka1, j2 ), ab( ka1, j2+1 ),ab( ka, j2+1 ), inca, & + call stdlib_${ri}$lar2v( nr, ab( ka1, j2 ), ab( ka1, j2+1 ),ab( ka, j2+1 ), inca, & work( n+j2 ),work( j2 ), ka1 ) end if ! start applying rotations in 2nd set from the left do l = ka - 1, kb - k + 1, -1 nrt = ( n-j2+l ) / ka1 - if( nrt>0 )call stdlib_qlartv( nrt, ab( l, j2+ka1-l ), inca,ab( l+1, j2+ka1-l & + if( nrt>0 )call stdlib_${ri}$lartv( nrt, ab( l, j2+ka1-l ), inca,ab( l+1, j2+ka1-l & ), inca, work( n+j2 ),work( j2 ), ka1 ) end do if( wantx ) then ! post-multiply x by product of rotations in 2nd set do j = j2, j1, ka1 - call stdlib_qrot( n-m, x( m+1, j ), 1, x( m+1, j+1 ), 1,work( n+j ), work( & + call stdlib_${ri}$rot( n-m, x( m+1, j ), 1, x( m+1, j+1 ), 1,work( n+j ), work( & j ) ) end do end if @@ -61621,7 +61622,7 @@ module stdlib_linalg_lapack_q ! finish applying rotations in 1st set from the left do l = kb - k, 1, -1 nrt = ( n-j2+l ) / ka1 - if( nrt>0 )call stdlib_qlartv( nrt, ab( l, j2+ka1-l ), inca,ab( l+1, j2+ka1-l & + if( nrt>0 )call stdlib_${ri}$lartv( nrt, ab( l, j2+ka1-l ), inca,ab( l+1, j2+ka1-l & ), inca,work( n+j2-m ), work( j2-m ), ka1 ) end do end do @@ -61658,8 +61659,8 @@ module stdlib_linalg_lapack_q end do if( wantx ) then ! post-multiply x by inv(s(i)) - call stdlib_qscal( n-m, one / bii, x( m+1, i ), 1 ) - if( kbt>0 )call stdlib_qger( n-m, kbt, -one, x( m+1, i ), 1,bb( kbt+1, i-kbt )& + call stdlib_${ri}$scal( n-m, one / bii, x( m+1, i ), 1 ) + if( kbt>0 )call stdlib_${ri}$ger( n-m, kbt, -one, x( m+1, i ), 1,bb( kbt+1, i-kbt )& , ldbb-1,x( m+1, i-kbt ), ldx ) end if ! store a(i1,i) in ra1 for use in next loop over k @@ -61674,7 +61675,7 @@ module stdlib_linalg_lapack_q ! which has in theory just been created if( i-k+ka1 ) then ! generate rotation to annihilate a(i-k+ka+1,i) - call stdlib_qlartg( ab( ka1-k, i ), ra1, work( n+i-k+ka-m ),work( i-k+ka-m & + call stdlib_${ri}$lartg( ab( ka1-k, i ), ra1, work( n+i-k+ka-m ),work( i-k+ka-m & ), ra ) ! create nonzero element a(i-k+ka+1,i-k) outside the ! band and store it in work(i-k) @@ -61702,29 +61703,29 @@ module stdlib_linalg_lapack_q end do ! generate rotations in 1st set to annihilate elements which ! have been created outside the band - if( nrt>0 )call stdlib_qlargv( nrt, ab( ka1, j2t-ka ), inca, work( j2t-m ),ka1, & + if( nrt>0 )call stdlib_${ri}$largv( nrt, ab( ka1, j2t-ka ), inca, work( j2t-m ),ka1, & work( n+j2t-m ), ka1 ) if( nr>0 ) then ! apply rotations in 1st set from the left do l = 1, ka - 1 - call stdlib_qlartv( nr, ab( l+1, j2-l ), inca,ab( l+2, j2-l ), inca, work( & + call stdlib_${ri}$lartv( nr, ab( l+1, j2-l ), inca,ab( l+2, j2-l ), inca, work( & n+j2-m ),work( j2-m ), ka1 ) end do ! apply rotations in 1st set from both sides to diagonal ! blocks - call stdlib_qlar2v( nr, ab( 1, j2 ), ab( 1, j2+1 ), ab( 2, j2 ),inca, work( n+& + call stdlib_${ri}$lar2v( nr, ab( 1, j2 ), ab( 1, j2+1 ), ab( 2, j2 ),inca, work( n+& j2-m ), work( j2-m ), ka1 ) end if ! start applying rotations in 1st set from the right do l = ka - 1, kb - k + 1, -1 nrt = ( n-j2+l ) / ka1 - if( nrt>0 )call stdlib_qlartv( nrt, ab( ka1-l+1, j2 ), inca,ab( ka1-l, j2+1 ),& + if( nrt>0 )call stdlib_${ri}$lartv( nrt, ab( ka1-l+1, j2 ), inca,ab( ka1-l, j2+1 ),& inca, work( n+j2-m ),work( j2-m ), ka1 ) end do if( wantx ) then ! post-multiply x by product of rotations in 1st set do j = j2, j1, ka1 - call stdlib_qrot( n-m, x( m+1, j ), 1, x( m+1, j+1 ), 1,work( n+j-m ), & + call stdlib_${ri}$rot( n-m, x( m+1, j ), 1, x( m+1, j+1 ), 1,work( n+j-m ), & work( j-m ) ) end do end if @@ -61745,7 +61746,7 @@ module stdlib_linalg_lapack_q ! finish applying rotations in 2nd set from the right do l = kb - k, 1, -1 nrt = ( n-j2+ka+l ) / ka1 - if( nrt>0 )call stdlib_qlartv( nrt, ab( ka1-l+1, j2-ka ), inca,ab( ka1-l, j2-& + if( nrt>0 )call stdlib_${ri}$lartv( nrt, ab( ka1-l+1, j2-ka ), inca,ab( ka1-l, j2-& ka+1 ), inca,work( n+j2-ka ), work( j2-ka ), ka1 ) end do nr = ( n-j2+ka ) / ka1 @@ -61771,28 +61772,28 @@ module stdlib_linalg_lapack_q if( nr>0 ) then ! generate rotations in 2nd set to annihilate elements ! which have been created outside the band - call stdlib_qlargv( nr, ab( ka1, j2-ka ), inca, work( j2 ), ka1,work( n+j2 ), & + call stdlib_${ri}$largv( nr, ab( ka1, j2-ka ), inca, work( j2 ), ka1,work( n+j2 ), & ka1 ) ! apply rotations in 2nd set from the left do l = 1, ka - 1 - call stdlib_qlartv( nr, ab( l+1, j2-l ), inca,ab( l+2, j2-l ), inca, work( & + call stdlib_${ri}$lartv( nr, ab( l+1, j2-l ), inca,ab( l+2, j2-l ), inca, work( & n+j2 ),work( j2 ), ka1 ) end do ! apply rotations in 2nd set from both sides to diagonal ! blocks - call stdlib_qlar2v( nr, ab( 1, j2 ), ab( 1, j2+1 ), ab( 2, j2 ),inca, work( n+& + call stdlib_${ri}$lar2v( nr, ab( 1, j2 ), ab( 1, j2+1 ), ab( 2, j2 ),inca, work( n+& j2 ), work( j2 ), ka1 ) end if ! start applying rotations in 2nd set from the right do l = ka - 1, kb - k + 1, -1 nrt = ( n-j2+l ) / ka1 - if( nrt>0 )call stdlib_qlartv( nrt, ab( ka1-l+1, j2 ), inca,ab( ka1-l, j2+1 ),& + if( nrt>0 )call stdlib_${ri}$lartv( nrt, ab( ka1-l+1, j2 ), inca,ab( ka1-l, j2+1 ),& inca, work( n+j2 ),work( j2 ), ka1 ) end do if( wantx ) then ! post-multiply x by product of rotations in 2nd set do j = j2, j1, ka1 - call stdlib_qrot( n-m, x( m+1, j ), 1, x( m+1, j+1 ), 1,work( n+j ), work( & + call stdlib_${ri}$rot( n-m, x( m+1, j ), 1, x( m+1, j+1 ), 1,work( n+j ), work( & j ) ) end do end if @@ -61802,7 +61803,7 @@ module stdlib_linalg_lapack_q ! finish applying rotations in 1st set from the right do l = kb - k, 1, -1 nrt = ( n-j2+l ) / ka1 - if( nrt>0 )call stdlib_qlartv( nrt, ab( ka1-l+1, j2 ), inca,ab( ka1-l, j2+1 ),& + if( nrt>0 )call stdlib_${ri}$lartv( nrt, ab( ka1-l+1, j2 ), inca,ab( ka1-l, j2+1 ),& inca, work( n+j2-m ),work( j2-m ), ka1 ) end do end do @@ -61882,8 +61883,8 @@ module stdlib_linalg_lapack_q end do if( wantx ) then ! post-multiply x by inv(s(i)) - call stdlib_qscal( nx, one / bii, x( 1, i ), 1 ) - if( kbt>0 )call stdlib_qger( nx, kbt, -one, x( 1, i ), 1, bb( kb, i+1 ),ldbb-& + call stdlib_${ri}$scal( nx, one / bii, x( 1, i ), 1 ) + if( kbt>0 )call stdlib_${ri}$ger( nx, kbt, -one, x( 1, i ), 1, bb( kb, i+1 ),ldbb-& 1, x( 1, i+1 ), ldx ) end if ! store a(i1,i) in ra1 for use in next loop over k @@ -61897,7 +61898,7 @@ module stdlib_linalg_lapack_q ! which has in theory just been created if( i+k-ka1>0 .and. i+k0 )call stdlib_qlargv( nrt, ab( 1, j1+ka ), inca, work( j1 ), ka1,work( & + if( nrt>0 )call stdlib_${ri}$largv( nrt, ab( 1, j1+ka ), inca, work( j1 ), ka1,work( & n+j1 ), ka1 ) if( nr>0 ) then ! apply rotations in 1st set from the left do l = 1, ka - 1 - call stdlib_qlartv( nr, ab( ka1-l, j1+l ), inca,ab( ka-l, j1+l ), inca, & + call stdlib_${ri}$lartv( nr, ab( ka1-l, j1+l ), inca,ab( ka-l, j1+l ), inca, & work( n+j1 ),work( j1 ), ka1 ) end do ! apply rotations in 1st set from both sides to diagonal ! blocks - call stdlib_qlar2v( nr, ab( ka1, j1 ), ab( ka1, j1-1 ),ab( ka, j1 ), inca, & + call stdlib_${ri}$lar2v( nr, ab( ka1, j1 ), ab( ka1, j1-1 ),ab( ka, j1 ), inca, & work( n+j1 ),work( j1 ), ka1 ) end if ! start applying rotations in 1st set from the right do l = ka - 1, kb - k + 1, -1 nrt = ( j2+l-1 ) / ka1 j1t = j2 - ( nrt-1 )*ka1 - if( nrt>0 )call stdlib_qlartv( nrt, ab( l, j1t ), inca,ab( l+1, j1t-1 ), inca,& + if( nrt>0 )call stdlib_${ri}$lartv( nrt, ab( l, j1t ), inca,ab( l+1, j1t-1 ), inca,& work( n+j1t ),work( j1t ), ka1 ) end do if( wantx ) then ! post-multiply x by product of rotations in 1st set do j = j1, j2, ka1 - call stdlib_qrot( nx, x( 1, j ), 1, x( 1, j-1 ), 1,work( n+j ), work( j ) ) + call stdlib_${ri}$rot( nx, x( 1, j ), 1, x( 1, j-1 ), 1,work( n+j ), work( j ) ) end do end if @@ -61969,7 +61970,7 @@ module stdlib_linalg_lapack_q do l = kb - k, 1, -1 nrt = ( j2+ka+l-1 ) / ka1 j1t = j2 - ( nrt-1 )*ka1 - if( nrt>0 )call stdlib_qlartv( nrt, ab( l, j1t+ka ), inca,ab( l+1, j1t+ka-1 ),& + if( nrt>0 )call stdlib_${ri}$lartv( nrt, ab( l, j1t+ka ), inca,ab( l+1, j1t+ka-1 ),& inca,work( n+m-kb+j1t+ka ),work( m-kb+j1t+ka ), ka1 ) end do nr = ( j2+ka-1 ) / ka1 @@ -61995,29 +61996,29 @@ module stdlib_linalg_lapack_q if( nr>0 ) then ! generate rotations in 2nd set to annihilate elements ! which have been created outside the band - call stdlib_qlargv( nr, ab( 1, j1+ka ), inca, work( m-kb+j1 ),ka1, work( n+m-& + call stdlib_${ri}$largv( nr, ab( 1, j1+ka ), inca, work( m-kb+j1 ),ka1, work( n+m-& kb+j1 ), ka1 ) ! apply rotations in 2nd set from the left do l = 1, ka - 1 - call stdlib_qlartv( nr, ab( ka1-l, j1+l ), inca,ab( ka-l, j1+l ), inca,& + call stdlib_${ri}$lartv( nr, ab( ka1-l, j1+l ), inca,ab( ka-l, j1+l ), inca,& work( n+m-kb+j1 ), work( m-kb+j1 ), ka1 ) end do ! apply rotations in 2nd set from both sides to diagonal ! blocks - call stdlib_qlar2v( nr, ab( ka1, j1 ), ab( ka1, j1-1 ),ab( ka, j1 ), inca, & + call stdlib_${ri}$lar2v( nr, ab( ka1, j1 ), ab( ka1, j1-1 ),ab( ka, j1 ), inca, & work( n+m-kb+j1 ),work( m-kb+j1 ), ka1 ) end if ! start applying rotations in 2nd set from the right do l = ka - 1, kb - k + 1, -1 nrt = ( j2+l-1 ) / ka1 j1t = j2 - ( nrt-1 )*ka1 - if( nrt>0 )call stdlib_qlartv( nrt, ab( l, j1t ), inca,ab( l+1, j1t-1 ), inca,& + if( nrt>0 )call stdlib_${ri}$lartv( nrt, ab( l, j1t ), inca,ab( l+1, j1t-1 ), inca,& work( n+m-kb+j1t ), work( m-kb+j1t ),ka1 ) end do if( wantx ) then ! post-multiply x by product of rotations in 2nd set do j = j1, j2, ka1 - call stdlib_qrot( nx, x( 1, j ), 1, x( 1, j-1 ), 1,work( n+m-kb+j ), work( & + call stdlib_${ri}$rot( nx, x( 1, j ), 1, x( 1, j-1 ), 1,work( n+m-kb+j ), work( & m-kb+j ) ) end do end if @@ -62028,7 +62029,7 @@ module stdlib_linalg_lapack_q do l = kb - k, 1, -1 nrt = ( j2+l-1 ) / ka1 j1t = j2 - ( nrt-1 )*ka1 - if( nrt>0 )call stdlib_qlartv( nrt, ab( l, j1t ), inca,ab( l+1, j1t-1 ), inca,& + if( nrt>0 )call stdlib_${ri}$lartv( nrt, ab( l, j1t ), inca,ab( l+1, j1t-1 ), inca,& work( n+j1t ),work( j1t ), ka1 ) end do end do @@ -62065,8 +62066,8 @@ module stdlib_linalg_lapack_q end do if( wantx ) then ! post-multiply x by inv(s(i)) - call stdlib_qscal( nx, one / bii, x( 1, i ), 1 ) - if( kbt>0 )call stdlib_qger( nx, kbt, -one, x( 1, i ), 1, bb( 2, i ), 1,x( 1, & + call stdlib_${ri}$scal( nx, one / bii, x( 1, i ), 1 ) + if( kbt>0 )call stdlib_${ri}$ger( nx, kbt, -one, x( 1, i ), 1, bb( 2, i ), 1,x( 1, & i+1 ), ldx ) end if ! store a(i,i1) in ra1 for use in next loop over k @@ -62080,7 +62081,7 @@ module stdlib_linalg_lapack_q ! which has in theory just been created if( i+k-ka1>0 .and. i+k0 )call stdlib_qlargv( nrt, ab( ka1, j1 ), inca, work( j1 ), ka1,work( n+& + if( nrt>0 )call stdlib_${ri}$largv( nrt, ab( ka1, j1 ), inca, work( j1 ), ka1,work( n+& j1 ), ka1 ) if( nr>0 ) then ! apply rotations in 1st set from the right do l = 1, ka - 1 - call stdlib_qlartv( nr, ab( l+1, j1 ), inca, ab( l+2, j1-1 ),inca, work( n+& + call stdlib_${ri}$lartv( nr, ab( l+1, j1 ), inca, ab( l+2, j1-1 ),inca, work( n+& j1 ), work( j1 ), ka1 ) end do ! apply rotations in 1st set from both sides to diagonal ! blocks - call stdlib_qlar2v( nr, ab( 1, j1 ), ab( 1, j1-1 ),ab( 2, j1-1 ), inca, work( & + call stdlib_${ri}$lar2v( nr, ab( 1, j1 ), ab( 1, j1-1 ),ab( 2, j1-1 ), inca, work( & n+j1 ),work( j1 ), ka1 ) end if ! start applying rotations in 1st set from the left do l = ka - 1, kb - k + 1, -1 nrt = ( j2+l-1 ) / ka1 j1t = j2 - ( nrt-1 )*ka1 - if( nrt>0 )call stdlib_qlartv( nrt, ab( ka1-l+1, j1t-ka1+l ), inca,ab( ka1-l, & + if( nrt>0 )call stdlib_${ri}$lartv( nrt, ab( ka1-l+1, j1t-ka1+l ), inca,ab( ka1-l, & j1t-ka1+l ), inca,work( n+j1t ), work( j1t ), ka1 ) end do if( wantx ) then ! post-multiply x by product of rotations in 1st set do j = j1, j2, ka1 - call stdlib_qrot( nx, x( 1, j ), 1, x( 1, j-1 ), 1,work( n+j ), work( j ) ) + call stdlib_${ri}$rot( nx, x( 1, j ), 1, x( 1, j-1 ), 1,work( n+j ), work( j ) ) end do end if @@ -62154,7 +62155,7 @@ module stdlib_linalg_lapack_q do l = kb - k, 1, -1 nrt = ( j2+ka+l-1 ) / ka1 j1t = j2 - ( nrt-1 )*ka1 - if( nrt>0 )call stdlib_qlartv( nrt, ab( ka1-l+1, j1t+l-1 ), inca,ab( ka1-l, & + if( nrt>0 )call stdlib_${ri}$lartv( nrt, ab( ka1-l+1, j1t+l-1 ), inca,ab( ka1-l, & j1t+l-1 ), inca,work( n+m-kb+j1t+ka ),work( m-kb+j1t+ka ), ka1 ) end do nr = ( j2+ka-1 ) / ka1 @@ -62180,29 +62181,29 @@ module stdlib_linalg_lapack_q if( nr>0 ) then ! generate rotations in 2nd set to annihilate elements ! which have been created outside the band - call stdlib_qlargv( nr, ab( ka1, j1 ), inca, work( m-kb+j1 ),ka1, work( n+m-& + call stdlib_${ri}$largv( nr, ab( ka1, j1 ), inca, work( m-kb+j1 ),ka1, work( n+m-& kb+j1 ), ka1 ) ! apply rotations in 2nd set from the right do l = 1, ka - 1 - call stdlib_qlartv( nr, ab( l+1, j1 ), inca, ab( l+2, j1-1 ),inca, work( n+& + call stdlib_${ri}$lartv( nr, ab( l+1, j1 ), inca, ab( l+2, j1-1 ),inca, work( n+& m-kb+j1 ), work( m-kb+j1 ),ka1 ) end do ! apply rotations in 2nd set from both sides to diagonal ! blocks - call stdlib_qlar2v( nr, ab( 1, j1 ), ab( 1, j1-1 ),ab( 2, j1-1 ), inca, work( & + call stdlib_${ri}$lar2v( nr, ab( 1, j1 ), ab( 1, j1-1 ),ab( 2, j1-1 ), inca, work( & n+m-kb+j1 ),work( m-kb+j1 ), ka1 ) end if ! start applying rotations in 2nd set from the left do l = ka - 1, kb - k + 1, -1 nrt = ( j2+l-1 ) / ka1 j1t = j2 - ( nrt-1 )*ka1 - if( nrt>0 )call stdlib_qlartv( nrt, ab( ka1-l+1, j1t-ka1+l ), inca,ab( ka1-l, & + if( nrt>0 )call stdlib_${ri}$lartv( nrt, ab( ka1-l+1, j1t-ka1+l ), inca,ab( ka1-l, & j1t-ka1+l ), inca,work( n+m-kb+j1t ), work( m-kb+j1t ),ka1 ) end do if( wantx ) then ! post-multiply x by product of rotations in 2nd set do j = j1, j2, ka1 - call stdlib_qrot( nx, x( 1, j ), 1, x( 1, j-1 ), 1,work( n+m-kb+j ), work( & + call stdlib_${ri}$rot( nx, x( 1, j ), 1, x( 1, j-1 ), 1,work( n+m-kb+j ), work( & m-kb+j ) ) end do end if @@ -62213,7 +62214,7 @@ module stdlib_linalg_lapack_q do l = kb - k, 1, -1 nrt = ( j2+l-1 ) / ka1 j1t = j2 - ( nrt-1 )*ka1 - if( nrt>0 )call stdlib_qlartv( nrt, ab( ka1-l+1, j1t-ka1+l ), inca,ab( ka1-l, & + if( nrt>0 )call stdlib_${ri}$lartv( nrt, ab( ka1-l+1, j1t-ka1+l ), inca,ab( ka1-l, & j1t-ka1+l ), inca,work( n+j1t ), work( j1t ), ka1 ) end do end do @@ -62225,10 +62226,10 @@ module stdlib_linalg_lapack_q end if end if go to 490 - end subroutine stdlib_qsbgst + end subroutine stdlib_${ri}$sbgst - pure subroutine stdlib_qsbgv( jobz, uplo, n, ka, kb, ab, ldab, bb, ldbb, w, z,ldz, work, & + pure subroutine stdlib_${ri}$sbgv( jobz, uplo, n, ka, kb, ab, ldab, bb, ldbb, w, z,ldz, work, & !! DSBGV: computes all the eigenvalues, and optionally, the eigenvectors !! of a real generalized symmetric-definite banded eigenproblem, of !! the form A*x=(lambda)*B*x. Here A and B are assumed to be symmetric @@ -62242,8 +62243,8 @@ module stdlib_linalg_lapack_q integer(ilp), intent(out) :: info integer(ilp), intent(in) :: ka, kb, ldab, ldbb, ldz, n ! Array Arguments - real(qp), intent(inout) :: ab(ldab,*), bb(ldbb,*) - real(qp), intent(out) :: w(*), work(*), z(ldz,*) + real(${rk}$), intent(inout) :: ab(ldab,*), bb(ldbb,*) + real(${rk}$), intent(out) :: w(*), work(*), z(ldz,*) ! ===================================================================== ! Local Scalars logical(lk) :: upper, wantz @@ -62278,7 +62279,7 @@ module stdlib_linalg_lapack_q ! quick return if possible if( n==0 )return ! form a split cholesky factorization of b. - call stdlib_qpbstf( uplo, n, kb, bb, ldbb, info ) + call stdlib_${ri}$pbstf( uplo, n, kb, bb, ldbb, info ) if( info/=0 ) then info = n + info return @@ -62286,7 +62287,7 @@ module stdlib_linalg_lapack_q ! transform problem to standard eigenvalue problem. inde = 1 indwrk = inde + n - call stdlib_qsbgst( jobz, uplo, n, ka, kb, ab, ldab, bb, ldbb, z, ldz,work( indwrk ), & + call stdlib_${ri}$sbgst( jobz, uplo, n, ka, kb, ab, ldab, bb, ldbb, z, ldz,work( indwrk ), & iinfo ) ! reduce to tridiagonal form. if( wantz ) then @@ -62294,19 +62295,19 @@ module stdlib_linalg_lapack_q else vect = 'N' end if - call stdlib_qsbtrd( vect, uplo, n, ka, ab, ldab, w, work( inde ), z, ldz,work( indwrk )& + call stdlib_${ri}$sbtrd( vect, uplo, n, ka, ab, ldab, w, work( inde ), z, ldz,work( indwrk )& , iinfo ) - ! for eigenvalues only, call stdlib_qsterf. for eigenvectors, call stdlib_dsteqr. + ! for eigenvalues only, call stdlib_${ri}$sterf. for eigenvectors, call stdlib_dsteqr. if( .not.wantz ) then - call stdlib_qsterf( n, w, work( inde ), info ) + call stdlib_${ri}$sterf( n, w, work( inde ), info ) else - call stdlib_qsteqr( jobz, n, w, work( inde ), z, ldz, work( indwrk ),info ) + call stdlib_${ri}$steqr( jobz, n, w, work( inde ), z, ldz, work( indwrk ),info ) end if return - end subroutine stdlib_qsbgv + end subroutine stdlib_${ri}$sbgv - pure subroutine stdlib_qsbgvd( jobz, uplo, n, ka, kb, ab, ldab, bb, ldbb, w,z, ldz, work, & + pure subroutine stdlib_${ri}$sbgvd( jobz, uplo, n, ka, kb, ab, ldab, bb, ldbb, w,z, ldz, work, & !! DSBGVD: computes all the eigenvalues, and optionally, the eigenvectors !! of a real generalized symmetric-definite banded eigenproblem, of the !! form A*x=(lambda)*B*x. Here A and B are assumed to be symmetric and @@ -62328,8 +62329,8 @@ module stdlib_linalg_lapack_q integer(ilp), intent(in) :: ka, kb, ldab, ldbb, ldz, liwork, lwork, n ! Array Arguments integer(ilp), intent(out) :: iwork(*) - real(qp), intent(inout) :: ab(ldab,*), bb(ldbb,*) - real(qp), intent(out) :: w(*), work(*), z(ldz,*) + real(${rk}$), intent(inout) :: ab(ldab,*), bb(ldbb,*) + real(${rk}$), intent(out) :: w(*), work(*), z(ldz,*) ! ===================================================================== ! Local Scalars @@ -62387,7 +62388,7 @@ module stdlib_linalg_lapack_q ! quick return if possible if( n==0 )return ! form a split cholesky factorization of b. - call stdlib_qpbstf( uplo, n, kb, bb, ldbb, info ) + call stdlib_${ri}$pbstf( uplo, n, kb, bb, ldbb, info ) if( info/=0 ) then info = n + info return @@ -62397,7 +62398,7 @@ module stdlib_linalg_lapack_q indwrk = inde + n indwk2 = indwrk + n*n llwrk2 = lwork - indwk2 + 1 - call stdlib_qsbgst( jobz, uplo, n, ka, kb, ab, ldab, bb, ldbb, z, ldz,work, iinfo ) + call stdlib_${ri}$sbgst( jobz, uplo, n, ka, kb, ab, ldab, bb, ldbb, z, ldz,work, iinfo ) ! reduce to tridiagonal form. if( wantz ) then @@ -62405,25 +62406,25 @@ module stdlib_linalg_lapack_q else vect = 'N' end if - call stdlib_qsbtrd( vect, uplo, n, ka, ab, ldab, w, work( inde ), z, ldz,work( indwrk )& + call stdlib_${ri}$sbtrd( vect, uplo, n, ka, ab, ldab, w, work( inde ), z, ldz,work( indwrk )& , iinfo ) - ! for eigenvalues only, call stdlib_qsterf. for eigenvectors, call stdlib_dstedc. + ! for eigenvalues only, call stdlib_${ri}$sterf. for eigenvectors, call stdlib_dstedc. if( .not.wantz ) then - call stdlib_qsterf( n, w, work( inde ), info ) + call stdlib_${ri}$sterf( n, w, work( inde ), info ) else - call stdlib_qstedc( 'I', n, w, work( inde ), work( indwrk ), n,work( indwk2 ), & + call stdlib_${ri}$stedc( 'I', n, w, work( inde ), work( indwrk ), n,work( indwk2 ), & llwrk2, iwork, liwork, info ) - call stdlib_qgemm( 'N', 'N', n, n, n, one, z, ldz, work( indwrk ), n,zero, work( & + call stdlib_${ri}$gemm( 'N', 'N', n, n, n, one, z, ldz, work( indwrk ), n,zero, work( & indwk2 ), n ) - call stdlib_qlacpy( 'A', n, n, work( indwk2 ), n, z, ldz ) + call stdlib_${ri}$lacpy( 'A', n, n, work( indwk2 ), n, z, ldz ) end if work( 1 ) = lwmin iwork( 1 ) = liwmin return - end subroutine stdlib_qsbgvd + end subroutine stdlib_${ri}$sbgvd - pure subroutine stdlib_qsbgvx( jobz, range, uplo, n, ka, kb, ab, ldab, bb,ldbb, q, ldq, vl, & + pure subroutine stdlib_${ri}$sbgvx( jobz, range, uplo, n, ka, kb, ab, ldab, bb,ldbb, q, ldq, vl, & !! DSBGVX: computes selected eigenvalues, and optionally, eigenvectors !! of a real generalized symmetric-definite banded eigenproblem, of !! the form A*x=(lambda)*B*x. Here A and B are assumed to be symmetric @@ -62438,11 +62439,11 @@ module stdlib_linalg_lapack_q character, intent(in) :: jobz, range, uplo integer(ilp), intent(in) :: il, iu, ka, kb, ldab, ldbb, ldq, ldz, n integer(ilp), intent(out) :: info, m - real(qp), intent(in) :: abstol, vl, vu + real(${rk}$), intent(in) :: abstol, vl, vu ! Array Arguments integer(ilp), intent(out) :: ifail(*), iwork(*) - real(qp), intent(inout) :: ab(ldab,*), bb(ldbb,*) - real(qp), intent(out) :: q(ldq,*), w(*), work(*), z(ldz,*) + real(${rk}$), intent(inout) :: ab(ldab,*), bb(ldbb,*) + real(${rk}$), intent(out) :: q(ldq,*), w(*), work(*), z(ldz,*) ! ===================================================================== ! Local Scalars @@ -62450,7 +62451,7 @@ module stdlib_linalg_lapack_q character :: order, vect integer(ilp) :: i, iinfo, indd, inde, indee, indibl, indisp, indiwo, indwrk, itmp1, j, & jj, nsplit - real(qp) :: tmp1 + real(${rk}$) :: tmp1 ! Intrinsic Functions intrinsic :: min ! Executable Statements @@ -62503,13 +62504,13 @@ module stdlib_linalg_lapack_q m = 0 if( n==0 )return ! form a split cholesky factorization of b. - call stdlib_qpbstf( uplo, n, kb, bb, ldbb, info ) + call stdlib_${ri}$pbstf( uplo, n, kb, bb, ldbb, info ) if( info/=0 ) then info = n + info return end if ! transform problem to standard eigenvalue problem. - call stdlib_qsbgst( jobz, uplo, n, ka, kb, ab, ldab, bb, ldbb, q, ldq,work, iinfo ) + call stdlib_${ri}$sbgst( jobz, uplo, n, ka, kb, ab, ldab, bb, ldbb, q, ldq,work, iinfo ) ! reduce symmetric band matrix to tridiagonal form. indd = 1 @@ -62520,11 +62521,11 @@ module stdlib_linalg_lapack_q else vect = 'N' end if - call stdlib_qsbtrd( vect, uplo, n, ka, ab, ldab, work( indd ),work( inde ), q, ldq, & + call stdlib_${ri}$sbtrd( vect, uplo, n, ka, ab, ldab, work( indd ),work( inde ), q, ldq, & work( indwrk ), iinfo ) ! if all eigenvalues are desired and abstol is less than or equal - ! to zero, then call stdlib_qsterf or stdlib_dsteqr. if this fails for some - ! eigenvalue, then try stdlib_qstebz. + ! to zero, then call stdlib_${ri}$sterf or stdlib_dsteqr. if this fails for some + ! eigenvalue, then try stdlib_${ri}$stebz. test = .false. if( indeig ) then if( il==1 .and. iu==n ) then @@ -62532,14 +62533,14 @@ module stdlib_linalg_lapack_q end if end if if( ( alleig .or. test ) .and. ( abstol<=zero ) ) then - call stdlib_qcopy( n, work( indd ), 1, w, 1 ) + call stdlib_${ri}$copy( n, work( indd ), 1, w, 1 ) indee = indwrk + 2*n - call stdlib_qcopy( n-1, work( inde ), 1, work( indee ), 1 ) + call stdlib_${ri}$copy( n-1, work( inde ), 1, work( indee ), 1 ) if( .not.wantz ) then - call stdlib_qsterf( n, w, work( indee ), info ) + call stdlib_${ri}$sterf( n, w, work( indee ), info ) else - call stdlib_qlacpy( 'A', n, n, q, ldq, z, ldz ) - call stdlib_qsteqr( jobz, n, w, work( indee ), z, ldz,work( indwrk ), info ) + call stdlib_${ri}$lacpy( 'A', n, n, q, ldq, z, ldz ) + call stdlib_${ri}$steqr( jobz, n, w, work( indee ), z, ldz,work( indwrk ), info ) if( info==0 ) then do i = 1, n @@ -62553,8 +62554,8 @@ module stdlib_linalg_lapack_q end if info = 0 end if - ! otherwise, call stdlib_qstebz and, if eigenvectors are desired, - ! call stdlib_qstein. + ! otherwise, call stdlib_${ri}$stebz and, if eigenvectors are desired, + ! call stdlib_${ri}$stein. if( wantz ) then order = 'B' else @@ -62563,17 +62564,17 @@ module stdlib_linalg_lapack_q indibl = 1 indisp = indibl + n indiwo = indisp + n - call stdlib_qstebz( range, order, n, vl, vu, il, iu, abstol,work( indd ), work( inde ),& + call stdlib_${ri}$stebz( range, order, n, vl, vu, il, iu, abstol,work( indd ), work( inde ),& m, nsplit, w,iwork( indibl ), iwork( indisp ), work( indwrk ),iwork( indiwo ), info ) if( wantz ) then - call stdlib_qstein( n, work( indd ), work( inde ), m, w,iwork( indibl ), iwork( & + call stdlib_${ri}$stein( n, work( indd ), work( inde ), m, w,iwork( indibl ), iwork( & indisp ), z, ldz,work( indwrk ), iwork( indiwo ), ifail, info ) ! apply transformation matrix used in reduction to tridiagonal - ! form to eigenvectors returned by stdlib_qstein. + ! form to eigenvectors returned by stdlib_${ri}$stein. do j = 1, m - call stdlib_qcopy( n, z( 1, j ), 1, work( 1 ), 1 ) - call stdlib_qgemv( 'N', n, n, one, q, ldq, work, 1, zero,z( 1, j ), 1 ) + call stdlib_${ri}$copy( n, z( 1, j ), 1, work( 1 ), 1 ) + call stdlib_${ri}$gemv( 'N', n, n, one, q, ldq, work, 1, zero,z( 1, j ), 1 ) end do end if 30 continue @@ -62595,7 +62596,7 @@ module stdlib_linalg_lapack_q iwork( indibl+i-1 ) = iwork( indibl+j-1 ) w( j ) = tmp1 iwork( indibl+j-1 ) = itmp1 - call stdlib_qswap( n, z( 1, i ), 1, z( 1, j ), 1 ) + call stdlib_${ri}$swap( n, z( 1, i ), 1, z( 1, j ), 1 ) if( info/=0 ) then itmp1 = ifail( i ) ifail( i ) = ifail( j ) @@ -62605,10 +62606,10 @@ module stdlib_linalg_lapack_q end do end if return - end subroutine stdlib_qsbgvx + end subroutine stdlib_${ri}$sbgvx - pure subroutine stdlib_qsbtrd( vect, uplo, n, kd, ab, ldab, d, e, q, ldq,work, info ) + pure subroutine stdlib_${ri}$sbtrd( vect, uplo, n, kd, ab, ldab, d, e, q, ldq,work, info ) !! DSBTRD: reduces a real symmetric band matrix A to symmetric !! tridiagonal form T by an orthogonal similarity transformation: !! Q**T * A * Q = T. @@ -62620,15 +62621,15 @@ module stdlib_linalg_lapack_q integer(ilp), intent(out) :: info integer(ilp), intent(in) :: kd, ldab, ldq, n ! Array Arguments - real(qp), intent(inout) :: ab(ldab,*), q(ldq,*) - real(qp), intent(out) :: d(*), e(*), work(*) + real(${rk}$), intent(inout) :: ab(ldab,*), q(ldq,*) + real(${rk}$), intent(out) :: d(*), e(*), work(*) ! ===================================================================== ! Local Scalars logical(lk) :: initq, upper, wantq integer(ilp) :: i, i2, ibl, inca, incx, iqaend, iqb, iqend, j, j1, j1end, j1inc, j2, & jend, jin, jinc, k, kd1, kdm1, kdn, l, last, lend, nq, nr, nrt - real(qp) :: temp + real(${rk}$) :: temp ! Intrinsic Functions intrinsic :: max,min ! Executable Statements @@ -62661,7 +62662,7 @@ module stdlib_linalg_lapack_q ! quick return if possible if( n==0 )return ! initialize q to the unit matrix, if needed - if( initq )call stdlib_qlaset( 'FULL', n, n, zero, one, q, ldq ) + if( initq )call stdlib_${ri}$laset( 'FULL', n, n, zero, one, q, ldq ) ! wherever possible, plane rotations are generated and applied in ! vector operations of length nr over the index set j1:j2:kd1. ! the cosines and sines of the plane rotations are stored in the @@ -62682,20 +62683,20 @@ module stdlib_linalg_lapack_q if( nr>0 ) then ! generate plane rotations to annihilate nonzero ! elements which have been created outside the band - call stdlib_qlargv( nr, ab( 1, j1-1 ), inca, work( j1 ),kd1, d( j1 ), & + call stdlib_${ri}$largv( nr, ab( 1, j1-1 ), inca, work( j1 ),kd1, d( j1 ), & kd1 ) ! apply rotations from the right ! dependent on the the number of diagonals either - ! stdlib_qlartv or stdlib_qrot is used + ! stdlib_${ri}$lartv or stdlib_${ri}$rot is used if( nr>=2*kd-1 ) then do l = 1, kd - 1 - call stdlib_qlartv( nr, ab( l+1, j1-1 ), inca,ab( l, j1 ), inca, & + call stdlib_${ri}$lartv( nr, ab( l+1, j1-1 ), inca,ab( l, j1 ), inca, & d( j1 ),work( j1 ), kd1 ) end do else jend = j1 + ( nr-1 )*kd1 do jinc = j1, jend, kd1 - call stdlib_qrot( kdm1, ab( 2, jinc-1 ), 1,ab( 1, jinc ), 1, d( & + call stdlib_${ri}$rot( kdm1, ab( 2, jinc-1 ), 1,ab( 1, jinc ), 1, d( & jinc ),work( jinc ) ) end do end if @@ -62704,11 +62705,11 @@ module stdlib_linalg_lapack_q if( k<=n-i+1 ) then ! generate plane rotation to annihilate a(i,i+k-1) ! within the band - call stdlib_qlartg( ab( kd-k+3, i+k-2 ),ab( kd-k+2, i+k-1 ), d( i+k-& + call stdlib_${ri}$lartg( ab( kd-k+3, i+k-2 ),ab( kd-k+2, i+k-1 ), d( i+k-& 1 ),work( i+k-1 ), temp ) ab( kd-k+3, i+k-2 ) = temp ! apply rotation from the right - call stdlib_qrot( k-3, ab( kd-k+4, i+k-2 ), 1,ab( kd-k+3, i+k-1 ), 1,& + call stdlib_${ri}$rot( k-3, ab( kd-k+4, i+k-2 ), 1,ab( kd-k+3, i+k-1 ), 1,& d( i+k-1 ),work( i+k-1 ) ) end if nr = nr + 1 @@ -62716,33 +62717,33 @@ module stdlib_linalg_lapack_q end if ! apply plane rotations from both sides to diagonal ! blocks - if( nr>0 )call stdlib_qlar2v( nr, ab( kd1, j1-1 ), ab( kd1, j1 ),ab( kd, & + if( nr>0 )call stdlib_${ri}$lar2v( nr, ab( kd1, j1-1 ), ab( kd1, j1 ),ab( kd, & j1 ), inca, d( j1 ),work( j1 ), kd1 ) ! apply plane rotations from the left if( nr>0 ) then if( 2*kd-1n ) then nrt = nr - 1 else nrt = nr end if - if( nrt>0 )call stdlib_qlartv( nrt, ab( kd-l, j1+l ), inca,ab( kd-& + if( nrt>0 )call stdlib_${ri}$lartv( nrt, ab( kd-l, j1+l ), inca,ab( kd-& l+1, j1+l ), inca,d( j1 ), work( j1 ), kd1 ) end do else j1end = j1 + kd1*( nr-2 ) if( j1end>=j1 ) then do jin = j1, j1end, kd1 - call stdlib_qrot( kd-1, ab( kd-1, jin+1 ), incx,ab( kd, jin+1 )& + call stdlib_${ri}$rot( kd-1, ab( kd-1, jin+1 ), incx,ab( kd, jin+1 )& , incx,d( jin ), work( jin ) ) end do end if lend = min( kdm1, n-j2 ) last = j1end + kd1 - if( lend>0 )call stdlib_qrot( lend, ab( kd-1, last+1 ), incx,ab( kd, & + if( lend>0 )call stdlib_${ri}$rot( lend, ab( kd-1, last+1 ), incx,ab( kd, & last+1 ), incx, d( last ),work( last ) ) end if end if @@ -62762,12 +62763,12 @@ module stdlib_linalg_lapack_q iqb = max( 1, j-ibl ) nq = 1 + iqaend - iqb iqaend = min( iqaend+kd, iqend ) - call stdlib_qrot( nq, q( iqb, j-1 ), 1, q( iqb, j ),1, d( j ), & + call stdlib_${ri}$rot( nq, q( iqb, j-1 ), 1, q( iqb, j ),1, d( j ), & work( j ) ) end do else do j = j1, j2, kd1 - call stdlib_qrot( n, q( 1, j-1 ), 1, q( 1, j ), 1,d( j ), work( j & + call stdlib_${ri}$rot( n, q( 1, j-1 ), 1, q( 1, j ), 1,d( j ), work( j & ) ) end do end if @@ -62815,20 +62816,20 @@ module stdlib_linalg_lapack_q if( nr>0 ) then ! generate plane rotations to annihilate nonzero ! elements which have been created outside the band - call stdlib_qlargv( nr, ab( kd1, j1-kd1 ), inca,work( j1 ), kd1, d( j1 )& + call stdlib_${ri}$largv( nr, ab( kd1, j1-kd1 ), inca,work( j1 ), kd1, d( j1 )& , kd1 ) ! apply plane rotations from one side ! dependent on the the number of diagonals either - ! stdlib_qlartv or stdlib_qrot is used + ! stdlib_${ri}$lartv or stdlib_${ri}$rot is used if( nr>2*kd-1 ) then do l = 1, kd - 1 - call stdlib_qlartv( nr, ab( kd1-l, j1-kd1+l ), inca,ab( kd1-l+1, & + call stdlib_${ri}$lartv( nr, ab( kd1-l, j1-kd1+l ), inca,ab( kd1-l+1, & j1-kd1+l ), inca,d( j1 ), work( j1 ), kd1 ) end do else jend = j1 + kd1*( nr-1 ) do jinc = j1, jend, kd1 - call stdlib_qrot( kdm1, ab( kd, jinc-kd ), incx,ab( kd1, jinc-kd )& + call stdlib_${ri}$rot( kdm1, ab( kd, jinc-kd ), incx,ab( kd1, jinc-kd )& , incx,d( jinc ), work( jinc ) ) end do end if @@ -62837,11 +62838,11 @@ module stdlib_linalg_lapack_q if( k<=n-i+1 ) then ! generate plane rotation to annihilate a(i+k-1,i) ! within the band - call stdlib_qlartg( ab( k-1, i ), ab( k, i ),d( i+k-1 ), work( i+k-1 & + call stdlib_${ri}$lartg( ab( k-1, i ), ab( k, i ),d( i+k-1 ), work( i+k-1 & ), temp ) ab( k-1, i ) = temp ! apply rotation from the left - call stdlib_qrot( k-3, ab( k-2, i+1 ), ldab-1,ab( k-1, i+1 ), ldab-1,& + call stdlib_${ri}$rot( k-3, ab( k-2, i+1 ), ldab-1,ab( k-1, i+1 ), ldab-1,& d( i+k-1 ),work( i+k-1 ) ) end if nr = nr + 1 @@ -62849,11 +62850,11 @@ module stdlib_linalg_lapack_q end if ! apply plane rotations from both sides to diagonal ! blocks - if( nr>0 )call stdlib_qlar2v( nr, ab( 1, j1-1 ), ab( 1, j1 ),ab( 2, j1-1 ),& + if( nr>0 )call stdlib_${ri}$lar2v( nr, ab( 1, j1-1 ), ab( 1, j1 ),ab( 2, j1-1 ),& inca, d( j1 ),work( j1 ), kd1 ) ! apply plane rotations from the right ! dependent on the the number of diagonals either - ! stdlib_qlartv or stdlib_qrot is used + ! stdlib_${ri}$lartv or stdlib_${ri}$rot is used if( nr>0 ) then if( nr>2*kd-1 ) then do l = 1, kd - 1 @@ -62862,20 +62863,20 @@ module stdlib_linalg_lapack_q else nrt = nr end if - if( nrt>0 )call stdlib_qlartv( nrt, ab( l+2, j1-1 ), inca,ab( l+1,& + if( nrt>0 )call stdlib_${ri}$lartv( nrt, ab( l+2, j1-1 ), inca,ab( l+1,& j1 ), inca, d( j1 ),work( j1 ), kd1 ) end do else j1end = j1 + kd1*( nr-2 ) if( j1end>=j1 ) then do j1inc = j1, j1end, kd1 - call stdlib_qrot( kdm1, ab( 3, j1inc-1 ), 1,ab( 2, j1inc ), 1, & + call stdlib_${ri}$rot( kdm1, ab( 3, j1inc-1 ), 1,ab( 2, j1inc ), 1, & d( j1inc ),work( j1inc ) ) end do end if lend = min( kdm1, n-j2 ) last = j1end + kd1 - if( lend>0 )call stdlib_qrot( lend, ab( 3, last-1 ), 1,ab( 2, last ),& + if( lend>0 )call stdlib_${ri}$rot( lend, ab( 3, last-1 ), 1,ab( 2, last ),& 1, d( last ),work( last ) ) end if end if @@ -62895,12 +62896,12 @@ module stdlib_linalg_lapack_q iqb = max( 1, j-ibl ) nq = 1 + iqaend - iqb iqaend = min( iqaend+kd, iqend ) - call stdlib_qrot( nq, q( iqb, j-1 ), 1, q( iqb, j ),1, d( j ), & + call stdlib_${ri}$rot( nq, q( iqb, j-1 ), 1, q( iqb, j ),1, d( j ), & work( j ) ) end do else do j = j1, j2, kd1 - call stdlib_qrot( n, q( 1, j-1 ), 1, q( 1, j ), 1,d( j ), work( j & + call stdlib_${ri}$rot( n, q( 1, j-1 ), 1, q( 1, j ), 1,d( j ), work( j & ) ) end do end if @@ -62936,10 +62937,10 @@ module stdlib_linalg_lapack_q end do end if return - end subroutine stdlib_qsbtrd + end subroutine stdlib_${ri}$sbtrd - pure subroutine stdlib_qsfrk( transr, uplo, trans, n, k, alpha, a, lda, beta,c ) + pure subroutine stdlib_${ri}$sfrk( transr, uplo, trans, n, k, alpha, a, lda, beta,c ) !! Level 3 BLAS like routine for C in RFP Format. !! DSFRK: performs one of the symmetric rank--k operations !! C := alpha*A*A**T + beta*C, @@ -62952,12 +62953,12 @@ module stdlib_linalg_lapack_q ! -- lapack is a software package provided by univ. of tennessee, -- ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments - real(qp), intent(in) :: alpha, beta + real(${rk}$), intent(in) :: alpha, beta integer(ilp), intent(in) :: k, lda, n character, intent(in) :: trans, transr, uplo ! Array Arguments - real(qp), intent(in) :: a(lda,*) - real(qp), intent(inout) :: c(*) + real(${rk}$), intent(in) :: a(lda,*) + real(${rk}$), intent(inout) :: c(*) ! ===================================================================== ! Local Scalars @@ -62995,7 +62996,7 @@ module stdlib_linalg_lapack_q end if ! quick return if possible. ! the quick return case: ((alpha==0).and.(beta/=zero)) is not - ! done (it is in stdlib_qsyrk for example) and left in the general case. + ! done (it is in stdlib_${ri}$syrk for example) and left in the general case. if( ( n==0 ) .or. ( ( ( alpha==zero ) .or. ( k==0 ) ) .and.( beta==one ) ) )& return if( ( alpha==zero ) .and. ( beta==zero ) ) then @@ -63028,38 +63029,38 @@ module stdlib_linalg_lapack_q ! n is odd, transr = 'n', and uplo = 'l' if( notrans ) then ! n is odd, transr = 'n', uplo = 'l', and trans = 'n' - call stdlib_qsyrk( 'L', 'N', n1, k, alpha, a( 1, 1 ), lda,beta, c( 1 ), n ) + call stdlib_${ri}$syrk( 'L', 'N', n1, k, alpha, a( 1, 1 ), lda,beta, c( 1 ), n ) - call stdlib_qsyrk( 'U', 'N', n2, k, alpha, a( n1+1, 1 ), lda,beta, c( n+1 )& + call stdlib_${ri}$syrk( 'U', 'N', n2, k, alpha, a( n1+1, 1 ), lda,beta, c( n+1 )& , n ) - call stdlib_qgemm( 'N', 'T', n2, n1, k, alpha, a( n1+1, 1 ),lda, a( 1, 1 ),& + call stdlib_${ri}$gemm( 'N', 'T', n2, n1, k, alpha, a( n1+1, 1 ),lda, a( 1, 1 ),& lda, beta, c( n1+1 ), n ) else ! n is odd, transr = 'n', uplo = 'l', and trans = 't' - call stdlib_qsyrk( 'L', 'T', n1, k, alpha, a( 1, 1 ), lda,beta, c( 1 ), n ) + call stdlib_${ri}$syrk( 'L', 'T', n1, k, alpha, a( 1, 1 ), lda,beta, c( 1 ), n ) - call stdlib_qsyrk( 'U', 'T', n2, k, alpha, a( 1, n1+1 ), lda,beta, c( n+1 )& + call stdlib_${ri}$syrk( 'U', 'T', n2, k, alpha, a( 1, n1+1 ), lda,beta, c( n+1 )& , n ) - call stdlib_qgemm( 'T', 'N', n2, n1, k, alpha, a( 1, n1+1 ),lda, a( 1, 1 ),& + call stdlib_${ri}$gemm( 'T', 'N', n2, n1, k, alpha, a( 1, n1+1 ),lda, a( 1, 1 ),& lda, beta, c( n1+1 ), n ) end if else ! n is odd, transr = 'n', and uplo = 'u' if( notrans ) then ! n is odd, transr = 'n', uplo = 'u', and trans = 'n' - call stdlib_qsyrk( 'L', 'N', n1, k, alpha, a( 1, 1 ), lda,beta, c( n2+1 ), & + call stdlib_${ri}$syrk( 'L', 'N', n1, k, alpha, a( 1, 1 ), lda,beta, c( n2+1 ), & n ) - call stdlib_qsyrk( 'U', 'N', n2, k, alpha, a( n2, 1 ), lda,beta, c( n1+1 ),& + call stdlib_${ri}$syrk( 'U', 'N', n2, k, alpha, a( n2, 1 ), lda,beta, c( n1+1 ),& n ) - call stdlib_qgemm( 'N', 'T', n1, n2, k, alpha, a( 1, 1 ),lda, a( n2, 1 ), & + call stdlib_${ri}$gemm( 'N', 'T', n1, n2, k, alpha, a( 1, 1 ),lda, a( n2, 1 ), & lda, beta, c( 1 ), n ) else ! n is odd, transr = 'n', uplo = 'u', and trans = 't' - call stdlib_qsyrk( 'L', 'T', n1, k, alpha, a( 1, 1 ), lda,beta, c( n2+1 ), & + call stdlib_${ri}$syrk( 'L', 'T', n1, k, alpha, a( 1, 1 ), lda,beta, c( n2+1 ), & n ) - call stdlib_qsyrk( 'U', 'T', n2, k, alpha, a( 1, n2 ), lda,beta, c( n1+1 ),& + call stdlib_${ri}$syrk( 'U', 'T', n2, k, alpha, a( 1, n2 ), lda,beta, c( n1+1 ),& n ) - call stdlib_qgemm( 'T', 'N', n1, n2, k, alpha, a( 1, 1 ),lda, a( 1, n2 ), & + call stdlib_${ri}$gemm( 'T', 'N', n1, n2, k, alpha, a( 1, 1 ),lda, a( 1, n2 ), & lda, beta, c( 1 ), n ) end if end if @@ -63069,38 +63070,38 @@ module stdlib_linalg_lapack_q ! n is odd, transr = 't', and uplo = 'l' if( notrans ) then ! n is odd, transr = 't', uplo = 'l', and trans = 'n' - call stdlib_qsyrk( 'U', 'N', n1, k, alpha, a( 1, 1 ), lda,beta, c( 1 ), n1 & + call stdlib_${ri}$syrk( 'U', 'N', n1, k, alpha, a( 1, 1 ), lda,beta, c( 1 ), n1 & ) - call stdlib_qsyrk( 'L', 'N', n2, k, alpha, a( n1+1, 1 ), lda,beta, c( 2 ), & + call stdlib_${ri}$syrk( 'L', 'N', n2, k, alpha, a( n1+1, 1 ), lda,beta, c( 2 ), & n1 ) - call stdlib_qgemm( 'N', 'T', n1, n2, k, alpha, a( 1, 1 ),lda, a( n1+1, 1 ),& + call stdlib_${ri}$gemm( 'N', 'T', n1, n2, k, alpha, a( 1, 1 ),lda, a( n1+1, 1 ),& lda, beta,c( n1*n1+1 ), n1 ) else ! n is odd, transr = 't', uplo = 'l', and trans = 't' - call stdlib_qsyrk( 'U', 'T', n1, k, alpha, a( 1, 1 ), lda,beta, c( 1 ), n1 & + call stdlib_${ri}$syrk( 'U', 'T', n1, k, alpha, a( 1, 1 ), lda,beta, c( 1 ), n1 & ) - call stdlib_qsyrk( 'L', 'T', n2, k, alpha, a( 1, n1+1 ), lda,beta, c( 2 ), & + call stdlib_${ri}$syrk( 'L', 'T', n2, k, alpha, a( 1, n1+1 ), lda,beta, c( 2 ), & n1 ) - call stdlib_qgemm( 'T', 'N', n1, n2, k, alpha, a( 1, 1 ),lda, a( 1, n1+1 ),& + call stdlib_${ri}$gemm( 'T', 'N', n1, n2, k, alpha, a( 1, 1 ),lda, a( 1, n1+1 ),& lda, beta,c( n1*n1+1 ), n1 ) end if else ! n is odd, transr = 't', and uplo = 'u' if( notrans ) then ! n is odd, transr = 't', uplo = 'u', and trans = 'n' - call stdlib_qsyrk( 'U', 'N', n1, k, alpha, a( 1, 1 ), lda,beta, c( n2*n2+1 & + call stdlib_${ri}$syrk( 'U', 'N', n1, k, alpha, a( 1, 1 ), lda,beta, c( n2*n2+1 & ), n2 ) - call stdlib_qsyrk( 'L', 'N', n2, k, alpha, a( n1+1, 1 ), lda,beta, c( & + call stdlib_${ri}$syrk( 'L', 'N', n2, k, alpha, a( n1+1, 1 ), lda,beta, c( & n1*n2+1 ), n2 ) - call stdlib_qgemm( 'N', 'T', n2, n1, k, alpha, a( n1+1, 1 ),lda, a( 1, 1 ),& + call stdlib_${ri}$gemm( 'N', 'T', n2, n1, k, alpha, a( n1+1, 1 ),lda, a( 1, 1 ),& lda, beta, c( 1 ), n2 ) else ! n is odd, transr = 't', uplo = 'u', and trans = 't' - call stdlib_qsyrk( 'U', 'T', n1, k, alpha, a( 1, 1 ), lda,beta, c( n2*n2+1 & + call stdlib_${ri}$syrk( 'U', 'T', n1, k, alpha, a( 1, 1 ), lda,beta, c( n2*n2+1 & ), n2 ) - call stdlib_qsyrk( 'L', 'T', n2, k, alpha, a( 1, n1+1 ), lda,beta, c( & + call stdlib_${ri}$syrk( 'L', 'T', n2, k, alpha, a( 1, n1+1 ), lda,beta, c( & n1*n2+1 ), n2 ) - call stdlib_qgemm( 'T', 'N', n2, n1, k, alpha, a( 1, n1+1 ),lda, a( 1, 1 ),& + call stdlib_${ri}$gemm( 'T', 'N', n2, n1, k, alpha, a( 1, n1+1 ),lda, a( 1, 1 ),& lda, beta, c( 1 ), n2 ) end if end if @@ -63113,38 +63114,38 @@ module stdlib_linalg_lapack_q ! n is even, transr = 'n', and uplo = 'l' if( notrans ) then ! n is even, transr = 'n', uplo = 'l', and trans = 'n' - call stdlib_qsyrk( 'L', 'N', nk, k, alpha, a( 1, 1 ), lda,beta, c( 2 ), n+& + call stdlib_${ri}$syrk( 'L', 'N', nk, k, alpha, a( 1, 1 ), lda,beta, c( 2 ), n+& 1 ) - call stdlib_qsyrk( 'U', 'N', nk, k, alpha, a( nk+1, 1 ), lda,beta, c( 1 ), & + call stdlib_${ri}$syrk( 'U', 'N', nk, k, alpha, a( nk+1, 1 ), lda,beta, c( 1 ), & n+1 ) - call stdlib_qgemm( 'N', 'T', nk, nk, k, alpha, a( nk+1, 1 ),lda, a( 1, 1 ),& + call stdlib_${ri}$gemm( 'N', 'T', nk, nk, k, alpha, a( nk+1, 1 ),lda, a( 1, 1 ),& lda, beta, c( nk+2 ),n+1 ) else ! n is even, transr = 'n', uplo = 'l', and trans = 't' - call stdlib_qsyrk( 'L', 'T', nk, k, alpha, a( 1, 1 ), lda,beta, c( 2 ), n+& + call stdlib_${ri}$syrk( 'L', 'T', nk, k, alpha, a( 1, 1 ), lda,beta, c( 2 ), n+& 1 ) - call stdlib_qsyrk( 'U', 'T', nk, k, alpha, a( 1, nk+1 ), lda,beta, c( 1 ), & + call stdlib_${ri}$syrk( 'U', 'T', nk, k, alpha, a( 1, nk+1 ), lda,beta, c( 1 ), & n+1 ) - call stdlib_qgemm( 'T', 'N', nk, nk, k, alpha, a( 1, nk+1 ),lda, a( 1, 1 ),& + call stdlib_${ri}$gemm( 'T', 'N', nk, nk, k, alpha, a( 1, nk+1 ),lda, a( 1, 1 ),& lda, beta, c( nk+2 ),n+1 ) end if else ! n is even, transr = 'n', and uplo = 'u' if( notrans ) then ! n is even, transr = 'n', uplo = 'u', and trans = 'n' - call stdlib_qsyrk( 'L', 'N', nk, k, alpha, a( 1, 1 ), lda,beta, c( nk+2 ), & + call stdlib_${ri}$syrk( 'L', 'N', nk, k, alpha, a( 1, 1 ), lda,beta, c( nk+2 ), & n+1 ) - call stdlib_qsyrk( 'U', 'N', nk, k, alpha, a( nk+1, 1 ), lda,beta, c( nk+1 & + call stdlib_${ri}$syrk( 'U', 'N', nk, k, alpha, a( nk+1, 1 ), lda,beta, c( nk+1 & ), n+1 ) - call stdlib_qgemm( 'N', 'T', nk, nk, k, alpha, a( 1, 1 ),lda, a( nk+1, 1 ),& + call stdlib_${ri}$gemm( 'N', 'T', nk, nk, k, alpha, a( 1, 1 ),lda, a( nk+1, 1 ),& lda, beta, c( 1 ),n+1 ) else ! n is even, transr = 'n', uplo = 'u', and trans = 't' - call stdlib_qsyrk( 'L', 'T', nk, k, alpha, a( 1, 1 ), lda,beta, c( nk+2 ), & + call stdlib_${ri}$syrk( 'L', 'T', nk, k, alpha, a( 1, 1 ), lda,beta, c( nk+2 ), & n+1 ) - call stdlib_qsyrk( 'U', 'T', nk, k, alpha, a( 1, nk+1 ), lda,beta, c( nk+1 & + call stdlib_${ri}$syrk( 'U', 'T', nk, k, alpha, a( 1, nk+1 ), lda,beta, c( nk+1 & ), n+1 ) - call stdlib_qgemm( 'T', 'N', nk, nk, k, alpha, a( 1, 1 ),lda, a( 1, nk+1 ),& + call stdlib_${ri}$gemm( 'T', 'N', nk, nk, k, alpha, a( 1, 1 ),lda, a( 1, nk+1 ),& lda, beta, c( 1 ),n+1 ) end if end if @@ -63154,48 +63155,48 @@ module stdlib_linalg_lapack_q ! n is even, transr = 't', and uplo = 'l' if( notrans ) then ! n is even, transr = 't', uplo = 'l', and trans = 'n' - call stdlib_qsyrk( 'U', 'N', nk, k, alpha, a( 1, 1 ), lda,beta, c( nk+1 ), & + call stdlib_${ri}$syrk( 'U', 'N', nk, k, alpha, a( 1, 1 ), lda,beta, c( nk+1 ), & nk ) - call stdlib_qsyrk( 'L', 'N', nk, k, alpha, a( nk+1, 1 ), lda,beta, c( 1 ), & + call stdlib_${ri}$syrk( 'L', 'N', nk, k, alpha, a( nk+1, 1 ), lda,beta, c( 1 ), & nk ) - call stdlib_qgemm( 'N', 'T', nk, nk, k, alpha, a( 1, 1 ),lda, a( nk+1, 1 ),& + call stdlib_${ri}$gemm( 'N', 'T', nk, nk, k, alpha, a( 1, 1 ),lda, a( nk+1, 1 ),& lda, beta,c( ( ( nk+1 )*nk )+1 ), nk ) else ! n is even, transr = 't', uplo = 'l', and trans = 't' - call stdlib_qsyrk( 'U', 'T', nk, k, alpha, a( 1, 1 ), lda,beta, c( nk+1 ), & + call stdlib_${ri}$syrk( 'U', 'T', nk, k, alpha, a( 1, 1 ), lda,beta, c( nk+1 ), & nk ) - call stdlib_qsyrk( 'L', 'T', nk, k, alpha, a( 1, nk+1 ), lda,beta, c( 1 ), & + call stdlib_${ri}$syrk( 'L', 'T', nk, k, alpha, a( 1, nk+1 ), lda,beta, c( 1 ), & nk ) - call stdlib_qgemm( 'T', 'N', nk, nk, k, alpha, a( 1, 1 ),lda, a( 1, nk+1 ),& + call stdlib_${ri}$gemm( 'T', 'N', nk, nk, k, alpha, a( 1, 1 ),lda, a( 1, nk+1 ),& lda, beta,c( ( ( nk+1 )*nk )+1 ), nk ) end if else ! n is even, transr = 't', and uplo = 'u' if( notrans ) then ! n is even, transr = 't', uplo = 'u', and trans = 'n' - call stdlib_qsyrk( 'U', 'N', nk, k, alpha, a( 1, 1 ), lda,beta, c( nk*( nk+& + call stdlib_${ri}$syrk( 'U', 'N', nk, k, alpha, a( 1, 1 ), lda,beta, c( nk*( nk+& 1 )+1 ), nk ) - call stdlib_qsyrk( 'L', 'N', nk, k, alpha, a( nk+1, 1 ), lda,beta, c( & + call stdlib_${ri}$syrk( 'L', 'N', nk, k, alpha, a( nk+1, 1 ), lda,beta, c( & nk*nk+1 ), nk ) - call stdlib_qgemm( 'N', 'T', nk, nk, k, alpha, a( nk+1, 1 ),lda, a( 1, 1 ),& + call stdlib_${ri}$gemm( 'N', 'T', nk, nk, k, alpha, a( nk+1, 1 ),lda, a( 1, 1 ),& lda, beta, c( 1 ), nk ) else ! n is even, transr = 't', uplo = 'u', and trans = 't' - call stdlib_qsyrk( 'U', 'T', nk, k, alpha, a( 1, 1 ), lda,beta, c( nk*( nk+& + call stdlib_${ri}$syrk( 'U', 'T', nk, k, alpha, a( 1, 1 ), lda,beta, c( nk*( nk+& 1 )+1 ), nk ) - call stdlib_qsyrk( 'L', 'T', nk, k, alpha, a( 1, nk+1 ), lda,beta, c( & + call stdlib_${ri}$syrk( 'L', 'T', nk, k, alpha, a( 1, nk+1 ), lda,beta, c( & nk*nk+1 ), nk ) - call stdlib_qgemm( 'T', 'N', nk, nk, k, alpha, a( 1, nk+1 ),lda, a( 1, 1 ),& + call stdlib_${ri}$gemm( 'T', 'N', nk, nk, k, alpha, a( 1, nk+1 ),lda, a( 1, 1 ),& lda, beta, c( 1 ), nk ) end if end if end if end if return - end subroutine stdlib_qsfrk + end subroutine stdlib_${ri}$sfrk - subroutine stdlib_qsgesv( n, nrhs, a, lda, ipiv, b, ldb, x, ldx, work,swork, iter, info ) + subroutine stdlib_${ri}$sgesv( n, nrhs, a, lda, ipiv, b, ldb, x, ldx, work,swork, iter, info ) !! DSGESV: computes the solution to a real system of linear equations !! A * X = B, !! where A is an N-by-N matrix and X and B are N-by-NRHS matrices. @@ -63233,21 +63234,21 @@ module stdlib_linalg_lapack_q ! Array Arguments integer(ilp), intent(out) :: ipiv(*) real(dp), intent(out) :: swork(*) - real(qp), intent(inout) :: a(lda,*) - real(qp), intent(in) :: b(ldb,*) - real(qp), intent(out) :: work(n,*), x(ldx,*) + real(${rk}$), intent(inout) :: a(lda,*) + real(${rk}$), intent(in) :: b(ldb,*) + real(${rk}$), intent(out) :: work(n,*), x(ldx,*) ! ===================================================================== ! Parameters logical(lk), parameter :: doitref = .true. integer(ilp), parameter :: itermax = 30 - real(qp), parameter :: bwdmax = 1.0e+00_qp + real(${rk}$), parameter :: bwdmax = 1.0e+00_${rk}$ ! Local Scalars integer(ilp) :: i, iiter, ptsa, ptsx - real(qp) :: anrm, cte, eps, rnrm, xnrm + real(${rk}$) :: anrm, cte, eps, rnrm, xnrm ! Intrinsic Functions intrinsic :: abs,real,max,sqrt ! Executable Statements @@ -63278,22 +63279,22 @@ module stdlib_linalg_lapack_q go to 40 end if ! compute some constants. - anrm = stdlib_qlange( 'I', n, n, a, lda, work ) - eps = stdlib_qlamch( 'EPSILON' ) - cte = anrm*eps*sqrt( real( n,KIND=qp) )*bwdmax + anrm = stdlib_${ri}$lange( 'I', n, n, a, lda, work ) + eps = stdlib_${ri}$lamch( 'EPSILON' ) + cte = anrm*eps*sqrt( real( n,KIND=${rk}$) )*bwdmax ! set the indices ptsa, ptsx for referencing sa and sx in swork. ptsa = 1 ptsx = ptsa + n*n ! convert b from quad precision to double precision and store the ! result in sx. - call stdlib_qlag2s( n, nrhs, b, ldb, swork( ptsx ), n, info ) + call stdlib_${ri}$lag2s( n, nrhs, b, ldb, swork( ptsx ), n, info ) if( info/=0 ) then iter = -2 go to 40 end if ! convert a from quad precision to double precision and store the ! result in sa. - call stdlib_qlag2s( n, n, a, lda, swork( ptsa ), n, info ) + call stdlib_${ri}$lag2s( n, n, a, lda, swork( ptsa ), n, info ) if( info/=0 ) then iter = -2 go to 40 @@ -63308,16 +63309,16 @@ module stdlib_linalg_lapack_q call stdlib_dgetrs( 'NO TRANSPOSE', n, nrhs, swork( ptsa ), n, ipiv,swork( ptsx ), n, & info ) ! convert sx back to quad precision - call stdlib_dlag2q( n, nrhs, swork( ptsx ), n, x, ldx, info ) + call stdlib_dlag2${ri}$( n, nrhs, swork( ptsx ), n, x, ldx, info ) ! compute r = b - ax (r is work). - call stdlib_qlacpy( 'ALL', n, nrhs, b, ldb, work, n ) - call stdlib_qgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', n, nrhs, n, negone, a,lda, x, ldx, & + call stdlib_${ri}$lacpy( 'ALL', n, nrhs, b, ldb, work, n ) + call stdlib_${ri}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', n, nrhs, n, negone, a,lda, x, ldx, & one, work, n ) ! check whether the nrhs normwise backward errors satisfy the ! stopping criterion. if yes, set iter=0 and return. do i = 1, nrhs - xnrm = abs( x( stdlib_iqamax( n, x( 1, i ), 1 ), i ) ) - rnrm = abs( work( stdlib_iqamax( n, work( 1, i ), 1 ), i ) ) + xnrm = abs( x( stdlib_i${ri}$amax( n, x( 1, i ), 1 ), i ) ) + rnrm = abs( work( stdlib_i${ri}$amax( n, work( 1, i ), 1 ), i ) ) if( rnrm>xnrm*cte )go to 10 end do ! if we are here, the nrhs normwise backward errors satisfy the @@ -63328,7 +63329,7 @@ module stdlib_linalg_lapack_q loop_30: do iiter = 1, itermax ! convert r (in work) from quad precision to double precision ! and store the result in sx. - call stdlib_qlag2s( n, nrhs, work, n, swork( ptsx ), n, info ) + call stdlib_${ri}$lag2s( n, nrhs, work, n, swork( ptsx ), n, info ) if( info/=0 ) then iter = -2 go to 40 @@ -63338,19 +63339,19 @@ module stdlib_linalg_lapack_q n, info ) ! convert sx back to quad precision and update the current ! iterate. - call stdlib_dlag2q( n, nrhs, swork( ptsx ), n, work, n, info ) + call stdlib_dlag2${ri}$( n, nrhs, swork( ptsx ), n, work, n, info ) do i = 1, nrhs - call stdlib_qaxpy( n, one, work( 1, i ), 1, x( 1, i ), 1 ) + call stdlib_${ri}$axpy( n, one, work( 1, i ), 1, x( 1, i ), 1 ) end do ! compute r = b - ax (r is work). - call stdlib_qlacpy( 'ALL', n, nrhs, b, ldb, work, n ) - call stdlib_qgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', n, nrhs, n, negone,a, lda, x, & + call stdlib_${ri}$lacpy( 'ALL', n, nrhs, b, ldb, work, n ) + call stdlib_${ri}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', n, nrhs, n, negone,a, lda, x, & ldx, one, work, n ) ! check whether the nrhs normwise backward errors satisfy the ! stopping criterion. if yes, set iter=iiter>0 and return. do i = 1, nrhs - xnrm = abs( x( stdlib_iqamax( n, x( 1, i ), 1 ), i ) ) - rnrm = abs( work( stdlib_iqamax( n, work( 1, i ), 1 ), i ) ) + xnrm = abs( x( stdlib_i${ri}$amax( n, x( 1, i ), 1 ), i ) ) + rnrm = abs( work( stdlib_i${ri}$amax( n, work( 1, i ), 1 ), i ) ) if( rnrm>xnrm*cte )go to 20 end do ! if we are here, the nrhs normwise backward errors satisfy the @@ -63367,15 +63368,15 @@ module stdlib_linalg_lapack_q 40 continue ! single-precision iterative refinement failed to converge to a ! satisfactory solution, so we resort to quad precision. - call stdlib_qgetrf( n, n, a, lda, ipiv, info ) + call stdlib_${ri}$getrf( n, n, a, lda, ipiv, info ) if( info/=0 )return - call stdlib_qlacpy( 'ALL', n, nrhs, b, ldb, x, ldx ) - call stdlib_qgetrs( 'NO TRANSPOSE', n, nrhs, a, lda, ipiv, x, ldx,info ) + call stdlib_${ri}$lacpy( 'ALL', n, nrhs, b, ldb, x, ldx ) + call stdlib_${ri}$getrs( 'NO TRANSPOSE', n, nrhs, a, lda, ipiv, x, ldx,info ) return - end subroutine stdlib_qsgesv + end subroutine stdlib_${ri}$sgesv - pure subroutine stdlib_qspcon( uplo, n, ap, ipiv, anorm, rcond, work, iwork,info ) + pure subroutine stdlib_${ri}$spcon( uplo, n, ap, ipiv, anorm, rcond, work, iwork,info ) !! DSPCON: estimates the reciprocal of the condition number (in the !! 1-norm) of a real symmetric packed matrix A using the factorization !! A = U*D*U**T or A = L*D*L**T computed by DSPTRF. @@ -63388,19 +63389,19 @@ module stdlib_linalg_lapack_q character, intent(in) :: uplo integer(ilp), intent(out) :: info integer(ilp), intent(in) :: n - real(qp), intent(in) :: anorm - real(qp), intent(out) :: rcond + real(${rk}$), intent(in) :: anorm + real(${rk}$), intent(out) :: rcond ! Array Arguments integer(ilp), intent(in) :: ipiv(*) integer(ilp), intent(out) :: iwork(*) - real(qp), intent(in) :: ap(*) - real(qp), intent(out) :: work(*) + real(${rk}$), intent(in) :: ap(*) + real(${rk}$), intent(out) :: work(*) ! ===================================================================== ! Local Scalars logical(lk) :: upper integer(ilp) :: i, ip, kase - real(qp) :: ainvnm + real(${rk}$) :: ainvnm ! Local Arrays integer(ilp) :: isave(3) ! Executable Statements @@ -63445,19 +63446,19 @@ module stdlib_linalg_lapack_q ! estimate the 1-norm of the inverse. kase = 0 30 continue - call stdlib_qlacn2( n, work( n+1 ), work, iwork, ainvnm, kase, isave ) + call stdlib_${ri}$lacn2( n, work( n+1 ), work, iwork, ainvnm, kase, isave ) if( kase/=0 ) then ! multiply by inv(l*d*l**t) or inv(u*d*u**t). - call stdlib_qsptrs( uplo, n, 1, ap, ipiv, work, n, info ) + call stdlib_${ri}$sptrs( uplo, n, 1, ap, 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_qspcon + end subroutine stdlib_${ri}$spcon - subroutine stdlib_qspev( jobz, uplo, n, ap, w, z, ldz, work, info ) + subroutine stdlib_${ri}$spev( jobz, uplo, n, ap, w, z, ldz, work, info ) !! DSPEV: computes all the eigenvalues and, optionally, eigenvectors of a !! real symmetric matrix A in packed storage. ! -- lapack driver routine -- @@ -63468,14 +63469,14 @@ module stdlib_linalg_lapack_q integer(ilp), intent(out) :: info integer(ilp), intent(in) :: ldz, n ! Array Arguments - real(qp), intent(inout) :: ap(*) - real(qp), intent(out) :: w(*), work(*), z(ldz,*) + real(${rk}$), intent(inout) :: ap(*) + real(${rk}$), intent(out) :: w(*), work(*), z(ldz,*) ! ===================================================================== ! Local Scalars logical(lk) :: wantz integer(ilp) :: iinfo, imax, inde, indtau, indwrk, iscale - real(qp) :: anrm, bignum, eps, rmax, rmin, safmin, sigma, smlnum + real(${rk}$) :: anrm, bignum, eps, rmax, rmin, safmin, sigma, smlnum ! Intrinsic Functions intrinsic :: sqrt ! Executable Statements @@ -63504,14 +63505,14 @@ module stdlib_linalg_lapack_q return end if ! get machine constants. - safmin = stdlib_qlamch( 'SAFE MINIMUM' ) - eps = stdlib_qlamch( 'PRECISION' ) + safmin = stdlib_${ri}$lamch( 'SAFE MINIMUM' ) + eps = stdlib_${ri}$lamch( 'PRECISION' ) smlnum = safmin / eps bignum = one / smlnum rmin = sqrt( smlnum ) rmax = sqrt( bignum ) ! scale matrix to allowable range, if necessary. - anrm = stdlib_qlansp( 'M', uplo, n, ap, work ) + anrm = stdlib_${ri}$lansp( 'M', uplo, n, ap, work ) iscale = 0 if( anrm>zero .and. anrmzero .and. anrmzero .and. anrm0 )abstll = abstol*sigma if( valeig ) then vll = vl*sigma vuu = vu*sigma end if end if - ! call stdlib_qsptrd to reduce symmetric packed matrix to tridiagonal form. + ! call stdlib_${ri}$sptrd to reduce symmetric packed matrix to tridiagonal form. indtau = 1 inde = indtau + n indd = inde + n indwrk = indd + n - call stdlib_qsptrd( uplo, n, ap, work( indd ), work( inde ),work( indtau ), iinfo ) + call stdlib_${ri}$sptrd( uplo, n, ap, work( indd ), work( inde ),work( indtau ), iinfo ) ! if all eigenvalues are desired and abstol is less than or equal - ! to zero, then call stdlib_qsterf or stdlib_qopgtr and stdlib_dsteqr. if this fails - ! for some eigenvalue, then try stdlib_qstebz. + ! to zero, then call stdlib_${ri}$sterf or stdlib_${ri}$opgtr and stdlib_dsteqr. if this fails + ! for some eigenvalue, then try stdlib_${ri}$stebz. test = .false. if (indeig) then if (il==1 .and. iu==n) then @@ -63804,16 +63805,16 @@ module stdlib_linalg_lapack_q end if end if if ((alleig .or. test) .and. (abstol<=zero)) then - call stdlib_qcopy( n, work( indd ), 1, w, 1 ) + call stdlib_${ri}$copy( n, work( indd ), 1, w, 1 ) indee = indwrk + 2*n if( .not.wantz ) then - call stdlib_qcopy( n-1, work( inde ), 1, work( indee ), 1 ) - call stdlib_qsterf( n, w, work( indee ), info ) + call stdlib_${ri}$copy( n-1, work( inde ), 1, work( indee ), 1 ) + call stdlib_${ri}$sterf( n, w, work( indee ), info ) else - call stdlib_qopgtr( uplo, n, ap, work( indtau ), z, ldz,work( indwrk ), iinfo ) + call stdlib_${ri}$opgtr( uplo, n, ap, work( indtau ), z, ldz,work( indwrk ), iinfo ) - call stdlib_qcopy( n-1, work( inde ), 1, work( indee ), 1 ) - call stdlib_qsteqr( jobz, n, w, work( indee ), z, ldz,work( indwrk ), info ) + call stdlib_${ri}$copy( n-1, work( inde ), 1, work( indee ), 1 ) + call stdlib_${ri}$steqr( jobz, n, w, work( indee ), z, ldz,work( indwrk ), info ) if( info==0 ) then do i = 1, n @@ -63827,7 +63828,7 @@ module stdlib_linalg_lapack_q end if info = 0 end if - ! otherwise, call stdlib_qstebz and, if eigenvectors are desired, stdlib_dstein. + ! otherwise, call stdlib_${ri}$stebz and, if eigenvectors are desired, stdlib_dstein. if( wantz ) then order = 'B' else @@ -63836,15 +63837,15 @@ module stdlib_linalg_lapack_q indibl = 1 indisp = indibl + n indiwo = indisp + n - call stdlib_qstebz( range, order, n, vll, vuu, il, iu, abstll,work( indd ), work( inde & + call stdlib_${ri}$stebz( range, order, n, vll, vuu, il, iu, abstll,work( indd ), work( inde & ), m, nsplit, w,iwork( indibl ), iwork( indisp ), work( indwrk ),iwork( indiwo ), info & ) if( wantz ) then - call stdlib_qstein( n, work( indd ), work( inde ), m, w,iwork( indibl ), iwork( & + call stdlib_${ri}$stein( n, work( indd ), work( inde ), m, w,iwork( indibl ), iwork( & indisp ), z, ldz,work( indwrk ), iwork( indiwo ), ifail, info ) ! apply orthogonal matrix used in reduction to tridiagonal - ! form to eigenvectors returned by stdlib_qstein. - call stdlib_qopmtr( 'L', uplo, 'N', n, m, ap, work( indtau ), z, ldz,work( indwrk ),& + ! form to eigenvectors returned by stdlib_${ri}$stein. + call stdlib_${ri}$opmtr( 'L', uplo, 'N', n, m, ap, work( indtau ), z, ldz,work( indwrk ),& iinfo ) end if ! if matrix was scaled, then rescale eigenvalues appropriately. @@ -63855,7 +63856,7 @@ module stdlib_linalg_lapack_q else imax = info - 1 end if - call stdlib_qscal( imax, one / sigma, w, 1 ) + call stdlib_${ri}$scal( imax, one / sigma, w, 1 ) end if ! if eigenvalues are not in order, then sort them, along with ! eigenvectors. @@ -63875,7 +63876,7 @@ module stdlib_linalg_lapack_q iwork( indibl+i-1 ) = iwork( indibl+j-1 ) w( j ) = tmp1 iwork( indibl+j-1 ) = itmp1 - call stdlib_qswap( n, z( 1, i ), 1, z( 1, j ), 1 ) + call stdlib_${ri}$swap( n, z( 1, i ), 1, z( 1, j ), 1 ) if( info/=0 ) then itmp1 = ifail( i ) ifail( i ) = ifail( j ) @@ -63885,10 +63886,10 @@ module stdlib_linalg_lapack_q end do end if return - end subroutine stdlib_qspevx + end subroutine stdlib_${ri}$spevx - pure subroutine stdlib_qspgst( itype, uplo, n, ap, bp, info ) + pure subroutine stdlib_${ri}$spgst( itype, uplo, n, ap, bp, info ) !! DSPGST: reduces a real symmetric-definite generalized eigenproblem !! to standard form, using packed storage. !! If ITYPE = 1, the problem is A*x = lambda*B*x, @@ -63904,14 +63905,14 @@ module stdlib_linalg_lapack_q integer(ilp), intent(out) :: info integer(ilp), intent(in) :: itype, n ! Array Arguments - real(qp), intent(inout) :: ap(*) - real(qp), intent(in) :: bp(*) + real(${rk}$), intent(inout) :: ap(*) + real(${rk}$), intent(in) :: bp(*) ! ===================================================================== ! Local Scalars logical(lk) :: upper integer(ilp) :: j, j1, j1j1, jj, k, k1, k1k1, kk - real(qp) :: ajj, akk, bjj, bkk, ct + real(${rk}$) :: ajj, akk, bjj, bkk, ct ! Executable Statements ! test the input parameters. info = 0 @@ -63937,10 +63938,10 @@ module stdlib_linalg_lapack_q jj = jj + j ! compute the j-th column of the upper triangle of a bjj = bp( jj ) - call stdlib_qtpsv( uplo, 'TRANSPOSE', 'NONUNIT', j, bp,ap( j1 ), 1 ) - call stdlib_qspmv( uplo, j-1, -one, ap, bp( j1 ), 1, one,ap( j1 ), 1 ) - call stdlib_qscal( j-1, one / bjj, ap( j1 ), 1 ) - ap( jj ) = ( ap( jj )-stdlib_qdot( j-1, ap( j1 ), 1, bp( j1 ),1 ) ) / & + call stdlib_${ri}$tpsv( uplo, 'TRANSPOSE', 'NONUNIT', j, bp,ap( j1 ), 1 ) + call stdlib_${ri}$spmv( uplo, j-1, -one, ap, bp( j1 ), 1, one,ap( j1 ), 1 ) + call stdlib_${ri}$scal( j-1, one / bjj, ap( j1 ), 1 ) + ap( jj ) = ( ap( jj )-stdlib_${ri}$dot( j-1, ap( j1 ), 1, bp( j1 ),1 ) ) / & bjj end do else @@ -63955,13 +63956,13 @@ module stdlib_linalg_lapack_q akk = akk / bkk**2 ap( kk ) = akk if( kxnrm*cte )go to 10 end do ! if we are here, the nrhs normwise backward errors satisfy the @@ -64464,7 +64465,7 @@ module stdlib_linalg_lapack_q loop_30: do iiter = 1, itermax ! convert r (in work) from quad precision to double precision ! and store the result in sx. - call stdlib_qlag2s( n, nrhs, work, n, swork( ptsx ), n, info ) + call stdlib_${ri}$lag2s( n, nrhs, work, n, swork( ptsx ), n, info ) if( info/=0 ) then iter = -2 go to 40 @@ -64473,18 +64474,18 @@ module stdlib_linalg_lapack_q call stdlib_dpotrs( uplo, n, nrhs, swork( ptsa ), n, swork( ptsx ), n,info ) ! convert sx back to quad precision and update the current ! iterate. - call stdlib_dlag2q( n, nrhs, swork( ptsx ), n, work, n, info ) + call stdlib_dlag2${ri}$( n, nrhs, swork( ptsx ), n, work, n, info ) do i = 1, nrhs - call stdlib_qaxpy( n, one, work( 1, i ), 1, x( 1, i ), 1 ) + call stdlib_${ri}$axpy( n, one, work( 1, i ), 1, x( 1, i ), 1 ) end do ! compute r = b - ax (r is work). - call stdlib_qlacpy( 'ALL', n, nrhs, b, ldb, work, n ) - call stdlib_qsymm( 'L', uplo, n, nrhs, negone, a, lda, x, ldx, one,work, n ) + call stdlib_${ri}$lacpy( 'ALL', n, nrhs, b, ldb, work, n ) + call stdlib_${ri}$symm( 'L', uplo, n, nrhs, negone, a, lda, x, ldx, one,work, n ) ! check whether the nrhs normwise backward errors satisfy the ! stopping criterion. if yes, set iter=iiter>0 and return. do i = 1, nrhs - xnrm = abs( x( stdlib_iqamax( n, x( 1, i ), 1 ), i ) ) - rnrm = abs( work( stdlib_iqamax( n, work( 1, i ), 1 ), i ) ) + xnrm = abs( x( stdlib_i${ri}$amax( n, x( 1, i ), 1 ), i ) ) + rnrm = abs( work( stdlib_i${ri}$amax( n, work( 1, i ), 1 ), i ) ) if( rnrm>xnrm*cte )go to 20 end do ! if we are here, the nrhs normwise backward errors satisfy the @@ -64501,15 +64502,15 @@ module stdlib_linalg_lapack_q 40 continue ! single-precision iterative refinement failed to converge to a ! satisfactory solution, so we resort to quad precision. - call stdlib_qpotrf( uplo, n, a, lda, info ) + call stdlib_${ri}$potrf( uplo, n, a, lda, info ) if( info/=0 )return - call stdlib_qlacpy( 'ALL', n, nrhs, b, ldb, x, ldx ) - call stdlib_qpotrs( uplo, n, nrhs, a, lda, x, ldx, info ) + call stdlib_${ri}$lacpy( 'ALL', n, nrhs, b, ldb, x, ldx ) + call stdlib_${ri}$potrs( uplo, n, nrhs, a, lda, x, ldx, info ) return - end subroutine stdlib_qsposv + end subroutine stdlib_${ri}$sposv - pure subroutine stdlib_qsprfs( uplo, n, nrhs, ap, afp, ipiv, b, ldb, x, ldx,ferr, berr, work,& + pure subroutine stdlib_${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 @@ -64525,9 +64526,9 @@ module stdlib_linalg_lapack_q ! Array Arguments integer(ilp), intent(in) :: ipiv(*) integer(ilp), intent(out) :: iwork(*) - real(qp), intent(in) :: afp(*), ap(*), b(ldb,*) - real(qp), intent(out) :: berr(*), ferr(*), work(*) - real(qp), intent(inout) :: x(ldx,*) + real(${rk}$), intent(in) :: afp(*), ap(*), b(ldb,*) + real(${rk}$), intent(out) :: berr(*), ferr(*), work(*) + real(${rk}$), intent(inout) :: x(ldx,*) ! ===================================================================== ! Parameters integer(ilp), parameter :: itmax = 5 @@ -64539,7 +64540,7 @@ module stdlib_linalg_lapack_q ! Local Scalars logical(lk) :: upper integer(ilp) :: count, i, ik, j, k, kase, kk, nz - real(qp) :: eps, lstres, s, safe1, safe2, safmin, xk + real(${rk}$) :: eps, lstres, s, safe1, safe2, safmin, xk ! Local Arrays integer(ilp) :: isave(3) ! Intrinsic Functions @@ -64573,8 +64574,8 @@ module stdlib_linalg_lapack_q end if ! nz = maximum number of nonzero elements in each row of a, plus 1 nz = n + 1 - eps = stdlib_qlamch( 'EPSILON' ) - safmin = stdlib_qlamch( 'SAFE MINIMUM' ) + eps = stdlib_${ri}$lamch( 'EPSILON' ) + safmin = stdlib_${ri}$lamch( 'SAFE MINIMUM' ) safe1 = nz*safmin safe2 = safe1 / eps ! do for each right hand side @@ -64584,8 +64585,8 @@ module stdlib_linalg_lapack_q 20 continue ! loop until stopping criterion is satisfied. ! compute residual r = b - a * x - call stdlib_qcopy( n, b( 1, j ), 1, work( n+1 ), 1 ) - call stdlib_qspmv( uplo, n, -one, ap, x( 1, j ), 1, one, work( n+1 ),1 ) + call stdlib_${ri}$copy( n, b( 1, j ), 1, work( n+1 ), 1 ) + call stdlib_${ri}$spmv( uplo, n, -one, ap, x( 1, j ), 1, one, work( n+1 ),1 ) ! 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 @@ -64641,8 +64642,8 @@ module stdlib_linalg_lapack_q ! 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_qsptrs( uplo, n, 1, afp, ipiv, work( n+1 ), n, info ) - call stdlib_qaxpy( n, one, work( n+1 ), 1, x( 1, j ), 1 ) + call stdlib_${ri}$sptrs( uplo, n, 1, afp, ipiv, work( n+1 ), n, info ) + call stdlib_${ri}$axpy( n, one, work( n+1 ), 1, x( 1, j ), 1 ) lstres = berr( j ) count = count + 1 go to 20 @@ -64661,7 +64662,7 @@ module stdlib_linalg_lapack_q ! 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_qlacn2 to estimate the infinity-norm of the matrix + ! 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 @@ -64673,12 +64674,12 @@ module stdlib_linalg_lapack_q end do kase = 0 100 continue - call stdlib_qlacn2( n, work( 2*n+1 ), work( n+1 ), iwork, ferr( j ),kase, isave ) + call stdlib_${ri}$lacn2( n, work( 2*n+1 ), work( n+1 ), iwork, ferr( j ),kase, isave ) if( kase/=0 ) then if( kase==1 ) then ! multiply by diag(w)*inv(a**t). - call stdlib_qsptrs( uplo, n, 1, afp, ipiv, work( n+1 ), n,info ) + call stdlib_${ri}$sptrs( uplo, n, 1, afp, ipiv, work( n+1 ), n,info ) do i = 1, n work( n+i ) = work( i )*work( n+i ) end do @@ -64687,7 +64688,7 @@ module stdlib_linalg_lapack_q do i = 1, n work( n+i ) = work( i )*work( n+i ) end do - call stdlib_qsptrs( uplo, n, 1, afp, ipiv, work( n+1 ), n,info ) + call stdlib_${ri}$sptrs( uplo, n, 1, afp, ipiv, work( n+1 ), n,info ) end if go to 100 end if @@ -64699,10 +64700,10 @@ module stdlib_linalg_lapack_q if( lstres/=zero )ferr( j ) = ferr( j ) / lstres end do loop_140 return - end subroutine stdlib_qsprfs + end subroutine stdlib_${ri}$sprfs - pure subroutine stdlib_qspsv( uplo, n, nrhs, ap, ipiv, b, ldb, info ) + pure subroutine stdlib_${ri}$spsv( uplo, n, nrhs, ap, ipiv, b, ldb, info ) !! DSPSV: computes the solution to a real system of linear equations !! A * X = B, !! where A is an N-by-N symmetric matrix stored in packed format and X @@ -64723,7 +64724,7 @@ module stdlib_linalg_lapack_q integer(ilp), intent(in) :: ldb, n, nrhs ! Array Arguments integer(ilp), intent(out) :: ipiv(*) - real(qp), intent(inout) :: ap(*), b(ldb,*) + real(${rk}$), intent(inout) :: ap(*), b(ldb,*) ! ===================================================================== ! Intrinsic Functions intrinsic :: max @@ -64744,16 +64745,16 @@ module stdlib_linalg_lapack_q return end if ! compute the factorization a = u*d*u**t or a = l*d*l**t. - call stdlib_qsptrf( uplo, n, ap, ipiv, info ) + call stdlib_${ri}$sptrf( uplo, n, ap, ipiv, info ) if( info==0 ) then ! solve the system a*x = b, overwriting b with x. - call stdlib_qsptrs( uplo, n, nrhs, ap, ipiv, b, ldb, info ) + call stdlib_${ri}$sptrs( uplo, n, nrhs, ap, ipiv, b, ldb, info ) end if return - end subroutine stdlib_qspsv + end subroutine stdlib_${ri}$spsv - subroutine stdlib_qspsvx( fact, uplo, n, nrhs, ap, afp, ipiv, b, ldb, x,ldx, rcond, ferr, & + subroutine stdlib_${ri}$spsvx( fact, uplo, n, nrhs, ap, afp, ipiv, b, ldb, x,ldx, rcond, ferr, & !! DSPSVX: uses the diagonal pivoting factorization A = U*D*U**T or !! A = L*D*L**T to compute the solution to a real system of linear !! equations A * X = B, where A is an N-by-N symmetric matrix stored @@ -64768,18 +64769,18 @@ module stdlib_linalg_lapack_q character, intent(in) :: fact, uplo integer(ilp), intent(out) :: info integer(ilp), intent(in) :: ldb, ldx, n, nrhs - real(qp), intent(out) :: rcond + real(${rk}$), intent(out) :: rcond ! Array Arguments integer(ilp), intent(inout) :: ipiv(*) integer(ilp), intent(out) :: iwork(*) - real(qp), intent(inout) :: afp(*) - real(qp), intent(in) :: ap(*), b(ldb,*) - real(qp), intent(out) :: berr(*), ferr(*), work(*), x(ldx,*) + real(${rk}$), intent(inout) :: afp(*) + real(${rk}$), intent(in) :: ap(*), b(ldb,*) + real(${rk}$), intent(out) :: berr(*), ferr(*), work(*), x(ldx,*) ! ===================================================================== ! Local Scalars logical(lk) :: nofact - real(qp) :: anorm + real(${rk}$) :: anorm ! Intrinsic Functions intrinsic :: max ! Executable Statements @@ -64806,8 +64807,8 @@ module stdlib_linalg_lapack_q end if if( nofact ) then ! compute the factorization a = u*d*u**t or a = l*d*l**t. - call stdlib_qcopy( n*( n+1 ) / 2, ap, 1, afp, 1 ) - call stdlib_qsptrf( uplo, n, afp, ipiv, info ) + call stdlib_${ri}$copy( n*( n+1 ) / 2, ap, 1, afp, 1 ) + call stdlib_${ri}$sptrf( uplo, n, afp, ipiv, info ) ! return if info is non-zero. if( info>0 )then rcond = zero @@ -64815,23 +64816,23 @@ module stdlib_linalg_lapack_q end if end if ! compute the norm of the matrix a. - anorm = stdlib_qlansp( 'I', uplo, n, ap, work ) + anorm = stdlib_${ri}$lansp( 'I', uplo, n, ap, work ) ! compute the reciprocal of the condition number of a. - call stdlib_qspcon( uplo, n, afp, ipiv, anorm, rcond, work, iwork, info ) + call stdlib_${ri}$spcon( uplo, n, afp, ipiv, anorm, rcond, work, iwork, info ) ! compute the solution vectors x. - call stdlib_qlacpy( 'FULL', n, nrhs, b, ldb, x, ldx ) - call stdlib_qsptrs( uplo, n, nrhs, afp, ipiv, x, ldx, info ) + call stdlib_${ri}$lacpy( 'FULL', n, nrhs, b, ldb, x, ldx ) + call stdlib_${ri}$sptrs( uplo, n, nrhs, afp, ipiv, x, ldx, info ) ! use iterative refinement to improve the computed solutions and ! compute error bounds and backward error estimates for them. - call stdlib_qsprfs( uplo, n, nrhs, ap, afp, ipiv, b, ldb, x, ldx, ferr,berr, work, & + call stdlib_${ri}$sprfs( uplo, n, nrhs, ap, afp, ipiv, b, ldb, x, ldx, ferr,berr, work, & iwork, info ) ! set info = n+1 if the matrix is singular to working precision. - if( rcond1 ) then - imax = stdlib_iqamax( k-1, ap( kc ), 1 ) + imax = stdlib_i${ri}$amax( k-1, ap( kc ), 1 ) colmax = abs( ap( kc+imax-1 ) ) else colmax = zero @@ -65015,7 +65016,7 @@ module stdlib_linalg_lapack_q end do kpc = ( imax-1 )*imax / 2 + 1 if( imax>1 ) then - jmax = stdlib_iqamax( imax-1, ap( kpc ), 1 ) + jmax = stdlib_i${ri}$amax( imax-1, ap( kpc ), 1 ) rowmax = max( rowmax, abs( ap( kpc+jmax-1 ) ) ) end if if( absakk>=alpha*colmax*( colmax / rowmax ) ) then @@ -65037,7 +65038,7 @@ module stdlib_linalg_lapack_q if( kp/=kk ) then ! interchange rows and columns kk and kp in the leading ! submatrix a(1:k,1:k) - call stdlib_qswap( kp-1, ap( knc ), 1, ap( kpc ), 1 ) + call stdlib_${ri}$swap( kp-1, ap( knc ), 1, ap( kpc ), 1 ) kx = kpc + kp - 1 do j = kp + 1, kk - 1 kx = kx + j - 1 @@ -65062,9 +65063,9 @@ module stdlib_linalg_lapack_q ! 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 r1 = one / ap( kc+k-1 ) - call stdlib_qspr( uplo, k-1, -r1, ap( kc ), 1, ap ) + call stdlib_${ri}$spr( uplo, k-1, -r1, ap( kc ), 1, ap ) ! store u(k) in column k - call stdlib_qscal( k-1, r1, ap( kc ), 1 ) + call stdlib_${ri}$scal( k-1, r1, ap( kc ), 1 ) 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) @@ -65123,7 +65124,7 @@ module stdlib_linalg_lapack_q ! imax is the row-index of the largest off-diagonal element in ! column k, and colmax is its absolute value if( k=alpha*colmax*( colmax / rowmax ) ) then @@ -65172,7 +65173,7 @@ module stdlib_linalg_lapack_q if( kp/=kk ) then ! interchange rows and columns kk and kp in the trailing ! submatrix a(k:n,k:n) - if( kp1 ) then - call stdlib_qcopy( k-1, ap( kc ), 1, work, 1 ) - call stdlib_qspmv( uplo, k-1, -one, ap, work, 1, zero, ap( kc ),1 ) - ap( kc+k-1 ) = ap( kc+k-1 ) -stdlib_qdot( k-1, work, 1, ap( kc ), 1 ) + call stdlib_${ri}$copy( k-1, ap( kc ), 1, work, 1 ) + call stdlib_${ri}$spmv( uplo, k-1, -one, ap, work, 1, zero, ap( kc ),1 ) + ap( kc+k-1 ) = ap( kc+k-1 ) -stdlib_${ri}$dot( k-1, work, 1, ap( kc ), 1 ) end if kstep = 1 else @@ -65340,15 +65341,15 @@ module stdlib_linalg_lapack_q ap( kcnext+k-1 ) = -akkp1 / d ! compute columns k and k+1 of the inverse. if( k>1 ) then - call stdlib_qcopy( k-1, ap( kc ), 1, work, 1 ) - call stdlib_qspmv( uplo, k-1, -one, ap, work, 1, zero, ap( kc ),1 ) - ap( kc+k-1 ) = ap( kc+k-1 ) -stdlib_qdot( k-1, work, 1, ap( kc ), 1 ) - ap( kcnext+k-1 ) = ap( kcnext+k-1 ) -stdlib_qdot( k-1, ap( kc ), 1, ap( & + call stdlib_${ri}$copy( k-1, ap( kc ), 1, work, 1 ) + call stdlib_${ri}$spmv( uplo, k-1, -one, ap, work, 1, zero, ap( kc ),1 ) + ap( kc+k-1 ) = ap( kc+k-1 ) -stdlib_${ri}$dot( k-1, work, 1, ap( kc ), 1 ) + ap( kcnext+k-1 ) = ap( kcnext+k-1 ) -stdlib_${ri}$dot( k-1, ap( kc ), 1, ap( & kcnext ),1 ) - call stdlib_qcopy( k-1, ap( kcnext ), 1, work, 1 ) - call stdlib_qspmv( uplo, k-1, -one, ap, work, 1, zero,ap( kcnext ), 1 ) + call stdlib_${ri}$copy( k-1, ap( kcnext ), 1, work, 1 ) + call stdlib_${ri}$spmv( uplo, k-1, -one, ap, work, 1, zero,ap( kcnext ), 1 ) - ap( kcnext+k ) = ap( kcnext+k ) -stdlib_qdot( k-1, work, 1, ap( kcnext ), 1 ) + ap( kcnext+k ) = ap( kcnext+k ) -stdlib_${ri}$dot( k-1, work, 1, ap( kcnext ), 1 ) end if kstep = 2 @@ -65359,7 +65360,7 @@ module stdlib_linalg_lapack_q ! interchange rows and columns k and kp in the leading ! submatrix a(1:k+1,1:k+1) kpc = ( kp-1 )*kp / 2 + 1 - call stdlib_qswap( kp-1, ap( kc ), 1, ap( kpc ), 1 ) + call stdlib_${ri}$swap( kp-1, ap( kc ), 1, ap( kpc ), 1 ) kx = kpc + kp - 1 do j = kp + 1, k - 1 kx = kx + j - 1 @@ -65397,10 +65398,10 @@ module stdlib_linalg_lapack_q ap( kc ) = one / ap( kc ) ! compute column k of the inverse. if( ksmlsiz ) then ! scale. - orgnrm = stdlib_qlanst( 'M', m, d( start ), e( start ) ) - call stdlib_qlascl( 'G', 0, 0, orgnrm, one, m, 1, d( start ), m,info ) - call stdlib_qlascl( 'G', 0, 0, orgnrm, one, m-1, 1, e( start ),m-1, info ) + orgnrm = stdlib_${ri}$lanst( 'M', m, d( start ), e( start ) ) + call stdlib_${ri}$lascl( 'G', 0, 0, orgnrm, one, m, 1, d( start ), m,info ) + call stdlib_${ri}$lascl( 'G', 0, 0, orgnrm, one, m-1, 1, e( start ),m-1, info ) if( icompz==1 ) then strtrw = 1 else strtrw = start end if - call stdlib_qlaed0( icompz, n, m, d( start ), e( start ),z( strtrw, start ), & + call stdlib_${ri}$laed0( icompz, n, m, d( start ), e( start ),z( strtrw, start ), & ldz, work( 1 ), n,work( storez ), iwork, info ) if( info/=0 ) then info = ( info / ( m+1 )+start-1 )*( n+1 ) +mod( info, ( m+1 ) ) + start - & @@ -66244,23 +66245,23 @@ module stdlib_linalg_lapack_q go to 50 end if ! scale back. - call stdlib_qlascl( 'G', 0, 0, one, orgnrm, m, 1, d( start ), m,info ) + call stdlib_${ri}$lascl( 'G', 0, 0, one, orgnrm, m, 1, d( start ), m,info ) else if( icompz==1 ) then ! since qr won't update a z matrix which is larger than ! the length of d, we must solve the sub-problem in a ! workspace and then multiply back into z. - call stdlib_qsteqr( 'I', m, d( start ), e( start ), work, m,work( m*m+1 ), & + call stdlib_${ri}$steqr( 'I', m, d( start ), e( start ), work, m,work( m*m+1 ), & info ) - call stdlib_qlacpy( 'A', n, m, z( 1, start ), ldz,work( storez ), n ) + call stdlib_${ri}$lacpy( 'A', n, m, z( 1, start ), ldz,work( storez ), n ) - call stdlib_qgemm( 'N', 'N', n, m, m, one,work( storez ), n, work, m, zero,& + call stdlib_${ri}$gemm( 'N', 'N', n, m, m, one,work( storez ), n, work, m, zero,& z( 1, start ), ldz ) else if( icompz==2 ) then - call stdlib_qsteqr( 'I', m, d( start ), e( start ),z( start, start ), ldz, & + call stdlib_${ri}$steqr( 'I', m, d( start ), e( start ),z( start, start ), ldz, & work, info ) else - call stdlib_qsterf( m, d( start ), e( start ), info ) + call stdlib_${ri}$sterf( m, d( start ), e( start ), info ) end if if( info/=0 ) then info = start*( n+1 ) + finish @@ -66273,7 +66274,7 @@ module stdlib_linalg_lapack_q ! endwhile if( icompz==0 ) then ! use quick sort - call stdlib_qlasrt( 'I', n, d, info ) + call stdlib_${ri}$lasrt( 'I', n, d, info ) else ! use selection sort to minimize swaps of eigenvectors do ii = 2, n @@ -66289,7 +66290,7 @@ module stdlib_linalg_lapack_q if( k/=i ) then d( k ) = d( i ) d( i ) = p - call stdlib_qswap( n, z( 1, i ), 1, z( 1, k ), 1 ) + call stdlib_${ri}$swap( n, z( 1, i ), 1, z( 1, k ), 1 ) end if end do end if @@ -66298,10 +66299,10 @@ module stdlib_linalg_lapack_q work( 1 ) = lwmin iwork( 1 ) = liwmin return - end subroutine stdlib_qstedc + end subroutine stdlib_${ri}$stedc - pure subroutine stdlib_qstegr( jobz, range, n, d, e, vl, vu, il, iu,abstol, m, w, z, ldz, & + pure subroutine stdlib_${ri}$stegr( jobz, range, n, d, e, vl, vu, il, iu,abstol, m, w, z, ldz, & !! DSTEGR: computes selected eigenvalues and, optionally, eigenvectors !! of a real symmetric tridiagonal matrix T. Any such unreduced matrix has !! a well defined set of pairwise different real eigenvalues, the corresponding @@ -66326,24 +66327,24 @@ module stdlib_linalg_lapack_q character, intent(in) :: jobz, range integer(ilp), intent(in) :: il, iu, ldz, liwork, lwork, n integer(ilp), intent(out) :: info, m - real(qp), intent(in) :: abstol, vl, vu + real(${rk}$), intent(in) :: abstol, vl, vu ! Array Arguments integer(ilp), intent(out) :: isuppz(*), iwork(*) - real(qp), intent(inout) :: d(*), e(*) - real(qp), intent(out) :: w(*), work(*) - real(qp), intent(out) :: z(ldz,*) + real(${rk}$), intent(inout) :: d(*), e(*) + real(${rk}$), intent(out) :: w(*), work(*) + real(${rk}$), intent(out) :: z(ldz,*) ! ===================================================================== ! Local Scalars logical(lk) :: tryrac ! Executable Statements info = 0 tryrac = .false. - call stdlib_qstemr( jobz, range, n, d, e, vl, vu, il, iu,m, w, z, ldz, n, isuppz, & + call stdlib_${ri}$stemr( jobz, range, n, d, e, vl, vu, il, iu,m, w, z, ldz, n, isuppz, & tryrac, work, lwork,iwork, liwork, info ) - end subroutine stdlib_qstegr + end subroutine stdlib_${ri}$stegr - pure subroutine stdlib_qstein( n, d, e, m, w, iblock, isplit, z, ldz, work,iwork, ifail, & + pure subroutine stdlib_${ri}$stein( n, d, e, m, w, iblock, isplit, z, ldz, work,iwork, ifail, & !! DSTEIN: computes the eigenvectors of a real symmetric tridiagonal !! matrix T corresponding to specified eigenvalues, using inverse !! iteration. @@ -66359,12 +66360,12 @@ module stdlib_linalg_lapack_q ! Array Arguments integer(ilp), intent(in) :: iblock(*), isplit(*) integer(ilp), intent(out) :: ifail(*), iwork(*) - real(qp), intent(in) :: d(*), e(*), w(*) - real(qp), intent(out) :: work(*), z(ldz,*) + real(${rk}$), intent(in) :: d(*), e(*), w(*) + real(${rk}$), intent(out) :: work(*), z(ldz,*) ! ===================================================================== ! Parameters - real(qp), parameter :: odm3 = 1.0e-3_qp - real(qp), parameter :: odm1 = 1.0e-1_qp + real(${rk}$), parameter :: odm3 = 1.0e-3_${rk}$ + real(${rk}$), parameter :: odm1 = 1.0e-1_${rk}$ integer(ilp), parameter :: maxits = 5 integer(ilp), parameter :: extra = 2 @@ -66372,7 +66373,7 @@ module stdlib_linalg_lapack_q ! Local Scalars integer(ilp) :: b1, blksiz, bn, gpind, i, iinfo, indrv1, indrv2, indrv3, indrv4, & indrv5, its, j, j1, jblk, jmax, nblk, nrmchk - real(qp) :: dtpcrt, eps, eps1, nrm, onenrm, ortol, pertol, scl, sep, tol, xj, xjm, & + real(${rk}$) :: dtpcrt, eps, eps1, nrm, onenrm, ortol, pertol, scl, sep, tol, xj, xjm, & ztr ! Local Arrays integer(ilp) :: iseed(4) @@ -66415,8 +66416,8 @@ module stdlib_linalg_lapack_q return end if ! get machine constants. - eps = stdlib_qlamch( 'PRECISION' ) - ! initialize seed for random number generator stdlib_qlarnv. + eps = stdlib_${ri}$lamch( 'PRECISION' ) + ! initialize seed for random number generator stdlib_${ri}$larnv. do i = 1, 4 iseed( i ) = 1 end do @@ -66473,26 +66474,26 @@ module stdlib_linalg_lapack_q its = 0 nrmchk = 0 ! get random starting vector. - call stdlib_qlarnv( 2, iseed, blksiz, work( indrv1+1 ) ) + call stdlib_${ri}$larnv( 2, iseed, blksiz, work( indrv1+1 ) ) ! copy the matrix t so it won't be destroyed in factorization. - call stdlib_qcopy( blksiz, d( b1 ), 1, work( indrv4+1 ), 1 ) - call stdlib_qcopy( blksiz-1, e( b1 ), 1, work( indrv2+2 ), 1 ) - call stdlib_qcopy( blksiz-1, e( b1 ), 1, work( indrv3+1 ), 1 ) + call stdlib_${ri}$copy( blksiz, d( b1 ), 1, work( indrv4+1 ), 1 ) + call stdlib_${ri}$copy( blksiz-1, e( b1 ), 1, work( indrv2+2 ), 1 ) + call stdlib_${ri}$copy( blksiz-1, e( b1 ), 1, work( indrv3+1 ), 1 ) ! compute lu factors with partial pivoting ( pt = lu ) tol = zero - call stdlib_qlagtf( blksiz, work( indrv4+1 ), xj, work( indrv2+2 ),work( indrv3+& + call stdlib_${ri}$lagtf( blksiz, work( indrv4+1 ), xj, work( indrv2+2 ),work( indrv3+& 1 ), tol, work( indrv5+1 ), iwork,iinfo ) ! update iteration count. 70 continue its = its + 1 if( its>maxits )go to 100 ! normalize and scale the righthand side vector pb. - jmax = stdlib_iqamax( blksiz, work( indrv1+1 ), 1 ) + jmax = stdlib_i${ri}$amax( blksiz, work( indrv1+1 ), 1 ) scl = blksiz*onenrm*max( eps,abs( work( indrv4+blksiz ) ) ) /abs( work( indrv1+& jmax ) ) - call stdlib_qscal( blksiz, scl, work( indrv1+1 ), 1 ) + call stdlib_${ri}$scal( blksiz, scl, work( indrv1+1 ), 1 ) ! solve the system lu = pb. - call stdlib_qlagts( -1, blksiz, work( indrv4+1 ), work( indrv2+2 ),work( indrv3+& + call stdlib_${ri}$lagts( -1, blksiz, work( indrv4+1 ), work( indrv2+2 ),work( indrv3+& 1 ), work( indrv5+1 ), iwork,work( indrv1+1 ), tol, iinfo ) ! reorthogonalize by modified gram-schmidt if eigenvalues are ! close enough. @@ -66500,13 +66501,13 @@ module stdlib_linalg_lapack_q if( abs( xj-xjm )>ortol )gpind = j if( gpind/=j ) then do i = gpind, j - 1 - ztr = -stdlib_qdot( blksiz, work( indrv1+1 ), 1, z( b1, i ),1 ) - call stdlib_qaxpy( blksiz, ztr, z( b1, i ), 1,work( indrv1+1 ), 1 ) + ztr = -stdlib_${ri}$dot( blksiz, work( indrv1+1 ), 1, z( b1, i ),1 ) + call stdlib_${ri}$axpy( blksiz, ztr, z( b1, i ), 1,work( indrv1+1 ), 1 ) end do end if ! check the infinity norm of the iterate. 90 continue - jmax = stdlib_iqamax( blksiz, work( indrv1+1 ), 1 ) + jmax = stdlib_i${ri}$amax( blksiz, work( indrv1+1 ), 1 ) nrm = abs( work( indrv1+jmax ) ) ! continue for additional iterations after norm reaches ! stopping criterion. @@ -66521,10 +66522,10 @@ module stdlib_linalg_lapack_q ifail( info ) = j ! accept iterate as jth eigenvector. 110 continue - scl = one / stdlib_qnrm2( blksiz, work( indrv1+1 ), 1 ) - jmax = stdlib_iqamax( blksiz, work( indrv1+1 ), 1 ) + scl = one / stdlib_${ri}$nrm2( blksiz, work( indrv1+1 ), 1 ) + jmax = stdlib_i${ri}$amax( blksiz, work( indrv1+1 ), 1 ) if( work( indrv1+jmax )wl).and.(r2<=wu)).or.(indeig.and.(iil==1)) ) & then @@ -66787,19 +66788,19 @@ module stdlib_linalg_lapack_q iindwk = 3*n + 1 ! scale matrix to allowable range, if necessary. ! the allowable range is related to the pivmin parameter; see the - ! comments in stdlib_qlarrd. the preference for scaling small values + ! comments in stdlib_${ri}$larrd. the preference for scaling small values ! up is heuristic; we expect users' matrices not to be close to the ! rmax threshold. scale = one - tnrm = stdlib_qlanst( 'M', n, d, e ) + tnrm = stdlib_${ri}$lanst( 'M', n, d, e ) if( tnrm>zero .and. tnrmrmax ) then scale = rmax / tnrm end if if( scale/=one ) then - call stdlib_qscal( n, scale, d, 1 ) - call stdlib_qscal( n-1, scale, e, 1 ) + call stdlib_${ri}$scal( n, scale, d, 1 ) + call stdlib_${ri}$scal( n-1, scale, e, 1 ) tnrm = tnrm*scale if( valeig ) then ! if eigenvalues in interval have to be found, @@ -66811,13 +66812,13 @@ module stdlib_linalg_lapack_q ! compute the desired eigenvalues of the tridiagonal after splitting ! into smaller subblocks if the corresponding off-diagonal elements ! are small - ! thresh is the splitting parameter for stdlib_qlarre + ! thresh is the splitting parameter for stdlib_${ri}$larre ! a negative thresh forces the old splitting criterion based on the ! size of the off-diagonal. a positive thresh switches to splitting ! which preserves relative accuracy. if( tryrac ) then ! test whether the matrix warrants the more expensive relative approach. - call stdlib_qlarrr( n, d, e, iinfo ) + call stdlib_${ri}$larrr( n, d, e, iinfo ) else ! the user does not care about relative accurately eigenvalues iinfo = -1 @@ -66832,7 +66833,7 @@ module stdlib_linalg_lapack_q endif if( tryrac ) then ! copy original diagonal, needed to guarantee relative accuracy - call stdlib_qcopy(n,d,1,work(indd),1) + call stdlib_${ri}$copy(n,d,1,work(indd),1) endif ! store the squares of the offdiagonal values of t do j = 1, n-1 @@ -66840,18 +66841,18 @@ module stdlib_linalg_lapack_q end do ! set the tolerance parameters for bisection if( .not.wantz ) then - ! stdlib_qlarre computes the eigenvalues to full precision. + ! stdlib_${ri}$larre computes the eigenvalues to full precision. rtol1 = four * eps rtol2 = four * eps else - ! stdlib_qlarre computes the eigenvalues to less than full precision. - ! stdlib_qlarrv will refine the eigenvalue approximations, and we can - ! need less accurate initial bisection in stdlib_qlarre. - ! note: these settings do only affect the subset case and stdlib_qlarre + ! stdlib_${ri}$larre computes the eigenvalues to less than full precision. + ! stdlib_${ri}$larrv will refine the eigenvalue approximations, and we can + ! need less accurate initial bisection in stdlib_${ri}$larre. + ! note: these settings do only affect the subset case and stdlib_${ri}$larre rtol1 = sqrt(eps) - rtol2 = max( sqrt(eps)*5.0e-3_qp, four * eps ) + rtol2 = max( sqrt(eps)*5.0e-3_${rk}$, four * eps ) endif - call stdlib_qlarre( range, n, wl, wu, iil, iiu, d, e,work(inde2), rtol1, rtol2, & + call stdlib_${ri}$larre( range, n, wl, wu, iil, iiu, d, e,work(inde2), rtol1, rtol2, & thresh, nsplit,iwork( iinspl ), m, w, work( inderr ),work( indgp ), iwork( iindbl ),& iwork( iindw ), work( indgrs ), pivmin,work( indwrk ), iwork( iindwk ), iinfo ) @@ -66859,13 +66860,13 @@ module stdlib_linalg_lapack_q info = 10 + abs( iinfo ) return end if - ! note that if range /= 'v', stdlib_qlarre computes bounds on the desired + ! note that if range /= 'v', stdlib_${ri}$larre computes bounds on the desired ! part of the spectrum. all desired eigenvalues are contained in ! (wl,wu] if( wantz ) then ! compute the desired eigenvectors corresponding to the computed ! eigenvalues - call stdlib_qlarrv( n, wl, wu, d, e,pivmin, iwork( iinspl ), m,1, m, minrgp, & + call stdlib_${ri}$larrv( n, wl, wu, d, e,pivmin, iwork( iinspl ), m,1, m, minrgp, & rtol1, rtol2,w, work( inderr ), work( indgp ), iwork( iindbl ),iwork( iindw ), & work( indgrs ), z, ldz,isuppz, work( indwrk ), iwork( iindwk ), iinfo ) if( iinfo/=0 ) then @@ -66873,10 +66874,10 @@ module stdlib_linalg_lapack_q return end if else - ! stdlib_qlarre computes eigenvalues of the (shifted) root representation - ! stdlib_qlarrv returns the eigenvalues of the unshifted matrix. + ! stdlib_${ri}$larre computes eigenvalues of the (shifted) root representation + ! stdlib_${ri}$larrv returns the eigenvalues of the unshifted matrix. ! however, if the eigenvectors are not desired by the user, we need - ! to apply the corresponding shifts from stdlib_qlarre to obtain the + ! to apply the corresponding shifts from stdlib_${ri}$larre to obtain the ! eigenvalues of the original matrix. do j = 1, m itmp = iwork( iindbl+j-1 ) @@ -66908,7 +66909,7 @@ module stdlib_linalg_lapack_q ifirst = iwork(iindw+wbegin-1) ilast = iwork(iindw+wend-1) rtol2 = four * eps - call stdlib_qlarrj( in,work(indd+ibegin-1), work(inde2+ibegin-1),ifirst, & + call stdlib_${ri}$larrj( in,work(indd+ibegin-1), work(inde2+ibegin-1),ifirst, & ilast, rtol2, offset, w(wbegin),work( inderr+wbegin-1 ),work( indwrk ), iwork(& iindwk ), pivmin,tnrm, iinfo ) ibegin = iend + 1 @@ -66917,14 +66918,14 @@ module stdlib_linalg_lapack_q endif ! if matrix was scaled, then rescale eigenvalues appropriately. if( scale/=one ) then - call stdlib_qscal( m, one / scale, w, 1 ) + call stdlib_${ri}$scal( m, one / scale, w, 1 ) end if end if ! if eigenvalues are not in increasing order, then sort them, ! possibly along with eigenvectors. if( nsplit>1 .or. n==2 ) then if( .not. wantz ) then - call stdlib_qlasrt( 'I', m, w, iinfo ) + call stdlib_${ri}$lasrt( 'I', m, w, iinfo ) if( iinfo/=0 ) then info = 3 return @@ -66943,7 +66944,7 @@ module stdlib_linalg_lapack_q w( i ) = w( j ) w( j ) = tmp if( wantz ) then - call stdlib_qswap( n, z( 1, i ), 1, z( 1, j ), 1 ) + call stdlib_${ri}$swap( n, z( 1, i ), 1, z( 1, j ), 1 ) itmp = isuppz( 2*i-1 ) isuppz( 2*i-1 ) = isuppz( 2*j-1 ) isuppz( 2*j-1 ) = itmp @@ -66958,10 +66959,10 @@ module stdlib_linalg_lapack_q work( 1 ) = lwmin iwork( 1 ) = liwmin return - end subroutine stdlib_qstemr + end subroutine stdlib_${ri}$stemr - pure subroutine stdlib_qsteqr( compz, n, d, e, z, ldz, work, info ) + pure subroutine stdlib_${ri}$steqr( compz, n, d, e, z, ldz, work, info ) !! DSTEQR: computes all eigenvalues and, optionally, eigenvectors of a !! symmetric tridiagonal matrix using the implicit QL or QR method. !! The eigenvectors of a full or band symmetric matrix can also be found @@ -66975,8 +66976,8 @@ module stdlib_linalg_lapack_q integer(ilp), intent(out) :: info integer(ilp), intent(in) :: ldz, n ! Array Arguments - real(qp), intent(inout) :: d(*), e(*), z(ldz,*) - real(qp), intent(out) :: work(*) + real(${rk}$), intent(inout) :: d(*), e(*), z(ldz,*) + real(${rk}$), intent(out) :: work(*) ! ===================================================================== ! Parameters integer(ilp), parameter :: maxit = 30 @@ -66985,7 +66986,7 @@ module stdlib_linalg_lapack_q ! Local Scalars integer(ilp) :: i, icompz, ii, iscale, j, jtot, k, l, l1, lend, lendm1, lendp1, lendsv,& lm1, lsv, m, mm, mm1, nm1, nmaxit - real(qp) :: anorm, b, c, eps, eps2, f, g, p, r, rt1, rt2, s, safmax, safmin, ssfmax, & + real(${rk}$) :: anorm, b, c, eps, eps2, f, g, p, r, rt1, rt2, s, safmax, safmin, ssfmax, & ssfmin, tst ! Intrinsic Functions intrinsic :: abs,max,sign,sqrt @@ -67019,15 +67020,15 @@ module stdlib_linalg_lapack_q return end if ! determine the unit roundoff and over/underflow thresholds. - eps = stdlib_qlamch( 'E' ) + eps = stdlib_${ri}$lamch( 'E' ) eps2 = eps**2 - safmin = stdlib_qlamch( 'S' ) + safmin = stdlib_${ri}$lamch( 'S' ) safmax = one / safmin ssfmax = sqrt( safmax ) / three ssfmin = sqrt( safmin ) / eps2 ! compute the eigenvalues and eigenvectors of the tridiagonal ! matrix. - if( icompz==2 )call stdlib_qlaset( 'FULL', n, n, zero, one, z, ldz ) + if( icompz==2 )call stdlib_${ri}$laset( 'FULL', n, n, zero, one, z, ldz ) nmaxit = n*maxit jtot = 0 ! determine where the matrix splits and choose ql or qr iteration @@ -67057,17 +67058,17 @@ module stdlib_linalg_lapack_q l1 = m + 1 if( lend==l )go to 10 ! scale submatrix in rows and columns l to lend - anorm = stdlib_qlanst( 'M', lend-l+1, d( l ), e( l ) ) + anorm = stdlib_${ri}$lanst( 'M', lend-l+1, d( l ), e( l ) ) iscale = 0 if( anorm==zero )go to 10 if( anorm>ssfmax ) then iscale = 1 - call stdlib_qlascl( 'G', 0, 0, anorm, ssfmax, lend-l+1, 1, d( l ), n,info ) - call stdlib_qlascl( 'G', 0, 0, anorm, ssfmax, lend-l, 1, e( l ), n,info ) + call stdlib_${ri}$lascl( 'G', 0, 0, anorm, ssfmax, lend-l+1, 1, d( l ), n,info ) + call stdlib_${ri}$lascl( 'G', 0, 0, anorm, ssfmax, lend-l, 1, e( l ), n,info ) else if( anorm0 ) then - call stdlib_qlaev2( d( l ), e( l ), d( l+1 ), rt1, rt2, c, s ) + call stdlib_${ri}$laev2( d( l ), e( l ), d( l+1 ), rt1, rt2, c, s ) work( l ) = c work( n-1+l ) = s - call stdlib_qlasr( 'R', 'V', 'B', n, 2, work( l ),work( n-1+l ), z( 1, l ), & + call stdlib_${ri}$lasr( 'R', 'V', 'B', n, 2, work( l ),work( n-1+l ), z( 1, l ), & ldz ) else - call stdlib_qlae2( d( l ), e( l ), d( l+1 ), rt1, rt2 ) + call stdlib_${ri}$lae2( d( l ), e( l ), d( l+1 ), rt1, rt2 ) end if d( l ) = rt1 d( l+1 ) = rt2 @@ -67113,7 +67114,7 @@ module stdlib_linalg_lapack_q jtot = jtot + 1 ! form shift. g = ( d( l+1 )-p ) / ( two*e( l ) ) - r = stdlib_qlapy2( g, one ) + r = stdlib_${ri}$lapy2( g, one ) g = d( m ) - p + ( e( l ) / ( g+sign( r, g ) ) ) s = one c = one @@ -67123,7 +67124,7 @@ module stdlib_linalg_lapack_q do i = mm1, l, -1 f = s*e( i ) b = c*e( i ) - call stdlib_qlartg( g, f, c, s, r ) + call stdlib_${ri}$lartg( g, f, c, s, r ) if( i/=m-1 )e( i+1 ) = r g = d( i+1 ) - p r = ( d( i )-g )*s + two*c*b @@ -67139,7 +67140,7 @@ module stdlib_linalg_lapack_q ! if eigenvectors are desired, then apply saved rotations. if( icompz>0 ) then mm = m - l + 1 - call stdlib_qlasr( 'R', 'V', 'B', n, mm, work( l ), work( n-1+l ),z( 1, l ), ldz & + call stdlib_${ri}$lasr( 'R', 'V', 'B', n, mm, work( l ), work( n-1+l ),z( 1, l ), ldz & ) end if d( l ) = d( l ) - p @@ -67167,17 +67168,17 @@ module stdlib_linalg_lapack_q if( m>lend )e( m-1 ) = zero p = d( l ) if( m==l )go to 130 - ! if remaining matrix is 2-by-2, use stdlib_qlae2 or stdlib_dlaev2 + ! if remaining matrix is 2-by-2, use stdlib_${ri}$lae2 or stdlib_dlaev2 ! to compute its eigensystem. if( m==l-1 ) then if( icompz>0 ) then - call stdlib_qlaev2( d( l-1 ), e( l-1 ), d( l ), rt1, rt2, c, s ) + call stdlib_${ri}$laev2( d( l-1 ), e( l-1 ), d( l ), rt1, rt2, c, s ) work( m ) = c work( n-1+m ) = s - call stdlib_qlasr( 'R', 'V', 'F', n, 2, work( m ),work( n-1+m ), z( 1, l-1 ), & + call stdlib_${ri}$lasr( 'R', 'V', 'F', n, 2, work( m ),work( n-1+m ), z( 1, l-1 ), & ldz ) else - call stdlib_qlae2( d( l-1 ), e( l-1 ), d( l ), rt1, rt2 ) + call stdlib_${ri}$lae2( d( l-1 ), e( l-1 ), d( l ), rt1, rt2 ) end if d( l-1 ) = rt1 d( l ) = rt2 @@ -67190,7 +67191,7 @@ module stdlib_linalg_lapack_q jtot = jtot + 1 ! form shift. g = ( d( l-1 )-p ) / ( two*e( l-1 ) ) - r = stdlib_qlapy2( g, one ) + r = stdlib_${ri}$lapy2( g, one ) g = d( m ) - p + ( e( l-1 ) / ( g+sign( r, g ) ) ) s = one c = one @@ -67200,7 +67201,7 @@ module stdlib_linalg_lapack_q do i = m, lm1 f = s*e( i ) b = c*e( i ) - call stdlib_qlartg( g, f, c, s, r ) + call stdlib_${ri}$lartg( g, f, c, s, r ) if( i/=m )e( i-1 ) = r g = d( i ) - p r = ( d( i+1 )-g )*s + two*c*b @@ -67216,7 +67217,7 @@ module stdlib_linalg_lapack_q ! if eigenvectors are desired, then apply saved rotations. if( icompz>0 ) then mm = l - m + 1 - call stdlib_qlasr( 'R', 'V', 'F', n, mm, work( m ), work( n-1+m ),z( 1, m ), ldz & + call stdlib_${ri}$lasr( 'R', 'V', 'F', n, mm, work( m ), work( n-1+m ),z( 1, m ), ldz & ) end if d( l ) = d( l ) - p @@ -67232,14 +67233,14 @@ module stdlib_linalg_lapack_q ! undo scaling if necessary 140 continue if( iscale==1 ) then - call stdlib_qlascl( 'G', 0, 0, ssfmax, anorm, lendsv-lsv+1, 1,d( lsv ), n, info ) + call stdlib_${ri}$lascl( 'G', 0, 0, ssfmax, anorm, lendsv-lsv+1, 1,d( lsv ), n, info ) - call stdlib_qlascl( 'G', 0, 0, ssfmax, anorm, lendsv-lsv, 1, e( lsv ),n, info ) + call stdlib_${ri}$lascl( 'G', 0, 0, ssfmax, anorm, lendsv-lsv, 1, e( lsv ),n, info ) else if( iscale==2 ) then - call stdlib_qlascl( 'G', 0, 0, ssfmin, anorm, lendsv-lsv+1, 1,d( lsv ), n, info ) + call stdlib_${ri}$lascl( 'G', 0, 0, ssfmin, anorm, lendsv-lsv+1, 1,d( lsv ), n, info ) - call stdlib_qlascl( 'G', 0, 0, ssfmin, anorm, lendsv-lsv, 1, e( lsv ),n, info ) + call stdlib_${ri}$lascl( 'G', 0, 0, ssfmin, anorm, lendsv-lsv, 1, e( lsv ),n, info ) end if ! check for no convergence to an eigenvalue after a total @@ -67253,7 +67254,7 @@ module stdlib_linalg_lapack_q 160 continue if( icompz==0 ) then ! use quick sort - call stdlib_qlasrt( 'I', n, d, info ) + call stdlib_${ri}$lasrt( 'I', n, d, info ) else ! use selection sort to minimize swaps of eigenvectors do ii = 2, n @@ -67269,16 +67270,16 @@ module stdlib_linalg_lapack_q if( k/=i ) then d( k ) = d( i ) d( i ) = p - call stdlib_qswap( n, z( 1, i ), 1, z( 1, k ), 1 ) + call stdlib_${ri}$swap( n, z( 1, i ), 1, z( 1, k ), 1 ) end if end do end if 190 continue return - end subroutine stdlib_qsteqr + end subroutine stdlib_${ri}$steqr - pure subroutine stdlib_qsterf( n, d, e, info ) + pure subroutine stdlib_${ri}$sterf( n, d, e, info ) !! DSTERF: computes all eigenvalues of a symmetric tridiagonal matrix !! using the Pal-Walker-Kahan variant of the QL or QR algorithm. ! -- lapack computational routine -- @@ -67288,7 +67289,7 @@ module stdlib_linalg_lapack_q integer(ilp), intent(out) :: info integer(ilp), intent(in) :: n ! Array Arguments - real(qp), intent(inout) :: d(*), e(*) + real(${rk}$), intent(inout) :: d(*), e(*) ! ===================================================================== ! Parameters integer(ilp), parameter :: maxit = 30 @@ -67296,7 +67297,7 @@ module stdlib_linalg_lapack_q ! Local Scalars integer(ilp) :: i, iscale, jtot, l, l1, lend, lendsv, lsv, m, nmaxit - real(qp) :: alpha, anorm, bb, c, eps, eps2, gamma, oldc, oldgam, p, r, rt1, rt2, rte, & + real(${rk}$) :: alpha, anorm, bb, c, eps, eps2, gamma, oldc, oldgam, p, r, rt1, rt2, rte, & s, safmax, safmin, sigma, ssfmax, ssfmin, rmax ! Intrinsic Functions intrinsic :: abs,sign,sqrt @@ -67311,13 +67312,13 @@ module stdlib_linalg_lapack_q end if if( n<=1 )return ! determine the unit roundoff for this environment. - eps = stdlib_qlamch( 'E' ) + eps = stdlib_${ri}$lamch( 'E' ) eps2 = eps**2 - safmin = stdlib_qlamch( 'S' ) + safmin = stdlib_${ri}$lamch( 'S' ) safmax = one / safmin ssfmax = sqrt( safmax ) / three ssfmin = sqrt( safmin ) / eps2 - rmax = stdlib_qlamch( 'O' ) + rmax = stdlib_${ri}$lamch( 'O' ) ! compute the eigenvalues of the tridiagonal matrix. nmaxit = n*maxit sigma = zero @@ -67345,17 +67346,17 @@ module stdlib_linalg_lapack_q l1 = m + 1 if( lend==l )go to 10 ! scale submatrix in rows and columns l to lend - anorm = stdlib_qlanst( 'M', lend-l+1, d( l ), e( l ) ) + anorm = stdlib_${ri}$lanst( 'M', lend-l+1, d( l ), e( l ) ) iscale = 0 if( anorm==zero )go to 10 if( (anorm>ssfmax) ) then iscale = 1 - call stdlib_qlascl( 'G', 0, 0, anorm, ssfmax, lend-l+1, 1, d( l ), n,info ) - call stdlib_qlascl( 'G', 0, 0, anorm, ssfmax, lend-l, 1, e( l ), n,info ) + call stdlib_${ri}$lascl( 'G', 0, 0, anorm, ssfmax, lend-l+1, 1, d( l ), n,info ) + call stdlib_${ri}$lascl( 'G', 0, 0, anorm, ssfmax, lend-l, 1, e( l ), n,info ) else if( anormlend )e( m-1 ) = zero p = d( l ) if( m==l )go to 140 - ! if remaining matrix is 2 by 2, use stdlib_qlae2 to compute its + ! if remaining matrix is 2 by 2, use stdlib_${ri}$lae2 to compute its ! eigenvalues. if( m==l-1 ) then rte = sqrt( e( l-1 ) ) - call stdlib_qlae2( d( l ), rte, d( l-1 ), rt1, rt2 ) + call stdlib_${ri}$lae2( d( l ), rte, d( l-1 ), rt1, rt2 ) d( l ) = rt1 d( l-1 ) = rt2 e( l-1 ) = zero @@ -67458,7 +67459,7 @@ module stdlib_linalg_lapack_q ! form shift. rte = sqrt( e( l-1 ) ) sigma = ( d( l-1 )-p ) / ( two*rte ) - r = stdlib_qlapy2( sigma, one ) + r = stdlib_${ri}$lapy2( sigma, one ) sigma = p - ( rte / ( sigma+sign( r, sigma ) ) ) c = one s = zero @@ -67494,9 +67495,9 @@ module stdlib_linalg_lapack_q end if ! undo scaling if necessary 150 continue - if( iscale==1 )call stdlib_qlascl( 'G', 0, 0, ssfmax, anorm, lendsv-lsv+1, 1,d( lsv ), & + if( iscale==1 )call stdlib_${ri}$lascl( 'G', 0, 0, ssfmax, anorm, lendsv-lsv+1, 1,d( lsv ), & n, info ) - if( iscale==2 )call stdlib_qlascl( 'G', 0, 0, ssfmin, anorm, lendsv-lsv+1, 1,d( lsv ), & + if( iscale==2 )call stdlib_${ri}$lascl( 'G', 0, 0, ssfmin, anorm, lendsv-lsv+1, 1,d( lsv ), & n, info ) ! check for no convergence to an eigenvalue after a total ! of n*maxit iterations. @@ -67507,13 +67508,13 @@ module stdlib_linalg_lapack_q go to 180 ! sort eigenvalues in increasing order. 170 continue - call stdlib_qlasrt( 'I', n, d, info ) + call stdlib_${ri}$lasrt( 'I', n, d, info ) 180 continue return - end subroutine stdlib_qsterf + end subroutine stdlib_${ri}$sterf - pure subroutine stdlib_qstev( jobz, n, d, e, z, ldz, work, info ) + pure subroutine stdlib_${ri}$stev( jobz, n, d, e, z, ldz, work, info ) !! DSTEV: computes all eigenvalues and, optionally, eigenvectors of a !! real symmetric tridiagonal matrix A. ! -- lapack driver routine -- @@ -67524,14 +67525,14 @@ module stdlib_linalg_lapack_q integer(ilp), intent(out) :: info integer(ilp), intent(in) :: ldz, n ! Array Arguments - real(qp), intent(inout) :: d(*), e(*) - real(qp), intent(out) :: work(*), z(ldz,*) + real(${rk}$), intent(inout) :: d(*), e(*) + real(${rk}$), intent(out) :: work(*), z(ldz,*) ! ===================================================================== ! Local Scalars logical(lk) :: wantz integer(ilp) :: imax, iscale - real(qp) :: bignum, eps, rmax, rmin, safmin, sigma, smlnum, tnrm + real(${rk}$) :: bignum, eps, rmax, rmin, safmin, sigma, smlnum, tnrm ! Intrinsic Functions intrinsic :: sqrt ! Executable Statements @@ -67556,15 +67557,15 @@ module stdlib_linalg_lapack_q return end if ! get machine constants. - safmin = stdlib_qlamch( 'SAFE MINIMUM' ) - eps = stdlib_qlamch( 'PRECISION' ) + safmin = stdlib_${ri}$lamch( 'SAFE MINIMUM' ) + eps = stdlib_${ri}$lamch( 'PRECISION' ) smlnum = safmin / eps bignum = one / smlnum rmin = sqrt( smlnum ) rmax = sqrt( bignum ) ! scale matrix to allowable range, if necessary. iscale = 0 - tnrm = stdlib_qlanst( 'M', n, d, e ) + tnrm = stdlib_${ri}$lanst( 'M', n, d, e ) if( tnrm>zero .and. tnrmzero .and. tnrmzero .and. tnrm 0. indifl = indisp + n ! indiwo is the offset of the remaining integer workspace. indiwo = indisp + n ! if all eigenvalues are desired, then - ! call stdlib_qsterf or stdlib_qstemr. if this fails for some eigenvalue, then - ! try stdlib_qstebz. + ! call stdlib_${ri}$sterf or stdlib_${ri}$stemr. if this fails for some eigenvalue, then + ! try stdlib_${ri}$stebz. test = .false. if( indeig ) then if( il==1 .and. iu==n ) then @@ -67879,18 +67880,18 @@ module stdlib_linalg_lapack_q end if end if if( ( alleig .or. test ) .and. ieeeok==1 ) then - call stdlib_qcopy( n-1, e( 1 ), 1, work( 1 ), 1 ) + call stdlib_${ri}$copy( n-1, e( 1 ), 1, work( 1 ), 1 ) if( .not.wantz ) then - call stdlib_qcopy( n, d, 1, w, 1 ) - call stdlib_qsterf( n, w, work, info ) + call stdlib_${ri}$copy( n, d, 1, w, 1 ) + call stdlib_${ri}$sterf( n, w, work, info ) else - call stdlib_qcopy( n, d, 1, work( n+1 ), 1 ) + call stdlib_${ri}$copy( n, d, 1, work( n+1 ), 1 ) if (abstol <= two*n*eps) then tryrac = .true. else tryrac = .false. end if - call stdlib_qstemr( jobz, 'A', n, work( n+1 ), work, vl, vu, il,iu, m, w, z, ldz,& + call stdlib_${ri}$stemr( jobz, 'A', n, work( n+1 ), work, vl, vu, il,iu, m, w, z, ldz,& n, isuppz, tryrac,work( 2*n+1 ), lwork-2*n, iwork, liwork, info ) end if if( info==0 ) then @@ -67899,16 +67900,16 @@ module stdlib_linalg_lapack_q end if info = 0 end if - ! otherwise, call stdlib_qstebz and, if eigenvectors are desired, stdlib_qstein. + ! otherwise, call stdlib_${ri}$stebz and, if eigenvectors are desired, stdlib_${ri}$stein. if( wantz ) then order = 'B' else order = 'E' end if - call stdlib_qstebz( range, order, n, vll, vuu, il, iu, abstol, d, e, m,nsplit, w, & + call stdlib_${ri}$stebz( range, order, n, vll, vuu, il, iu, abstol, d, e, m,nsplit, w, & iwork( indibl ), iwork( indisp ), work,iwork( indiwo ), info ) if( wantz ) then - call stdlib_qstein( n, d, e, m, w, iwork( indibl ), iwork( indisp ),z, ldz, work, & + call stdlib_${ri}$stein( n, d, e, m, w, iwork( indibl ), iwork( indisp ),z, ldz, work, & iwork( indiwo ), iwork( indifl ),info ) end if ! if matrix was scaled, then rescale eigenvalues appropriately. @@ -67919,7 +67920,7 @@ module stdlib_linalg_lapack_q else imax = info - 1 end if - call stdlib_qscal( imax, one / sigma, w, 1 ) + call stdlib_${ri}$scal( imax, one / sigma, w, 1 ) end if ! if eigenvalues are not in order, then sort them, along with ! eigenvectors. @@ -67939,19 +67940,19 @@ module stdlib_linalg_lapack_q iwork( i ) = iwork( j ) w( j ) = tmp1 iwork( j ) = itmp1 - call stdlib_qswap( n, z( 1, i ), 1, z( 1, j ), 1 ) + call stdlib_${ri}$swap( n, z( 1, i ), 1, z( 1, j ), 1 ) end if end do end if ! causes problems with tests 19 - ! if (wantz .and. indeig ) z( 1,1) = z(1,1) / 1.002_qp + .002 + ! if (wantz .and. indeig ) z( 1,1) = z(1,1) / 1.002_${rk}$ + .002 work( 1 ) = lwmin iwork( 1 ) = liwmin return - end subroutine stdlib_qstevr + end subroutine stdlib_${ri}$stevr - pure subroutine stdlib_qstevx( jobz, range, n, d, e, vl, vu, il, iu, abstol,m, w, z, ldz, & + pure subroutine stdlib_${ri}$stevx( jobz, range, n, d, e, vl, vu, il, iu, abstol,m, w, z, ldz, & !! DSTEVX: computes selected eigenvalues and, optionally, eigenvectors !! of a real symmetric tridiagonal matrix A. Eigenvalues and !! eigenvectors can be selected by specifying either a range of values @@ -67964,11 +67965,11 @@ module stdlib_linalg_lapack_q character, intent(in) :: jobz, range integer(ilp), intent(in) :: il, iu, ldz, n integer(ilp), intent(out) :: info, m - real(qp), intent(in) :: abstol, vl, vu + real(${rk}$), intent(in) :: abstol, vl, vu ! Array Arguments integer(ilp), intent(out) :: ifail(*), iwork(*) - real(qp), intent(inout) :: d(*), e(*) - real(qp), intent(out) :: w(*), work(*), z(ldz,*) + real(${rk}$), intent(inout) :: d(*), e(*) + real(${rk}$), intent(out) :: w(*), work(*), z(ldz,*) ! ===================================================================== ! Local Scalars @@ -67976,7 +67977,7 @@ module stdlib_linalg_lapack_q character :: order integer(ilp) :: i, imax, indibl, indisp, indiwo, indwrk, iscale, itmp1, j, jj, & nsplit - real(qp) :: bignum, eps, rmax, rmin, safmin, sigma, smlnum, tmp1, tnrm, vll, & + real(${rk}$) :: bignum, eps, rmax, rmin, safmin, sigma, smlnum, tmp1, tnrm, vll, & vuu ! Intrinsic Functions intrinsic :: max,min,sqrt @@ -68028,8 +68029,8 @@ module stdlib_linalg_lapack_q return end if ! get machine constants. - safmin = stdlib_qlamch( 'SAFE MINIMUM' ) - eps = stdlib_qlamch( 'PRECISION' ) + safmin = stdlib_${ri}$lamch( 'SAFE MINIMUM' ) + eps = stdlib_${ri}$lamch( 'PRECISION' ) smlnum = safmin / eps bignum = one / smlnum rmin = sqrt( smlnum ) @@ -68043,7 +68044,7 @@ module stdlib_linalg_lapack_q vll = zero vuu = zero end if - tnrm = stdlib_qlanst( 'M', n, d, e ) + tnrm = stdlib_${ri}$lanst( 'M', n, d, e ) if( tnrm>zero .and. tnrm1 ) then if( ip/=i ) then - call stdlib_qswap( i-1, a( i, 1 ), lda,a( ip, 1 ), lda ) + call stdlib_${ri}$swap( i-1, a( i, 1 ), lda,a( ip, 1 ), lda ) end if end if else @@ -68707,7 +68708,7 @@ module stdlib_linalg_lapack_q ip = -ipiv( i ) if ( i>1 ) then if( ip/=(i+1) ) then - call stdlib_qswap( i-1, a( i+1, 1 ), lda,a( ip, 1 ), lda ) + call stdlib_${ri}$swap( i-1, a( i+1, 1 ), lda,a( ip, 1 ), lda ) end if end if ! convert ipiv @@ -68732,7 +68733,7 @@ module stdlib_linalg_lapack_q ip = ipiv( i ) if ( i>1 ) then if( ip/=i ) then - call stdlib_qswap( i-1, a( ip, 1 ), lda,a( i, 1 ), lda ) + call stdlib_${ri}$swap( i-1, a( ip, 1 ), lda,a( i, 1 ), lda ) end if end if else @@ -68742,7 +68743,7 @@ module stdlib_linalg_lapack_q ip = -ipiv( i ) if ( i>1 ) then if( ip/=(i+1) ) then - call stdlib_qswap( i-1, a( ip, 1 ), lda,a( i+1, 1 ), lda ) + call stdlib_${ri}$swap( i-1, a( ip, 1 ), lda,a( i+1, 1 ), lda ) end if end if ! convert ipiv @@ -68768,10 +68769,10 @@ module stdlib_linalg_lapack_q ! end a is lower end if return - end subroutine stdlib_qsyconvf + end subroutine stdlib_${ri}$syconvf - pure subroutine stdlib_qsyconvf_rook( uplo, way, n, a, lda, e, ipiv, info ) + pure subroutine stdlib_${ri}$syconvf_rook( uplo, way, n, a, lda, e, ipiv, info ) !! If parameter WAY = 'C': !! DSYCONVF_ROOK: converts the factorization output format used in !! DSYTRF_ROOK provided on entry in parameter A into the factorization @@ -68794,7 +68795,7 @@ module stdlib_linalg_lapack_q integer(ilp), intent(in) :: lda, n ! Array Arguments integer(ilp), intent(in) :: ipiv(*) - real(qp), intent(inout) :: a(lda,*), e(*) + real(${rk}$), intent(inout) :: a(lda,*), e(*) ! ===================================================================== ! External Subroutines @@ -68850,7 +68851,7 @@ module stdlib_linalg_lapack_q ip = ipiv( i ) if( i1 ) then if( ip/=i ) then - call stdlib_qswap( i-1, a( i, 1 ), lda,a( ip, 1 ), lda ) + call stdlib_${ri}$swap( i-1, a( i, 1 ), lda,a( ip, 1 ), lda ) end if end if else @@ -68962,10 +68963,10 @@ module stdlib_linalg_lapack_q ip2 = -ipiv( i+1 ) if ( i>1 ) then if( ip/=i ) then - call stdlib_qswap( i-1, a( i, 1 ), lda,a( ip, 1 ), lda ) + call stdlib_${ri}$swap( i-1, a( i, 1 ), lda,a( ip, 1 ), lda ) end if if( ip2/=(i+1) ) then - call stdlib_qswap( i-1, a( i+1, 1 ), lda,a( ip2, 1 ), lda ) + call stdlib_${ri}$swap( i-1, a( i+1, 1 ), lda,a( ip2, 1 ), lda ) end if end if i = i + 1 @@ -68985,7 +68986,7 @@ module stdlib_linalg_lapack_q ip = ipiv( i ) if ( i>1 ) then if( ip/=i ) then - call stdlib_qswap( i-1, a( ip, 1 ), lda,a( i, 1 ), lda ) + call stdlib_${ri}$swap( i-1, a( ip, 1 ), lda,a( i, 1 ), lda ) end if end if else @@ -68997,10 +68998,10 @@ module stdlib_linalg_lapack_q ip2 = -ipiv( i+1 ) if ( i>1 ) then if( ip2/=(i+1) ) then - call stdlib_qswap( i-1, a( ip2, 1 ), lda,a( i+1, 1 ), lda ) + call stdlib_${ri}$swap( i-1, a( ip2, 1 ), lda,a( i+1, 1 ), lda ) end if if( ip/=i ) then - call stdlib_qswap( i-1, a( ip, 1 ), lda,a( i, 1 ), lda ) + call stdlib_${ri}$swap( i-1, a( ip, 1 ), lda,a( i, 1 ), lda ) end if end if end if @@ -69021,10 +69022,10 @@ module stdlib_linalg_lapack_q ! end a is lower end if return - end subroutine stdlib_qsyconvf_rook + end subroutine stdlib_${ri}$syconvf_rook - pure subroutine stdlib_qsyequb( uplo, n, a, lda, s, scond, amax, work, info ) + pure subroutine stdlib_${ri}$syequb( uplo, n, a, lda, s, scond, amax, work, info ) !! DSYEQUB: computes row and column scalings intended to equilibrate a !! symmetric matrix A (with respect to the Euclidean norm) and reduce !! its condition number. The scale factors S are computed by the BIN @@ -69038,11 +69039,11 @@ module stdlib_linalg_lapack_q ! Scalar Arguments integer(ilp), intent(out) :: info integer(ilp), intent(in) :: lda, n - real(qp), intent(out) :: amax, scond + real(${rk}$), intent(out) :: amax, scond character, intent(in) :: uplo ! Array Arguments - real(qp), intent(in) :: a(lda,*) - real(qp), intent(out) :: s(*), work(*) + real(${rk}$), intent(in) :: a(lda,*) + real(${rk}$), intent(out) :: s(*), work(*) ! ===================================================================== ! Parameters integer(ilp), parameter :: max_iter = 100 @@ -69050,7 +69051,7 @@ module stdlib_linalg_lapack_q ! Local Scalars integer(ilp) :: i, j, iter - real(qp) :: avg, std, tol, c0, c1, c2, t, u, si, d, base, smin, smax, smlnum, bignum, & + real(${rk}$) :: avg, std, tol, c0, c1, c2, t, u, si, d, base, smin, smax, smlnum, bignum, & scale, sumsq logical(lk) :: up ! Intrinsic Functions @@ -69102,9 +69103,9 @@ module stdlib_linalg_lapack_q end do end if do j = 1, n - s( j ) = 1.0_qp / s( j ) + s( j ) = 1.0_${rk}$ / s( j ) end do - tol = one / sqrt( 2.0_qp * n ) + tol = one / sqrt( 2.0_${rk}$ * n ) do iter = 1, max_iter scale = zero sumsq = zero @@ -69139,7 +69140,7 @@ module stdlib_linalg_lapack_q do i = n+1, 2*n work( i ) = s( i-n ) * work( i-n ) - avg end do - call stdlib_qlassq( n, work( n+1 ), 1, scale, sumsq ) + call stdlib_${ri}$lassq( n, work( n+1 ), 1, scale, sumsq ) std = scale * sqrt( sumsq / n ) if ( std < tol * avg ) goto 999 do i = 1, n @@ -69184,12 +69185,12 @@ module stdlib_linalg_lapack_q end do end do 999 continue - smlnum = stdlib_qlamch( 'SAFEMIN' ) + smlnum = stdlib_${ri}$lamch( 'SAFEMIN' ) bignum = one / smlnum smin = bignum smax = zero t = one / sqrt( avg ) - base = stdlib_qlamch( 'B' ) + base = stdlib_${ri}$lamch( 'B' ) u = one / log( base ) do i = 1, n s( i ) = base ** int( u * log( s( i ) * t ),KIND=ilp) @@ -69197,10 +69198,10 @@ module stdlib_linalg_lapack_q smax = max( smax, s( i ) ) end do scond = max( smin, smlnum ) / min( smax, bignum ) - end subroutine stdlib_qsyequb + end subroutine stdlib_${ri}$syequb - subroutine stdlib_qsyev( jobz, uplo, n, a, lda, w, work, lwork, info ) + subroutine stdlib_${ri}$syev( jobz, uplo, n, a, lda, w, work, lwork, info ) !! DSYEV: computes all eigenvalues and, optionally, eigenvectors of a !! real symmetric matrix A. ! -- lapack driver routine -- @@ -69211,14 +69212,14 @@ module stdlib_linalg_lapack_q integer(ilp), intent(out) :: info integer(ilp), intent(in) :: lda, lwork, n ! Array Arguments - real(qp), intent(inout) :: a(lda,*) - real(qp), intent(out) :: w(*), work(*) + real(${rk}$), intent(inout) :: a(lda,*) + real(${rk}$), intent(out) :: w(*), work(*) ! ===================================================================== ! Local Scalars logical(lk) :: lower, lquery, wantz integer(ilp) :: iinfo, imax, inde, indtau, indwrk, iscale, llwork, lwkopt, nb - real(qp) :: anrm, bignum, eps, rmax, rmin, safmin, sigma, smlnum + real(${rk}$) :: anrm, bignum, eps, rmax, rmin, safmin, sigma, smlnum ! Intrinsic Functions intrinsic :: max,sqrt ! Executable Statements @@ -69259,14 +69260,14 @@ module stdlib_linalg_lapack_q return end if ! get machine constants. - safmin = stdlib_qlamch( 'SAFE MINIMUM' ) - eps = stdlib_qlamch( 'PRECISION' ) + safmin = stdlib_${ri}$lamch( 'SAFE MINIMUM' ) + eps = stdlib_${ri}$lamch( 'PRECISION' ) smlnum = safmin / eps bignum = one / smlnum rmin = sqrt( smlnum ) rmax = sqrt( bignum ) ! scale matrix to allowable range, if necessary. - anrm = stdlib_qlansy( 'M', uplo, n, a, lda, work ) + anrm = stdlib_${ri}$lansy( 'M', uplo, n, a, lda, work ) iscale = 0 if( anrm>zero .and. anrmzero .and. anrmzero .and. anrm0 )abstll = abstol*sigma @@ -69635,97 +69636,97 @@ module stdlib_linalg_lapack_q end if end if ! initialize indices into workspaces. note: the iwork indices are - ! used only if stdlib_qsterf or stdlib_qstemr fail. + ! used only if stdlib_${ri}$sterf or stdlib_${ri}$stemr fail. ! work(indtau:indtau+n-1) stores the scalar factors of the - ! elementary reflectors used in stdlib_qsytrd. + ! elementary reflectors used in stdlib_${ri}$sytrd. indtau = 1 ! work(indd:indd+n-1) stores the tridiagonal's diagonal entries. indd = indtau + n ! work(inde:inde+n-1) stores the off-diagonal entries of the - ! tridiagonal matrix from stdlib_qsytrd. + ! tridiagonal matrix from stdlib_${ri}$sytrd. inde = indd + n ! work(inddd:inddd+n-1) is a copy of the diagonal entries over - ! -written by stdlib_qstemr (the stdlib_qsterf path copies the diagonal to w). + ! -written by stdlib_${ri}$stemr (the stdlib_${ri}$sterf path copies the diagonal to w). inddd = inde + n ! work(indee:indee+n-1) is a copy of the off-diagonal entries over - ! -written while computing the eigenvalues in stdlib_qsterf and stdlib_qstemr. + ! -written while computing the eigenvalues in stdlib_${ri}$sterf and stdlib_${ri}$stemr. indee = inddd + n ! indwk is the starting offset of the left-over workspace, and ! llwork is the remaining workspace size. indwk = indee + n llwork = lwork - indwk + 1 - ! iwork(indibl:indibl+m-1) corresponds to iblock in stdlib_qstebz and + ! iwork(indibl:indibl+m-1) corresponds to iblock in stdlib_${ri}$stebz and ! stores the block indices of each of the m<=n eigenvalues. indibl = 1 - ! iwork(indisp:indisp+nsplit-1) corresponds to isplit in stdlib_qstebz and + ! iwork(indisp:indisp+nsplit-1) corresponds to isplit in stdlib_${ri}$stebz and ! stores the starting and finishing indices of each block. indisp = indibl + n ! iwork(indifl:indifl+n-1) stores the indices of eigenvectors ! that corresponding to eigenvectors that fail to converge in - ! stdlib_qstein. this information is discarded; if any fail, the driver + ! stdlib_${ri}$stein. this information is discarded; if any fail, the driver ! returns info > 0. indifl = indisp + n ! indiwo is the offset of the remaining integer workspace. indiwo = indifl + n - ! call stdlib_qsytrd to reduce symmetric matrix to tridiagonal form. - call stdlib_qsytrd( uplo, n, a, lda, work( indd ), work( inde ),work( indtau ), work( & + ! call stdlib_${ri}$sytrd to reduce symmetric matrix to tridiagonal form. + call stdlib_${ri}$sytrd( uplo, n, a, lda, work( indd ), work( inde ),work( indtau ), work( & indwk ), llwork, iinfo ) ! if all eigenvalues are desired - ! then call stdlib_qsterf or stdlib_qstemr and stdlib_qormtr. + ! then call stdlib_${ri}$sterf or stdlib_${ri}$stemr and stdlib_${ri}$ormtr. if( ( alleig .or. ( indeig .and. il==1 .and. iu==n ) ) .and.ieeeok==1 ) then if( .not.wantz ) then - call stdlib_qcopy( n, work( indd ), 1, w, 1 ) - call stdlib_qcopy( n-1, work( inde ), 1, work( indee ), 1 ) - call stdlib_qsterf( n, w, work( indee ), info ) + call stdlib_${ri}$copy( n, work( indd ), 1, w, 1 ) + call stdlib_${ri}$copy( n-1, work( inde ), 1, work( indee ), 1 ) + call stdlib_${ri}$sterf( n, w, work( indee ), info ) else - call stdlib_qcopy( n-1, work( inde ), 1, work( indee ), 1 ) - call stdlib_qcopy( n, work( indd ), 1, work( inddd ), 1 ) + call stdlib_${ri}$copy( n-1, work( inde ), 1, work( indee ), 1 ) + call stdlib_${ri}$copy( n, work( indd ), 1, work( inddd ), 1 ) if (abstol <= two*n*eps) then tryrac = .true. else tryrac = .false. end if - call stdlib_qstemr( jobz, 'A', n, work( inddd ), work( indee ),vl, vu, il, iu, m,& + call stdlib_${ri}$stemr( jobz, 'A', n, work( inddd ), work( indee ),vl, vu, il, iu, m,& w, z, ldz, n, isuppz,tryrac, work( indwk ), lwork, iwork, liwork,info ) ! apply orthogonal matrix used in reduction to tridiagonal - ! form to eigenvectors returned by stdlib_qstemr. + ! form to eigenvectors returned by stdlib_${ri}$stemr. if( wantz .and. info==0 ) then indwkn = inde llwrkn = lwork - indwkn + 1 - call stdlib_qormtr( 'L', uplo, 'N', n, m, a, lda,work( indtau ), z, ldz, work(& + call stdlib_${ri}$ormtr( 'L', uplo, 'N', n, m, a, lda,work( indtau ), z, ldz, work(& indwkn ),llwrkn, iinfo ) end if end if if( info==0 ) then - ! everything worked. skip stdlib_qstebz/stdlib_qstein. iwork(:) are + ! everything worked. skip stdlib_${ri}$stebz/stdlib_${ri}$stein. iwork(:) are ! undefined. m = n go to 30 end if info = 0 end if - ! otherwise, call stdlib_qstebz and, if eigenvectors are desired, stdlib_qstein. - ! also call stdlib_qstebz and stdlib_qstein if stdlib_qstemr fails. + ! otherwise, call stdlib_${ri}$stebz and, if eigenvectors are desired, stdlib_${ri}$stein. + ! also call stdlib_${ri}$stebz and stdlib_${ri}$stein if stdlib_${ri}$stemr fails. if( wantz ) then order = 'B' else order = 'E' end if - call stdlib_qstebz( range, order, n, vll, vuu, il, iu, abstll,work( indd ), work( inde & + call stdlib_${ri}$stebz( range, order, n, vll, vuu, il, iu, abstll,work( indd ), work( inde & ), m, nsplit, w,iwork( indibl ), iwork( indisp ), work( indwk ),iwork( indiwo ), info ) if( wantz ) then - call stdlib_qstein( n, work( indd ), work( inde ), m, w,iwork( indibl ), iwork( & + call stdlib_${ri}$stein( n, work( indd ), work( inde ), m, w,iwork( indibl ), iwork( & indisp ), z, ldz,work( indwk ), iwork( indiwo ), iwork( indifl ),info ) ! apply orthogonal matrix used in reduction to tridiagonal - ! form to eigenvectors returned by stdlib_qstein. + ! form to eigenvectors returned by stdlib_${ri}$stein. indwkn = inde llwrkn = lwork - indwkn + 1 - call stdlib_qormtr( 'L', uplo, 'N', n, m, a, lda, work( indtau ), z,ldz, work( & + call stdlib_${ri}$ormtr( 'L', uplo, 'N', n, m, a, lda, work( indtau ), z,ldz, work( & indwkn ), llwrkn, iinfo ) end if ! if matrix was scaled, then rescale eigenvalues appropriately. - ! jump here if stdlib_qstemr/stdlib_qstein succeeded. + ! jump here if stdlib_${ri}$stemr/stdlib_${ri}$stein succeeded. 30 continue if( iscale==1 ) then if( info==0 ) then @@ -69733,11 +69734,11 @@ module stdlib_linalg_lapack_q else imax = info - 1 end if - call stdlib_qscal( imax, one / sigma, w, 1 ) + call stdlib_${ri}$scal( imax, one / sigma, w, 1 ) end if ! if eigenvalues are not in order, then sort them, along with ! eigenvectors. note: we do not sort the ifail portion of iwork. - ! it may not be initialized (if stdlib_qstemr/stdlib_qstein succeeded), and we do + ! it may not be initialized (if stdlib_${ri}$stemr/stdlib_${ri}$stein succeeded), and we do ! not return this detailed information to the user. if( wantz ) then do j = 1, m - 1 @@ -69752,7 +69753,7 @@ module stdlib_linalg_lapack_q if( i/=0 ) then w( i ) = w( j ) w( j ) = tmp1 - call stdlib_qswap( n, z( 1, i ), 1, z( 1, j ), 1 ) + call stdlib_${ri}$swap( n, z( 1, i ), 1, z( 1, j ), 1 ) end if end do end if @@ -69760,10 +69761,10 @@ module stdlib_linalg_lapack_q work( 1 ) = lwkopt iwork( 1 ) = liwmin return - end subroutine stdlib_qsyevr + end subroutine stdlib_${ri}$syevr - subroutine stdlib_qsyevx( jobz, range, uplo, n, a, lda, vl, vu, il, iu,abstol, m, w, z, ldz, & + subroutine stdlib_${ri}$syevx( jobz, range, uplo, n, a, lda, vl, vu, il, iu,abstol, m, w, z, ldz, & !! DSYEVX: computes selected eigenvalues and, optionally, eigenvectors !! of a real symmetric matrix A. Eigenvalues and eigenvectors can be !! selected by specifying either a range of values or a range of indices @@ -69776,11 +69777,11 @@ module stdlib_linalg_lapack_q character, intent(in) :: jobz, range, uplo integer(ilp), intent(in) :: il, iu, lda, ldz, lwork, n integer(ilp), intent(out) :: info, m - real(qp), intent(in) :: abstol, vl, vu + real(${rk}$), intent(in) :: abstol, vl, vu ! Array Arguments integer(ilp), intent(out) :: ifail(*), iwork(*) - real(qp), intent(inout) :: a(lda,*) - real(qp), intent(out) :: w(*), work(*), z(ldz,*) + real(${rk}$), intent(inout) :: a(lda,*) + real(${rk}$), intent(out) :: w(*), work(*), z(ldz,*) ! ===================================================================== ! Local Scalars @@ -69789,7 +69790,7 @@ module stdlib_linalg_lapack_q integer(ilp) :: i, iinfo, imax, indd, inde, indee, indibl, indisp, indiwo, indtau, & indwkn, indwrk, iscale, itmp1, j, jj, llwork, llwrkn, lwkmin, lwkopt, nb, & nsplit - real(qp) :: abstll, anrm, bignum, eps, rmax, rmin, safmin, sigma, smlnum, tmp1, vll, & + real(${rk}$) :: abstll, anrm, bignum, eps, rmax, rmin, safmin, sigma, smlnum, tmp1, vll, & vuu ! Intrinsic Functions intrinsic :: max,min,sqrt @@ -69866,8 +69867,8 @@ module stdlib_linalg_lapack_q return end if ! get machine constants. - safmin = stdlib_qlamch( 'SAFE MINIMUM' ) - eps = stdlib_qlamch( 'PRECISION' ) + safmin = stdlib_${ri}$lamch( 'SAFE MINIMUM' ) + eps = stdlib_${ri}$lamch( 'PRECISION' ) smlnum = safmin / eps bignum = one / smlnum rmin = sqrt( smlnum ) @@ -69879,7 +69880,7 @@ module stdlib_linalg_lapack_q vll = vl vuu = vu end if - anrm = stdlib_qlansy( 'M', uplo, n, a, lda, work ) + anrm = stdlib_${ri}$lansy( 'M', uplo, n, a, lda, work ) if( anrm>zero .and. anrm0 )abstll = abstol*sigma @@ -69903,17 +69904,17 @@ module stdlib_linalg_lapack_q vuu = vu*sigma end if end if - ! call stdlib_qsytrd to reduce symmetric matrix to tridiagonal form. + ! call stdlib_${ri}$sytrd to reduce symmetric matrix to tridiagonal form. indtau = 1 inde = indtau + n indd = inde + n indwrk = indd + n llwork = lwork - indwrk + 1 - call stdlib_qsytrd( uplo, n, a, lda, work( indd ), work( inde ),work( indtau ), work( & + call stdlib_${ri}$sytrd( uplo, n, a, lda, work( indd ), work( inde ),work( indtau ), work( & indwrk ), llwork, iinfo ) ! if all eigenvalues are desired and abstol is less than or equal to - ! zero, then call stdlib_qsterf or stdlib_qorgtr and stdlib_dsteqr. if this fails for - ! some eigenvalue, then try stdlib_qstebz. + ! zero, then call stdlib_${ri}$sterf or stdlib_${ri}$orgtr and stdlib_dsteqr. if this fails for + ! some eigenvalue, then try stdlib_${ri}$stebz. test = .false. if( indeig ) then if( il==1 .and. iu==n ) then @@ -69921,17 +69922,17 @@ module stdlib_linalg_lapack_q end if end if if( ( alleig .or. test ) .and. ( abstol<=zero ) ) then - call stdlib_qcopy( n, work( indd ), 1, w, 1 ) + call stdlib_${ri}$copy( n, work( indd ), 1, w, 1 ) indee = indwrk + 2*n if( .not.wantz ) then - call stdlib_qcopy( n-1, work( inde ), 1, work( indee ), 1 ) - call stdlib_qsterf( n, w, work( indee ), info ) + call stdlib_${ri}$copy( n-1, work( inde ), 1, work( indee ), 1 ) + call stdlib_${ri}$sterf( n, w, work( indee ), info ) else - call stdlib_qlacpy( 'A', n, n, a, lda, z, ldz ) - call stdlib_qorgtr( uplo, n, z, ldz, work( indtau ),work( indwrk ), llwork, & + call stdlib_${ri}$lacpy( 'A', n, n, a, lda, z, ldz ) + call stdlib_${ri}$orgtr( uplo, n, z, ldz, work( indtau ),work( indwrk ), llwork, & iinfo ) - call stdlib_qcopy( n-1, work( inde ), 1, work( indee ), 1 ) - call stdlib_qsteqr( jobz, n, w, work( indee ), z, ldz,work( indwrk ), info ) + call stdlib_${ri}$copy( n-1, work( inde ), 1, work( indee ), 1 ) + call stdlib_${ri}$steqr( jobz, n, w, work( indee ), z, ldz,work( indwrk ), info ) if( info==0 ) then do i = 1, n @@ -69945,7 +69946,7 @@ module stdlib_linalg_lapack_q end if info = 0 end if - ! otherwise, call stdlib_qstebz and, if eigenvectors are desired, stdlib_dstein. + ! otherwise, call stdlib_${ri}$stebz and, if eigenvectors are desired, stdlib_dstein. if( wantz ) then order = 'B' else @@ -69954,17 +69955,17 @@ module stdlib_linalg_lapack_q indibl = 1 indisp = indibl + n indiwo = indisp + n - call stdlib_qstebz( range, order, n, vll, vuu, il, iu, abstll,work( indd ), work( inde & + call stdlib_${ri}$stebz( range, order, n, vll, vuu, il, iu, abstll,work( indd ), work( inde & ), m, nsplit, w,iwork( indibl ), iwork( indisp ), work( indwrk ),iwork( indiwo ), info & ) if( wantz ) then - call stdlib_qstein( n, work( indd ), work( inde ), m, w,iwork( indibl ), iwork( & + call stdlib_${ri}$stein( n, work( indd ), work( inde ), m, w,iwork( indibl ), iwork( & indisp ), z, ldz,work( indwrk ), iwork( indiwo ), ifail, info ) ! apply orthogonal matrix used in reduction to tridiagonal - ! form to eigenvectors returned by stdlib_qstein. + ! form to eigenvectors returned by stdlib_${ri}$stein. indwkn = inde llwrkn = lwork - indwkn + 1 - call stdlib_qormtr( 'L', uplo, 'N', n, m, a, lda, work( indtau ), z,ldz, work( & + call stdlib_${ri}$ormtr( 'L', uplo, 'N', n, m, a, lda, work( indtau ), z,ldz, work( & indwkn ), llwrkn, iinfo ) end if ! if matrix was scaled, then rescale eigenvalues appropriately. @@ -69975,7 +69976,7 @@ module stdlib_linalg_lapack_q else imax = info - 1 end if - call stdlib_qscal( imax, one / sigma, w, 1 ) + call stdlib_${ri}$scal( imax, one / sigma, w, 1 ) end if ! if eigenvalues are not in order, then sort them, along with ! eigenvectors. @@ -69995,7 +69996,7 @@ module stdlib_linalg_lapack_q iwork( indibl+i-1 ) = iwork( indibl+j-1 ) w( j ) = tmp1 iwork( indibl+j-1 ) = itmp1 - call stdlib_qswap( n, z( 1, i ), 1, z( 1, j ), 1 ) + call stdlib_${ri}$swap( n, z( 1, i ), 1, z( 1, j ), 1 ) if( info/=0 ) then itmp1 = ifail( i ) ifail( i ) = ifail( j ) @@ -70007,10 +70008,10 @@ module stdlib_linalg_lapack_q ! set work(1) to optimal workspace size. work( 1 ) = lwkopt return - end subroutine stdlib_qsyevx + end subroutine stdlib_${ri}$syevx - pure subroutine stdlib_qsygs2( itype, uplo, n, a, lda, b, ldb, info ) + pure subroutine stdlib_${ri}$sygs2( itype, uplo, n, a, lda, b, ldb, info ) !! DSYGS2: reduces a real symmetric-definite generalized eigenproblem !! to standard form. !! If ITYPE = 1, the problem is A*x = lambda*B*x, @@ -70026,14 +70027,14 @@ module stdlib_linalg_lapack_q integer(ilp), intent(out) :: info integer(ilp), intent(in) :: itype, lda, ldb, n ! Array Arguments - real(qp), intent(inout) :: a(lda,*) - real(qp), intent(in) :: b(ldb,*) + real(${rk}$), intent(inout) :: a(lda,*) + real(${rk}$), intent(in) :: b(ldb,*) ! ===================================================================== ! Local Scalars logical(lk) :: upper integer(ilp) :: k - real(qp) :: akk, bkk, ct + real(${rk}$) :: akk, bkk, ct ! Intrinsic Functions intrinsic :: max ! Executable Statements @@ -70065,13 +70066,13 @@ module stdlib_linalg_lapack_q akk = akk / bkk**2 a( k, k ) = akk if( k=n ) then ! use unblocked code - call stdlib_qsygs2( itype, uplo, n, a, lda, b, ldb, info ) + call stdlib_${ri}$sygs2( itype, uplo, n, a, lda, b, ldb, info ) else ! use blocked code if( itype==1 ) then @@ -70192,18 +70193,18 @@ module stdlib_linalg_lapack_q do k = 1, n, nb kb = min( n-k+1, nb ) ! update the upper triangle of a(k:n,k:n) - call stdlib_qsygs2( itype, uplo, kb, a( k, k ), lda,b( k, k ), ldb, info ) + call stdlib_${ri}$sygs2( itype, uplo, kb, a( k, k ), lda,b( k, k ), ldb, info ) if( k+kb<=n ) then - call stdlib_qtrsm( 'LEFT', uplo, 'TRANSPOSE', 'NON-UNIT',kb, n-k-kb+1, & + call stdlib_${ri}$trsm( 'LEFT', uplo, 'TRANSPOSE', 'NON-UNIT',kb, n-k-kb+1, & one, b( k, k ), ldb,a( k, k+kb ), lda ) - call stdlib_qsymm( 'LEFT', uplo, kb, n-k-kb+1, -half,a( k, k ), lda, b( & + call stdlib_${ri}$symm( 'LEFT', uplo, kb, n-k-kb+1, -half,a( k, k ), lda, b( & k, k+kb ), ldb, one,a( k, k+kb ), lda ) - call stdlib_qsyr2k( uplo, 'TRANSPOSE', n-k-kb+1, kb, -one,a( k, k+kb ), & + call stdlib_${ri}$syr2k( uplo, 'TRANSPOSE', n-k-kb+1, kb, -one,a( k, k+kb ), & lda, b( k, k+kb ), ldb,one, a( k+kb, k+kb ), lda ) - call stdlib_qsymm( 'LEFT', uplo, kb, n-k-kb+1, -half,a( k, k ), lda, b( & + call stdlib_${ri}$symm( 'LEFT', uplo, kb, n-k-kb+1, -half,a( k, k ), lda, b( & k, k+kb ), ldb, one,a( k, k+kb ), lda ) - call stdlib_qtrsm( 'RIGHT', uplo, 'NO TRANSPOSE','NON-UNIT', kb, n-k-kb+& + call stdlib_${ri}$trsm( 'RIGHT', uplo, 'NO TRANSPOSE','NON-UNIT', kb, n-k-kb+& 1, one,b( k+kb, k+kb ), ldb, a( k, k+kb ),lda ) end if end do @@ -70212,18 +70213,18 @@ module stdlib_linalg_lapack_q do k = 1, n, nb kb = min( n-k+1, nb ) ! update the lower triangle of a(k:n,k:n) - call stdlib_qsygs2( itype, uplo, kb, a( k, k ), lda,b( k, k ), ldb, info ) + call stdlib_${ri}$sygs2( itype, uplo, kb, a( k, k ), lda,b( k, k ), ldb, info ) if( k+kb<=n ) then - call stdlib_qtrsm( 'RIGHT', uplo, 'TRANSPOSE', 'NON-UNIT',n-k-kb+1, kb, & + call stdlib_${ri}$trsm( 'RIGHT', uplo, 'TRANSPOSE', 'NON-UNIT',n-k-kb+1, kb, & one, b( k, k ), ldb,a( k+kb, k ), lda ) - call stdlib_qsymm( 'RIGHT', uplo, n-k-kb+1, kb, -half,a( k, k ), lda, b(& + call stdlib_${ri}$symm( 'RIGHT', uplo, n-k-kb+1, kb, -half,a( k, k ), lda, b(& k+kb, k ), ldb, one,a( k+kb, k ), lda ) - call stdlib_qsyr2k( uplo, 'NO TRANSPOSE', n-k-kb+1, kb,-one, a( k+kb, k & + call stdlib_${ri}$syr2k( uplo, 'NO TRANSPOSE', n-k-kb+1, kb,-one, a( k+kb, k & ), lda, b( k+kb, k ),ldb, one, a( k+kb, k+kb ), lda ) - call stdlib_qsymm( 'RIGHT', uplo, n-k-kb+1, kb, -half,a( k, k ), lda, b(& + call stdlib_${ri}$symm( 'RIGHT', uplo, n-k-kb+1, kb, -half,a( k, k ), lda, b(& k+kb, k ), ldb, one,a( k+kb, k ), lda ) - call stdlib_qtrsm( 'LEFT', uplo, 'NO TRANSPOSE','NON-UNIT', n-k-kb+1, & + call stdlib_${ri}$trsm( 'LEFT', uplo, 'NO TRANSPOSE','NON-UNIT', n-k-kb+1, & kb, one,b( k+kb, k+kb ), ldb, a( k+kb, k ),lda ) end if end do @@ -70234,17 +70235,17 @@ module stdlib_linalg_lapack_q do k = 1, n, nb kb = min( n-k+1, nb ) ! update the upper triangle of a(1:k+kb-1,1:k+kb-1) - call stdlib_qtrmm( 'LEFT', uplo, 'NO TRANSPOSE', 'NON-UNIT',k-1, kb, one, & + call stdlib_${ri}$trmm( 'LEFT', uplo, 'NO TRANSPOSE', 'NON-UNIT',k-1, kb, one, & b, ldb, a( 1, k ), lda ) - call stdlib_qsymm( 'RIGHT', uplo, k-1, kb, half, a( k, k ),lda, b( 1, k ), & + call stdlib_${ri}$symm( 'RIGHT', uplo, k-1, kb, half, a( k, k ),lda, b( 1, k ), & ldb, one, a( 1, k ), lda ) - call stdlib_qsyr2k( uplo, 'NO TRANSPOSE', k-1, kb, one,a( 1, k ), lda, b( & + call stdlib_${ri}$syr2k( uplo, 'NO TRANSPOSE', k-1, kb, one,a( 1, k ), lda, b( & 1, k ), ldb, one, a,lda ) - call stdlib_qsymm( 'RIGHT', uplo, k-1, kb, half, a( k, k ),lda, b( 1, k ), & + call stdlib_${ri}$symm( 'RIGHT', uplo, k-1, kb, half, a( k, k ),lda, b( 1, k ), & ldb, one, a( 1, k ), lda ) - call stdlib_qtrmm( 'RIGHT', uplo, 'TRANSPOSE', 'NON-UNIT',k-1, kb, one, b( & + call stdlib_${ri}$trmm( 'RIGHT', uplo, 'TRANSPOSE', 'NON-UNIT',k-1, kb, one, b( & k, k ), ldb, a( 1, k ),lda ) - call stdlib_qsygs2( itype, uplo, kb, a( k, k ), lda,b( k, k ), ldb, info ) + call stdlib_${ri}$sygs2( itype, uplo, kb, a( k, k ), lda,b( k, k ), ldb, info ) end do else @@ -70252,27 +70253,27 @@ module stdlib_linalg_lapack_q do k = 1, n, nb kb = min( n-k+1, nb ) ! update the lower triangle of a(1:k+kb-1,1:k+kb-1) - call stdlib_qtrmm( 'RIGHT', uplo, 'NO TRANSPOSE', 'NON-UNIT',kb, k-1, one, & + call stdlib_${ri}$trmm( 'RIGHT', uplo, 'NO TRANSPOSE', 'NON-UNIT',kb, k-1, one, & b, ldb, a( k, 1 ), lda ) - call stdlib_qsymm( 'LEFT', uplo, kb, k-1, half, a( k, k ),lda, b( k, 1 ), & + call stdlib_${ri}$symm( 'LEFT', uplo, kb, k-1, half, a( k, k ),lda, b( k, 1 ), & ldb, one, a( k, 1 ), lda ) - call stdlib_qsyr2k( uplo, 'TRANSPOSE', k-1, kb, one,a( k, 1 ), lda, b( k, & + call stdlib_${ri}$syr2k( uplo, 'TRANSPOSE', k-1, kb, one,a( k, 1 ), lda, b( k, & 1 ), ldb, one, a,lda ) - call stdlib_qsymm( 'LEFT', uplo, kb, k-1, half, a( k, k ),lda, b( k, 1 ), & + call stdlib_${ri}$symm( 'LEFT', uplo, kb, k-1, half, a( k, k ),lda, b( k, 1 ), & ldb, one, a( k, 1 ), lda ) - call stdlib_qtrmm( 'LEFT', uplo, 'TRANSPOSE', 'NON-UNIT', kb,k-1, one, b( & + call stdlib_${ri}$trmm( 'LEFT', uplo, 'TRANSPOSE', 'NON-UNIT', kb,k-1, one, b( & k, k ), ldb, a( k, 1 ), lda ) - call stdlib_qsygs2( itype, uplo, kb, a( k, k ), lda,b( k, k ), ldb, info ) + call stdlib_${ri}$sygs2( itype, uplo, kb, a( k, k ), lda,b( k, k ), ldb, info ) end do end if end if end if return - end subroutine stdlib_qsygst + end subroutine stdlib_${ri}$sygst - subroutine stdlib_qsygv( itype, jobz, uplo, n, a, lda, b, ldb, w, work,lwork, info ) + subroutine stdlib_${ri}$sygv( itype, jobz, uplo, n, a, lda, b, ldb, w, work,lwork, info ) !! DSYGV: computes all the eigenvalues, and optionally, the eigenvectors !! of a real generalized symmetric-definite eigenproblem, of the form !! A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. @@ -70286,8 +70287,8 @@ module stdlib_linalg_lapack_q integer(ilp), intent(out) :: info integer(ilp), intent(in) :: itype, lda, ldb, lwork, n ! Array Arguments - real(qp), intent(inout) :: a(lda,*), b(ldb,*) - real(qp), intent(out) :: w(*), work(*) + real(${rk}$), intent(inout) :: a(lda,*), b(ldb,*) + real(${rk}$), intent(out) :: w(*), work(*) ! ===================================================================== ! Local Scalars @@ -70333,14 +70334,14 @@ module stdlib_linalg_lapack_q ! quick return if possible if( n==0 )return ! form a cholesky factorization of b. - call stdlib_qpotrf( uplo, n, b, ldb, info ) + call stdlib_${ri}$potrf( uplo, n, b, ldb, info ) if( info/=0 ) then info = n + info return end if ! transform problem to standard eigenvalue problem and solve. - call stdlib_qsygst( itype, uplo, n, a, lda, b, ldb, info ) - call stdlib_qsyev( jobz, uplo, n, a, lda, w, work, lwork, info ) + call stdlib_${ri}$sygst( itype, uplo, n, a, lda, b, ldb, info ) + call stdlib_${ri}$syev( jobz, uplo, n, a, lda, w, work, lwork, info ) if( wantz ) then ! backtransform eigenvectors to the original problem. neig = n @@ -70353,7 +70354,7 @@ module stdlib_linalg_lapack_q else trans = 'T' end if - call stdlib_qtrsm( 'LEFT', uplo, trans, 'NON-UNIT', n, neig, one,b, ldb, a, lda ) + call stdlib_${ri}$trsm( 'LEFT', uplo, trans, 'NON-UNIT', n, neig, one,b, ldb, a, lda ) else if( itype==3 ) then ! for b*a*x=(lambda)*x; @@ -70363,16 +70364,16 @@ module stdlib_linalg_lapack_q else trans = 'N' end if - call stdlib_qtrmm( 'LEFT', uplo, trans, 'NON-UNIT', n, neig, one,b, ldb, a, lda ) + call stdlib_${ri}$trmm( 'LEFT', uplo, trans, 'NON-UNIT', n, neig, one,b, ldb, a, lda ) end if end if work( 1 ) = lwkopt return - end subroutine stdlib_qsygv + end subroutine stdlib_${ri}$sygv - subroutine stdlib_qsygvd( itype, jobz, uplo, n, a, lda, b, ldb, w, work,lwork, iwork, liwork,& + subroutine stdlib_${ri}$sygvd( itype, jobz, uplo, n, a, lda, b, ldb, w, work,lwork, iwork, liwork,& !! DSYGVD: computes all the eigenvalues, and optionally, the eigenvectors !! of a real generalized symmetric-definite eigenproblem, of the form !! A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A and @@ -70394,8 +70395,8 @@ module stdlib_linalg_lapack_q integer(ilp), intent(in) :: itype, lda, ldb, liwork, lwork, n ! Array Arguments integer(ilp), intent(out) :: iwork(*) - real(qp), intent(inout) :: a(lda,*), b(ldb,*) - real(qp), intent(out) :: w(*), work(*) + real(${rk}$), intent(inout) :: a(lda,*), b(ldb,*) + real(${rk}$), intent(out) :: w(*), work(*) ! ===================================================================== ! Local Scalars @@ -70453,16 +70454,16 @@ module stdlib_linalg_lapack_q ! quick return if possible if( n==0 )return ! form a cholesky factorization of b. - call stdlib_qpotrf( uplo, n, b, ldb, info ) + call stdlib_${ri}$potrf( uplo, n, b, ldb, info ) if( info/=0 ) then info = n + info return end if ! transform problem to standard eigenvalue problem and solve. - call stdlib_qsygst( itype, uplo, n, a, lda, b, ldb, info ) - call stdlib_qsyevd( jobz, uplo, n, a, lda, w, work, lwork, iwork, liwork,info ) - lopt = max( real( lopt,KIND=qp), real( work( 1 ),KIND=qp) ) - liopt = max( real( liopt,KIND=qp), real( iwork( 1 ),KIND=qp) ) + call stdlib_${ri}$sygst( itype, uplo, n, a, lda, b, ldb, info ) + call stdlib_${ri}$syevd( jobz, uplo, n, a, lda, w, work, lwork, iwork, liwork,info ) + lopt = max( real( lopt,KIND=${rk}$), real( work( 1 ),KIND=${rk}$) ) + liopt = max( real( liopt,KIND=${rk}$), real( iwork( 1 ),KIND=${rk}$) ) if( wantz .and. info==0 ) then ! backtransform eigenvectors to the original problem. if( itype==1 .or. itype==2 ) then @@ -70473,7 +70474,7 @@ module stdlib_linalg_lapack_q else trans = 'T' end if - call stdlib_qtrsm( 'LEFT', uplo, trans, 'NON-UNIT', n, n, one,b, ldb, a, lda ) + call stdlib_${ri}$trsm( 'LEFT', uplo, trans, 'NON-UNIT', n, n, one,b, ldb, a, lda ) else if( itype==3 ) then ! for b*a*x=(lambda)*x; @@ -70483,17 +70484,17 @@ module stdlib_linalg_lapack_q else trans = 'N' end if - call stdlib_qtrmm( 'LEFT', uplo, trans, 'NON-UNIT', n, n, one,b, ldb, a, lda ) + call stdlib_${ri}$trmm( 'LEFT', uplo, trans, 'NON-UNIT', n, n, one,b, ldb, a, lda ) end if end if work( 1 ) = lopt iwork( 1 ) = liopt return - end subroutine stdlib_qsygvd + end subroutine stdlib_${ri}$sygvd - subroutine stdlib_qsygvx( itype, jobz, range, uplo, n, a, lda, b, ldb,vl, vu, il, iu, abstol,& + subroutine stdlib_${ri}$sygvx( itype, jobz, range, uplo, n, a, lda, b, ldb,vl, vu, il, iu, abstol,& !! DSYGVX: computes selected eigenvalues, and optionally, eigenvectors !! of a real generalized symmetric-definite eigenproblem, of the form !! A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A @@ -70508,11 +70509,11 @@ module stdlib_linalg_lapack_q character, intent(in) :: jobz, range, uplo integer(ilp), intent(in) :: il, itype, iu, lda, ldb, ldz, lwork, n integer(ilp), intent(out) :: info, m - real(qp), intent(in) :: abstol, vl, vu + real(${rk}$), intent(in) :: abstol, vl, vu ! Array Arguments integer(ilp), intent(out) :: ifail(*), iwork(*) - real(qp), intent(inout) :: a(lda,*), b(ldb,*) - real(qp), intent(out) :: w(*), work(*), z(ldz,*) + real(${rk}$), intent(inout) :: a(lda,*), b(ldb,*) + real(${rk}$), intent(out) :: w(*), work(*), z(ldz,*) ! ===================================================================== ! Local Scalars @@ -70581,14 +70582,14 @@ module stdlib_linalg_lapack_q return end if ! form a cholesky factorization of b. - call stdlib_qpotrf( uplo, n, b, ldb, info ) + call stdlib_${ri}$potrf( uplo, n, b, ldb, info ) if( info/=0 ) then info = n + info return end if ! transform problem to standard eigenvalue problem and solve. - call stdlib_qsygst( itype, uplo, n, a, lda, b, ldb, info ) - call stdlib_qsyevx( jobz, range, uplo, n, a, lda, vl, vu, il, iu, abstol,m, w, z, ldz, & + call stdlib_${ri}$sygst( itype, uplo, n, a, lda, b, ldb, info ) + call stdlib_${ri}$syevx( jobz, range, uplo, n, a, lda, vl, vu, il, iu, abstol,m, w, z, ldz, & work, lwork, iwork, ifail, info ) if( wantz ) then ! backtransform eigenvectors to the original problem. @@ -70601,7 +70602,7 @@ module stdlib_linalg_lapack_q else trans = 'T' end if - call stdlib_qtrsm( 'LEFT', uplo, trans, 'NON-UNIT', n, m, one, b,ldb, z, ldz ) + call stdlib_${ri}$trsm( 'LEFT', uplo, trans, 'NON-UNIT', n, m, one, b,ldb, z, ldz ) else if( itype==3 ) then ! for b*a*x=(lambda)*x; @@ -70611,17 +70612,17 @@ module stdlib_linalg_lapack_q else trans = 'N' end if - call stdlib_qtrmm( 'LEFT', uplo, trans, 'NON-UNIT', n, m, one, b,ldb, z, ldz ) + call stdlib_${ri}$trmm( 'LEFT', uplo, trans, 'NON-UNIT', n, m, one, b,ldb, z, ldz ) end if end if ! set work(1) to optimal workspace size. work( 1 ) = lwkopt return - end subroutine stdlib_qsygvx + end subroutine stdlib_${ri}$sygvx - pure subroutine stdlib_qsyrfs( uplo, n, nrhs, a, lda, af, ldaf, ipiv, b, ldb,x, ldx, ferr, & + pure subroutine stdlib_${ri}$syrfs( uplo, n, nrhs, a, lda, af, ldaf, ipiv, b, ldb,x, ldx, ferr, & !! DSYRFS: improves the computed solution to a system of linear !! equations when the coefficient matrix is symmetric indefinite, and !! provides error bounds and backward error estimates for the solution. @@ -70636,9 +70637,9 @@ module stdlib_linalg_lapack_q ! Array Arguments integer(ilp), intent(in) :: ipiv(*) integer(ilp), intent(out) :: iwork(*) - real(qp), intent(in) :: a(lda,*), af(ldaf,*), b(ldb,*) - real(qp), intent(out) :: berr(*), ferr(*), work(*) - real(qp), intent(inout) :: x(ldx,*) + real(${rk}$), intent(in) :: a(lda,*), af(ldaf,*), b(ldb,*) + real(${rk}$), intent(out) :: berr(*), ferr(*), work(*) + real(${rk}$), intent(inout) :: x(ldx,*) ! ===================================================================== ! Parameters integer(ilp), parameter :: itmax = 5 @@ -70650,7 +70651,7 @@ module stdlib_linalg_lapack_q ! Local Scalars logical(lk) :: upper integer(ilp) :: count, i, j, k, kase, nz - real(qp) :: eps, lstres, s, safe1, safe2, safmin, xk + real(${rk}$) :: eps, lstres, s, safe1, safe2, safmin, xk ! Local Arrays integer(ilp) :: isave(3) ! Intrinsic Functions @@ -70688,8 +70689,8 @@ module stdlib_linalg_lapack_q end if ! nz = maximum number of nonzero elements in each row of a, plus 1 nz = n + 1 - eps = stdlib_qlamch( 'EPSILON' ) - safmin = stdlib_qlamch( 'SAFE MINIMUM' ) + eps = stdlib_${ri}$lamch( 'EPSILON' ) + safmin = stdlib_${ri}$lamch( 'SAFE MINIMUM' ) safe1 = nz*safmin safe2 = safe1 / eps ! do for each right hand side @@ -70699,8 +70700,8 @@ module stdlib_linalg_lapack_q 20 continue ! loop until stopping criterion is satisfied. ! compute residual r = b - a * x - call stdlib_qcopy( n, b( 1, j ), 1, work( n+1 ), 1 ) - call stdlib_qsymv( uplo, n, -one, a, lda, x( 1, j ), 1, one,work( n+1 ), 1 ) + call stdlib_${ri}$copy( n, b( 1, j ), 1, work( n+1 ), 1 ) + call stdlib_${ri}$symv( uplo, n, -one, a, lda, x( 1, j ), 1, one,work( n+1 ), 1 ) ! 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 @@ -70749,8 +70750,8 @@ module stdlib_linalg_lapack_q ! 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_qsytrs( uplo, n, 1, af, ldaf, ipiv, work( n+1 ), n,info ) - call stdlib_qaxpy( n, one, work( n+1 ), 1, x( 1, j ), 1 ) + call stdlib_${ri}$sytrs( uplo, n, 1, af, ldaf, ipiv, work( n+1 ), n,info ) + call stdlib_${ri}$axpy( n, one, work( n+1 ), 1, x( 1, j ), 1 ) lstres = berr( j ) count = count + 1 go to 20 @@ -70769,7 +70770,7 @@ module stdlib_linalg_lapack_q ! 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_qlacn2 to estimate the infinity-norm of the matrix + ! 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 @@ -70781,12 +70782,12 @@ module stdlib_linalg_lapack_q end do kase = 0 100 continue - call stdlib_qlacn2( n, work( 2*n+1 ), work( n+1 ), iwork, ferr( j ),kase, isave ) + call stdlib_${ri}$lacn2( n, work( 2*n+1 ), work( n+1 ), iwork, ferr( j ),kase, isave ) if( kase/=0 ) then if( kase==1 ) then ! multiply by diag(w)*inv(a**t). - call stdlib_qsytrs( uplo, n, 1, af, ldaf, ipiv, work( n+1 ), n,info ) + call stdlib_${ri}$sytrs( uplo, n, 1, af, ldaf, ipiv, work( n+1 ), n,info ) do i = 1, n work( n+i ) = work( i )*work( n+i ) end do @@ -70795,7 +70796,7 @@ module stdlib_linalg_lapack_q do i = 1, n work( n+i ) = work( i )*work( n+i ) end do - call stdlib_qsytrs( uplo, n, 1, af, ldaf, ipiv, work( n+1 ), n,info ) + call stdlib_${ri}$sytrs( uplo, n, 1, af, ldaf, ipiv, work( n+1 ), n,info ) end if go to 100 end if @@ -70807,10 +70808,10 @@ module stdlib_linalg_lapack_q if( lstres/=zero )ferr( j ) = ferr( j ) / lstres end do loop_140 return - end subroutine stdlib_qsyrfs + end subroutine stdlib_${ri}$syrfs - pure subroutine stdlib_qsysv( uplo, n, nrhs, a, lda, ipiv, b, ldb, work,lwork, info ) + pure subroutine stdlib_${ri}$sysv( uplo, n, nrhs, a, lda, ipiv, b, ldb, work,lwork, info ) !! DSYSV: computes the solution to a real system of linear equations !! A * X = B, !! where A is an N-by-N symmetric matrix and X and B are N-by-NRHS @@ -70831,8 +70832,8 @@ module stdlib_linalg_lapack_q integer(ilp), intent(in) :: lda, ldb, lwork, n, nrhs ! Array Arguments integer(ilp), intent(out) :: ipiv(*) - real(qp), intent(inout) :: a(lda,*), b(ldb,*) - real(qp), intent(out) :: work(*) + real(${rk}$), intent(inout) :: a(lda,*), b(ldb,*) + real(${rk}$), intent(out) :: work(*) ! ===================================================================== ! Local Scalars logical(lk) :: lquery @@ -70860,7 +70861,7 @@ module stdlib_linalg_lapack_q if( n==0 ) then lwkopt = 1 else - call stdlib_qsytrf( uplo, n, a, lda, ipiv, work, -1, info ) + call stdlib_${ri}$sytrf( uplo, n, a, lda, ipiv, work, -1, info ) lwkopt = work(1) end if work( 1 ) = lwkopt @@ -70872,23 +70873,23 @@ module stdlib_linalg_lapack_q return end if ! compute the factorization a = u*d*u**t or a = l*d*l**t. - call stdlib_qsytrf( uplo, n, a, lda, ipiv, work, lwork, info ) + call stdlib_${ri}$sytrf( uplo, n, a, lda, ipiv, work, lwork, info ) if( info==0 ) then ! solve the system a*x = b, overwriting b with x. if ( lwork0 )then rcond = zero @@ -71196,24 +71197,24 @@ module stdlib_linalg_lapack_q end if end if ! compute the norm of the matrix a. - anorm = stdlib_qlansy( 'I', uplo, n, a, lda, work ) + anorm = stdlib_${ri}$lansy( 'I', uplo, n, a, lda, work ) ! compute the reciprocal of the condition number of a. - call stdlib_qsycon( uplo, n, af, ldaf, ipiv, anorm, rcond, work, iwork,info ) + call stdlib_${ri}$sycon( uplo, n, af, ldaf, ipiv, anorm, rcond, work, iwork,info ) ! compute the solution vectors x. - call stdlib_qlacpy( 'FULL', n, nrhs, b, ldb, x, ldx ) - call stdlib_qsytrs( uplo, n, nrhs, af, ldaf, ipiv, x, ldx, info ) + call stdlib_${ri}$lacpy( 'FULL', n, nrhs, b, ldb, x, ldx ) + call stdlib_${ri}$sytrs( uplo, n, nrhs, af, ldaf, ipiv, x, ldx, info ) ! use iterative refinement to improve the computed solutions and ! compute error bounds and backward error estimates for them. - call stdlib_qsyrfs( uplo, n, nrhs, a, lda, af, ldaf, ipiv, b, ldb, x,ldx, ferr, berr, & + call stdlib_${ri}$syrfs( uplo, n, nrhs, a, lda, af, ldaf, ipiv, b, ldb, x,ldx, ferr, berr, & work, iwork, info ) ! set info = n+1 if the matrix is singular to working precision. - if( rcond1 ) then - imax = stdlib_iqamax( k-1, a( 1, k ), 1 ) + imax = stdlib_i${ri}$amax( k-1, a( 1, k ), 1 ) colmax = abs( a( imax, k ) ) else colmax = zero end if - if( (max( absakk, colmax )==zero) .or. stdlib_qisnan(absakk) ) then + if( (max( absakk, colmax )==zero) .or. stdlib_${ri}$isnan(absakk) ) then ! column k is zero or underflow, or contains a nan: ! set info and continue if( info==0 )info = k @@ -71455,10 +71456,10 @@ module stdlib_linalg_lapack_q else ! jmax is the column-index of the largest off-diagonal ! element in row imax, and rowmax is its absolute value - jmax = imax + stdlib_iqamax( k-imax, a( imax, imax+1 ), lda ) + jmax = imax + stdlib_i${ri}$amax( k-imax, a( imax, imax+1 ), lda ) rowmax = abs( a( imax, jmax ) ) if( imax>1 ) then - jmax = stdlib_iqamax( imax-1, a( 1, imax ), 1 ) + jmax = stdlib_i${ri}$amax( imax-1, a( 1, imax ), 1 ) rowmax = max( rowmax, abs( a( jmax, imax ) ) ) end if if( absakk>=alpha*colmax*( colmax / rowmax ) ) then @@ -71479,8 +71480,8 @@ module stdlib_linalg_lapack_q if( kp/=kk ) then ! interchange rows and columns kk and kp in the leading ! submatrix a(1:k,1:k) - call stdlib_qswap( kp-1, a( 1, kk ), 1, a( 1, kp ), 1 ) - call stdlib_qswap( kk-kp-1, a( kp+1, kk ), 1, a( kp, kp+1 ),lda ) + call stdlib_${ri}$swap( kp-1, a( 1, kk ), 1, a( 1, kp ), 1 ) + call stdlib_${ri}$swap( kk-kp-1, a( kp+1, kk ), 1, a( kp, kp+1 ),lda ) t = a( kk, kk ) a( kk, kk ) = a( kp, kp ) a( kp, kp ) = t @@ -71498,9 +71499,9 @@ module stdlib_linalg_lapack_q ! 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 r1 = one / a( k, k ) - call stdlib_qsyr( uplo, k-1, -r1, a( 1, k ), 1, a, lda ) + call stdlib_${ri}$syr( uplo, k-1, -r1, a( 1, k ), 1, a, lda ) ! store u(k) in column k - call stdlib_qscal( k-1, r1, a( 1, k ), 1 ) + call stdlib_${ri}$scal( k-1, r1, a( 1, k ), 1 ) 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) @@ -71553,12 +71554,12 @@ module stdlib_linalg_lapack_q ! column k, and colmax is its absolute value. ! determine both colmax and imax. if( k=alpha*colmax*( colmax / rowmax ) ) then @@ -71594,9 +71595,9 @@ module stdlib_linalg_lapack_q if( kp/=kk ) then ! interchange rows and columns kk and kp in the trailing ! submatrix a(k:n,k:n) - if( kp1 ) then - imax = stdlib_iqamax( k-1, a( 1, k ), 1 ) + imax = stdlib_i${ri}$amax( k-1, a( 1, k ), 1 ) colmax = abs( a( imax, k ) ) else colmax = zero @@ -71760,13 +71761,13 @@ module stdlib_linalg_lapack_q ! element in row imax, and rowmax is its absolute value. ! determine both rowmax and jmax. if( imax/=k ) then - jmax = imax + stdlib_iqamax( k-imax, a( imax, imax+1 ),lda ) + jmax = imax + stdlib_i${ri}$amax( k-imax, a( imax, imax+1 ),lda ) rowmax = abs( a( imax, jmax ) ) else rowmax = zero end if if( imax>1 ) then - itemp = stdlib_iqamax( imax-1, a( 1, imax ), 1 ) + itemp = stdlib_i${ri}$amax( imax-1, a( 1, imax ), 1 ) dtemp = abs( a( itemp, imax ) ) if( dtemp>rowmax ) then rowmax = dtemp @@ -71802,23 +71803,23 @@ module stdlib_linalg_lapack_q if( ( kstep==2 ) .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 )call stdlib_qswap( p-1, a( 1, k ), 1, a( 1, p ), 1 ) - if( p<(k-1) )call stdlib_qswap( k-p-1, a( p+1, k ), 1, a( p, p+1 ),lda ) + if( p>1 )call stdlib_${ri}$swap( p-1, a( 1, k ), 1, a( 1, p ), 1 ) + if( p<(k-1) )call stdlib_${ri}$swap( k-p-1, a( p+1, k ), 1, a( p, p+1 ),lda ) t = a( k, k ) a( k, k ) = a( p, p ) a( p, p ) = t ! convert upper triangle of a into u form by applying ! the interchanges in columns k+1:n. - if( k1 )call stdlib_qswap( kp-1, a( 1, kk ), 1, a( 1, kp ), 1 ) - if( ( kk>1 ) .and. ( kp<(kk-1) ) )call stdlib_qswap( kk-kp-1, a( kp+1, kk ), & + if( kp>1 )call stdlib_${ri}$swap( kp-1, a( 1, kk ), 1, a( 1, kp ), 1 ) + if( ( kk>1 ) .and. ( kp<(kk-1) ) )call stdlib_${ri}$swap( kk-kp-1, a( kp+1, kk ), & 1, a( kp, kp+1 ),lda ) t = a( kk, kk ) a( kk, kk ) = a( kp, kp ) @@ -71830,7 +71831,7 @@ module stdlib_linalg_lapack_q end if ! convert upper triangle of a into u form by applying ! the interchanges in columns k+1:n. - if( krowmax ) then rowmax = dtemp @@ -71996,24 +71997,24 @@ module stdlib_linalg_lapack_q if( ( kstep==2 ) .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(k+1) )call stdlib_qswap( p-k-1, a( k+1, k ), 1, a( p, k+1 ), lda ) + if( p(k+1) )call stdlib_${ri}$swap( p-k-1, a( k+1, k ), 1, a( p, k+1 ), lda ) t = a( k, k ) a( k, k ) = a( p, p ) a( p, p ) = t ! convert lower triangle of a into l form by applying ! the interchanges in columns 1:k-1. - if ( k>1 )call stdlib_qswap( k-1, a( k, 1 ), lda, a( p, 1 ), lda ) + if ( k>1 )call stdlib_${ri}$swap( k-1, a( k, 1 ), lda, a( p, 1 ), lda ) end if ! second swap kk = k + kstep - 1 if( kp/=kk ) then ! interchange rows and columns kk and kp in the trailing ! submatrix a(k:n,k:n) - if( kp(kk+1) ) )call stdlib_qswap( kp-kk-1, a( kk+1, kk ), & + if( ( kk(kk+1) ) )call stdlib_${ri}$swap( kp-kk-1, a( kk+1, kk ), & 1, a( kp, kk+1 ),lda ) t = a( kk, kk ) a( kk, kk ) = a( kp, kp ) @@ -72025,7 +72026,7 @@ module stdlib_linalg_lapack_q end if ! convert lower triangle of a into l form by applying ! the interchanges in columns 1:k-1. - if ( k>1 )call stdlib_qswap( k-1, a( kk, 1 ), lda, a( kp, 1 ), lda ) + if ( k>1 )call stdlib_${ri}$swap( k-1, a( kk, 1 ), lda, a( kp, 1 ), lda ) end if ! update the trailing submatrix if( kstep==1 ) then @@ -72040,10 +72041,10 @@ module stdlib_linalg_lapack_q ! 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_qsyr( uplo, n-k, -d11, a( k+1, k ), 1,a( k+1, k+1 ), lda ) + call stdlib_${ri}$syr( uplo, n-k, -d11, a( k+1, k ), 1,a( k+1, k+1 ), lda ) ! store l(k) in column k - call stdlib_qscal( n-k, d11, a( k+1, k ), 1 ) + call stdlib_${ri}$scal( n-k, d11, a( k+1, k ), 1 ) else ! store l(k) in column k d11 = a( k, k ) @@ -72054,7 +72055,7 @@ module stdlib_linalg_lapack_q ! 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_qsyr( uplo, n-k, -d11, a( k+1, k ), 1,a( k+1, k+1 ), lda ) + call stdlib_${ri}$syr( uplo, n-k, -d11, a( k+1, k ), 1,a( k+1, k+1 ), lda ) end if ! store the subdiagonal element of d in array e @@ -72109,10 +72110,10 @@ module stdlib_linalg_lapack_q 64 continue end if return - end subroutine stdlib_qsytf2_rk + end subroutine stdlib_${ri}$sytf2_rk - pure subroutine stdlib_qsytf2_rook( uplo, n, a, lda, ipiv, info ) + pure subroutine stdlib_${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 @@ -72129,16 +72130,16 @@ module stdlib_linalg_lapack_q integer(ilp), intent(in) :: lda, n ! Array Arguments integer(ilp), intent(out) :: ipiv(*) - real(qp), intent(inout) :: a(lda,*) + real(${rk}$), intent(inout) :: a(lda,*) ! ===================================================================== ! Parameters - real(qp), parameter :: sevten = 17.0e+0_qp + real(${rk}$), parameter :: sevten = 17.0e+0_${rk}$ ! Local Scalars logical(lk) :: upper, done integer(ilp) :: i, imax, j, jmax, itemp, k, kk, kp, kstep, p, ii - real(qp) :: absakk, alpha, colmax, d11, d12, d21, d22, rowmax, dtemp, t, wk, wkm1, & + real(${rk}$) :: absakk, alpha, colmax, d11, d12, d21, d22, rowmax, dtemp, t, wk, wkm1, & wkp1, sfmin ! Intrinsic Functions intrinsic :: abs,max,sqrt @@ -72160,7 +72161,7 @@ module stdlib_linalg_lapack_q ! initialize alpha for use in choosing pivot block size. alpha = ( one+sqrt( sevten ) ) / eight ! compute machine safe minimum - sfmin = stdlib_qlamch( 'S' ) + sfmin = stdlib_${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 @@ -72178,7 +72179,7 @@ module stdlib_linalg_lapack_q ! column k, and colmax is its absolute value. ! determine both colmax and imax. if( k>1 ) then - imax = stdlib_iqamax( k-1, a( 1, k ), 1 ) + imax = stdlib_i${ri}$amax( k-1, a( 1, k ), 1 ) colmax = abs( a( imax, k ) ) else colmax = zero @@ -72204,13 +72205,13 @@ module stdlib_linalg_lapack_q ! element in row imax, and rowmax is its absolute value. ! determine both rowmax and jmax. if( imax/=k ) then - jmax = imax + stdlib_iqamax( k-imax, a( imax, imax+1 ),lda ) + jmax = imax + stdlib_i${ri}$amax( k-imax, a( imax, imax+1 ),lda ) rowmax = abs( a( imax, jmax ) ) else rowmax = zero end if if( imax>1 ) then - itemp = stdlib_iqamax( imax-1, a( 1, imax ), 1 ) + itemp = stdlib_i${ri}$amax( imax-1, a( 1, imax ), 1 ) dtemp = abs( a( itemp, imax ) ) if( dtemp>rowmax ) then rowmax = dtemp @@ -72246,8 +72247,8 @@ module stdlib_linalg_lapack_q if( ( kstep==2 ) .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 )call stdlib_qswap( p-1, a( 1, k ), 1, a( 1, p ), 1 ) - if( p<(k-1) )call stdlib_qswap( k-p-1, a( p+1, k ), 1, a( p, p+1 ),lda ) + if( p>1 )call stdlib_${ri}$swap( p-1, a( 1, k ), 1, a( 1, p ), 1 ) + if( p<(k-1) )call stdlib_${ri}$swap( k-p-1, a( p+1, k ), 1, a( p, p+1 ),lda ) t = a( k, k ) a( k, k ) = a( p, p ) @@ -72258,8 +72259,8 @@ module stdlib_linalg_lapack_q if( kp/=kk ) then ! interchange rows and columns kk and kp in the leading ! submatrix a(1:k,1:k) - if( kp>1 )call stdlib_qswap( kp-1, a( 1, kk ), 1, a( 1, kp ), 1 ) - if( ( kk>1 ) .and. ( kp<(kk-1) ) )call stdlib_qswap( kk-kp-1, a( kp+1, kk ), & + if( kp>1 )call stdlib_${ri}$swap( kp-1, a( 1, kk ), 1, a( 1, kp ), 1 ) + if( ( kk>1 ) .and. ( kp<(kk-1) ) )call stdlib_${ri}$swap( kk-kp-1, a( kp+1, kk ), & 1, a( kp, kp+1 ),lda ) t = a( kk, kk ) a( kk, kk ) = a( kp, kp ) @@ -72283,9 +72284,9 @@ module stdlib_linalg_lapack_q ! 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_qsyr( uplo, k-1, -d11, a( 1, k ), 1, a, lda ) + call stdlib_${ri}$syr( uplo, k-1, -d11, a( 1, k ), 1, a, lda ) ! store u(k) in column k - call stdlib_qscal( k-1, d11, a( 1, k ), 1 ) + call stdlib_${ri}$scal( k-1, d11, a( 1, k ), 1 ) else ! store l(k) in column k d11 = a( k, k ) @@ -72296,7 +72297,7 @@ module stdlib_linalg_lapack_q ! 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_qsyr( uplo, k-1, -d11, a( 1, k ), 1, a, lda ) + call stdlib_${ri}$syr( uplo, k-1, -d11, a( 1, k ), 1, a, lda ) end if end if else @@ -72354,7 +72355,7 @@ module stdlib_linalg_lapack_q ! column k, and colmax is its absolute value. ! determine both colmax and imax. if( krowmax ) then rowmax = dtemp @@ -72421,8 +72422,8 @@ module stdlib_linalg_lapack_q if( ( kstep==2 ) .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(k+1) )call stdlib_qswap( p-k-1, a( k+1, k ), 1, a( p, k+1 ), lda ) + if( p(k+1) )call stdlib_${ri}$swap( p-k-1, a( k+1, k ), 1, a( p, k+1 ), lda ) t = a( k, k ) a( k, k ) = a( p, p ) @@ -72433,9 +72434,9 @@ module stdlib_linalg_lapack_q if( kp/=kk ) then ! interchange rows and columns kk and kp in the trailing ! submatrix a(k:n,k:n) - if( kp(kk+1) ) )call stdlib_qswap( kp-kk-1, a( kk+1, kk ), & + if( ( kk(kk+1) ) )call stdlib_${ri}$swap( kp-kk-1, a( kk+1, kk ), & 1, a( kp, kk+1 ),lda ) t = a( kk, kk ) a( kk, kk ) = a( kp, kp ) @@ -72459,10 +72460,10 @@ module stdlib_linalg_lapack_q ! 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_qsyr( uplo, n-k, -d11, a( k+1, k ), 1,a( k+1, k+1 ), lda ) + call stdlib_${ri}$syr( uplo, n-k, -d11, a( k+1, k ), 1,a( k+1, k+1 ), lda ) ! store l(k) in column k - call stdlib_qscal( n-k, d11, a( k+1, k ), 1 ) + call stdlib_${ri}$scal( n-k, d11, a( k+1, k ), 1 ) else ! store l(k) in column k d11 = a( k, k ) @@ -72473,7 +72474,7 @@ module stdlib_linalg_lapack_q ! 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_qsyr( uplo, n-k, -d11, a( k+1, k ), 1,a( k+1, k+1 ), lda ) + call stdlib_${ri}$syr( uplo, n-k, -d11, a( k+1, k ), 1,a( k+1, k+1 ), lda ) end if end if @@ -72520,10 +72521,10 @@ module stdlib_linalg_lapack_q end if 70 continue return - end subroutine stdlib_qsytf2_rook + end subroutine stdlib_${ri}$sytf2_rook - pure subroutine stdlib_qsytrd( uplo, n, a, lda, d, e, tau, work, lwork, info ) + pure subroutine stdlib_${ri}$sytrd( uplo, n, a, lda, d, e, tau, work, lwork, info ) !! DSYTRD: reduces a real symmetric matrix A to real symmetric !! tridiagonal form T by an orthogonal similarity transformation: !! Q**T * A * Q = T. @@ -72535,8 +72536,8 @@ module stdlib_linalg_lapack_q integer(ilp), intent(out) :: info integer(ilp), intent(in) :: lda, lwork, n ! Array Arguments - real(qp), intent(inout) :: a(lda,*) - real(qp), intent(out) :: d(*), e(*), tau(*), work(*) + real(${rk}$), intent(inout) :: a(lda,*) + real(${rk}$), intent(out) :: d(*), e(*), tau(*), work(*) ! ===================================================================== ! Local Scalars @@ -72607,10 +72608,10 @@ module stdlib_linalg_lapack_q ! reduce columns i:i+nb-1 to tridiagonal form and form the ! matrix w which is needed to update the unreduced part of ! the matrix - call stdlib_qlatrd( uplo, i+nb-1, nb, a, lda, e, tau, work,ldwork ) + call stdlib_${ri}$latrd( uplo, i+nb-1, nb, a, lda, e, tau, work,ldwork ) ! update the unreduced submatrix a(1:i-1,1:i-1), using an ! update of the form: a := a - v*w**t - w*v**t - call stdlib_qsyr2k( uplo, 'NO TRANSPOSE', i-1, nb, -one, a( 1, i ),lda, work, & + call stdlib_${ri}$syr2k( uplo, 'NO TRANSPOSE', i-1, nb, -one, a( 1, i ),lda, work, & ldwork, one, a, lda ) ! copy superdiagonal elements back into a, and diagonal ! elements into d @@ -72620,18 +72621,18 @@ module stdlib_linalg_lapack_q end do end do ! use unblocked code to reduce the last or only block - call stdlib_qsytd2( uplo, kk, a, lda, d, e, tau, iinfo ) + call stdlib_${ri}$sytd2( uplo, kk, a, lda, d, e, tau, iinfo ) else ! reduce the lower triangle of a do i = 1, n - nx, nb ! reduce columns i:i+nb-1 to tridiagonal form and form the ! matrix w which is needed to update the unreduced part of ! the matrix - call stdlib_qlatrd( uplo, n-i+1, nb, a( i, i ), lda, e( i ),tau( i ), work, & + call stdlib_${ri}$latrd( uplo, n-i+1, nb, a( i, i ), lda, e( i ),tau( i ), work, & ldwork ) ! update the unreduced submatrix a(i+ib:n,i+ib:n), using ! an update of the form: a := a - v*w**t - w*v**t - call stdlib_qsyr2k( uplo, 'NO TRANSPOSE', n-i-nb+1, nb, -one,a( i+nb, i ), lda, & + call stdlib_${ri}$syr2k( uplo, 'NO TRANSPOSE', n-i-nb+1, nb, -one,a( i+nb, i ), lda, & work( nb+1 ), ldwork, one,a( i+nb, i+nb ), lda ) ! copy subdiagonal elements back into a, and diagonal ! elements into d @@ -72641,15 +72642,15 @@ module stdlib_linalg_lapack_q end do end do ! use unblocked code to reduce the last or only block - call stdlib_qsytd2( uplo, n-i+1, a( i, i ), lda, d( i ), e( i ),tau( i ), iinfo ) + call stdlib_${ri}$sytd2( uplo, n-i+1, a( i, i ), lda, d( i ), e( i ),tau( i ), iinfo ) end if work( 1 ) = lwkopt return - end subroutine stdlib_qsytrd + end subroutine stdlib_${ri}$sytrd - subroutine stdlib_qsytrd_sb2st( stage1, vect, uplo, n, kd, ab, ldab,d, e, hous, lhous, & + subroutine stdlib_${ri}$sytrd_sb2st( stage1, vect, uplo, n, kd, ab, ldab,d, e, hous, lhous, & !! DSYTRD_SB2ST: reduces a real symmetric band matrix A to real symmetric !! tridiagonal form T by a orthogonal similarity transformation: !! Q**T * A * Q = T. @@ -72662,12 +72663,12 @@ module stdlib_linalg_lapack_q integer(ilp), intent(in) :: n, kd, ldab, lhous, lwork integer(ilp), intent(out) :: info ! Array Arguments - real(qp), intent(out) :: d(*), e(*) - real(qp), intent(inout) :: ab(ldab,*) - real(qp), intent(out) :: hous(*), work(*) + real(${rk}$), intent(out) :: d(*), e(*) + real(${rk}$), intent(inout) :: ab(ldab,*) + real(${rk}$), intent(out) :: hous(*), work(*) ! ===================================================================== ! Parameters - real(qp), parameter :: rzero = 0.0e+0_qp + real(${rk}$), parameter :: rzero = 0.0e+0_${rk}$ ! Local Scalars @@ -72798,11 +72799,11 @@ module stdlib_linalg_lapack_q thgrsiz = n grsiz = 1 shift = 3 - nbtiles = ceiling( real(n,KIND=qp)/real(kd,KIND=qp) ) - stepercol = ceiling( real(shift,KIND=qp)/real(grsiz,KIND=qp) ) - thgrnb = ceiling( real(n-1,KIND=qp)/real(thgrsiz,KIND=qp) ) - call stdlib_qlacpy( "A", kd+1, n, ab, ldab, work( apos ), lda ) - call stdlib_qlaset( "A", kd, n, zero, zero, work( awpos ), lda ) + nbtiles = ceiling( real(n,KIND=${rk}$)/real(kd,KIND=${rk}$) ) + stepercol = ceiling( real(shift,KIND=${rk}$)/real(grsiz,KIND=${rk}$) ) + thgrnb = ceiling( real(n-1,KIND=${rk}$)/real(thgrsiz,KIND=${rk}$) ) + call stdlib_${ri}$lacpy( "A", kd+1, n, ab, ldab, work( apos ), lda ) + call stdlib_${ri}$laset( "A", kd, n, zero, zero, work( awpos ), lda ) ! openmp parallelisation start here !$OMP PARALLEL PRIVATE( TID, THGRID, BLKLASTIND ) & !$OMP& PRIVATE( THED, I, M, K, ST, ED, STT, SWEEPID ) & @@ -72849,7 +72850,7 @@ module stdlib_linalg_lapack_q !$OMP& DEPEND(in:WORK(MYID-1)) & !$OMP& DEPEND(out:WORK(MYID)) !$ tid = omp_get_thread_num() - !$ call stdlib_qsb2st_kernels( uplo, wantq, ttype,stind, edind, & + !$ call stdlib_${ri}$sb2st_kernels( uplo, wantq, ttype,stind, edind, & !$ sweepid, n, kd, ib,work ( inda ), lda,hous( indv ), hous( & !$ indtau ), ldv,work( indw + tid*kd ) ) !$OMP END TASK @@ -72857,7 +72858,7 @@ module stdlib_linalg_lapack_q !$OMP TASK DEPEND(in:WORK(MYID+SHIFT-1)) & !$OMP& DEPEND(out:WORK(MYID)) !$ tid = omp_get_thread_num() - call stdlib_qsb2st_kernels( uplo, wantq, ttype,stind, edind, & + call stdlib_${ri}$sb2st_kernels( uplo, wantq, ttype,stind, edind, & sweepid, n, kd, ib,work ( inda ), lda,hous( indv ), hous( & indtau ), ldv,work( indw + tid*kd ) ) !$OMP END TASK @@ -72892,10 +72893,10 @@ module stdlib_linalg_lapack_q hous( 1 ) = lhmin work( 1 ) = lwmin return - end subroutine stdlib_qsytrd_sb2st + end subroutine stdlib_${ri}$sytrd_sb2st - subroutine stdlib_qsytrd_sy2sb( uplo, n, kd, a, lda, ab, ldab, tau,work, lwork, info ) + subroutine stdlib_${ri}$sytrd_sy2sb( uplo, n, kd, a, lda, ab, ldab, tau,work, lwork, info ) !! DSYTRD_SY2SB: reduces a real symmetric matrix A to real symmetric !! band-diagonal form AB by a orthogonal similarity transformation: !! Q**T * A * Q = AB. @@ -72908,11 +72909,11 @@ module stdlib_linalg_lapack_q integer(ilp), intent(out) :: info integer(ilp), intent(in) :: lda, ldab, lwork, n, kd ! Array Arguments - real(qp), intent(inout) :: a(lda,*) - real(qp), intent(out) :: ab(ldab,*), tau(*), work(*) + real(${rk}$), intent(inout) :: a(lda,*) + real(${rk}$), intent(out) :: ab(ldab,*), tau(*), work(*) ! ===================================================================== ! Parameters - real(qp), parameter :: rone = 1.0e+0_qp + real(${rk}$), parameter :: rone = 1.0e+0_${rk}$ ! Local Scalars @@ -72954,12 +72955,12 @@ module stdlib_linalg_lapack_q if( upper ) then do i = 1, n llk = min( kd+1, i ) - call stdlib_qcopy( llk, a( i-llk+1, i ), 1,ab( kd+1-llk+1, i ), 1 ) + call stdlib_${ri}$copy( llk, a( i-llk+1, i ), 1,ab( kd+1-llk+1, i ), 1 ) end do else do i = 1, n llk = min( kd+1, n-i+1 ) - call stdlib_qcopy( llk, a( i, i ), 1, ab( 1, i ), 1 ) + call stdlib_${ri}$copy( llk, a( i, i ), 1, ab( 1, i ), 1 ) end do endif work( 1 ) = 1 @@ -72986,41 +72987,41 @@ module stdlib_linalg_lapack_q endif ! set the workspace of the triangular matrix t to zero once such a ! way every time t is generated the upper/lower portion will be always zero - call stdlib_qlaset( "A", ldt, kd, zero, zero, work( tpos ), ldt ) + call stdlib_${ri}$laset( "A", ldt, kd, zero, zero, work( tpos ), ldt ) if( upper ) then do i = 1, n - kd, kd pn = n-i-kd+1 pk = min( n-i-kd+1, kd ) ! compute the lq factorization of the current block - call stdlib_qgelqf( kd, pn, a( i, i+kd ), lda,tau( i ), work( s2pos ), ls2, & + call stdlib_${ri}$gelqf( kd, pn, a( i, i+kd ), lda,tau( i ), work( s2pos ), ls2, & iinfo ) ! copy the upper portion of a into ab do j = i, i+pk-1 llk = min( kd, n-j ) + 1 - call stdlib_qcopy( llk, a( j, j ), lda, ab( kd+1, j ), ldab-1 ) + call stdlib_${ri}$copy( llk, a( j, j ), lda, ab( kd+1, j ), ldab-1 ) end do - call stdlib_qlaset( 'LOWER', pk, pk, zero, one,a( i, i+kd ), lda ) + call stdlib_${ri}$laset( 'LOWER', pk, pk, zero, one,a( i, i+kd ), lda ) ! form the matrix t - call stdlib_qlarft( 'FORWARD', 'ROWWISE', pn, pk,a( i, i+kd ), lda, tau( i ),& + call stdlib_${ri}$larft( 'FORWARD', 'ROWWISE', pn, pk,a( i, i+kd ), lda, tau( i ),& work( tpos ), ldt ) ! compute w: - call stdlib_qgemm( 'CONJUGATE', 'NO TRANSPOSE', pk, pn, pk,one, work( tpos ), & + call stdlib_${ri}$gemm( 'CONJUGATE', 'NO TRANSPOSE', pk, pn, pk,one, work( tpos ), & ldt,a( i, i+kd ), lda,zero, work( s2pos ), lds2 ) - call stdlib_qsymm( 'RIGHT', uplo, pk, pn,one, a( i+kd, i+kd ), lda,work( s2pos & + call stdlib_${ri}$symm( 'RIGHT', uplo, pk, pn,one, a( i+kd, i+kd ), lda,work( s2pos & ), lds2,zero, work( wpos ), ldw ) - call stdlib_qgemm( 'NO TRANSPOSE', 'CONJUGATE', pk, pk, pn,one, work( wpos ), & + call stdlib_${ri}$gemm( 'NO TRANSPOSE', 'CONJUGATE', pk, pk, pn,one, work( wpos ), & ldw,work( s2pos ), lds2,zero, work( s1pos ), lds1 ) - call stdlib_qgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', pk, pn, pk,-half, work( & + call stdlib_${ri}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', pk, pn, pk,-half, work( & s1pos ), lds1,a( i, i+kd ), lda,one, work( wpos ), ldw ) ! update the unreduced submatrix a(i+kd:n,i+kd:n), using ! an update of the form: a := a - v'*w - w'*v - call stdlib_qsyr2k( uplo, 'CONJUGATE', pn, pk,-one, a( i, i+kd ), lda,work( & + call stdlib_${ri}$syr2k( uplo, 'CONJUGATE', pn, pk,-one, a( i, i+kd ), lda,work( & wpos ), ldw,rone, a( i+kd, i+kd ), lda ) end do ! copy the upper band to ab which is the band storage matrix do j = n-kd+1, n llk = min(kd, n-j) + 1 - call stdlib_qcopy( llk, a( j, j ), lda, ab( kd+1, j ), ldab-1 ) + call stdlib_${ri}$copy( llk, a( j, j ), lda, ab( kd+1, j ), ldab-1 ) end do else ! reduce the lower triangle of a to lower band matrix @@ -73028,50 +73029,50 @@ module stdlib_linalg_lapack_q pn = n-i-kd+1 pk = min( n-i-kd+1, kd ) ! compute the qr factorization of the current block - call stdlib_qgeqrf( pn, kd, a( i+kd, i ), lda,tau( i ), work( s2pos ), ls2, & + call stdlib_${ri}$geqrf( pn, kd, a( i+kd, i ), lda,tau( i ), work( s2pos ), ls2, & iinfo ) ! copy the upper portion of a into ab do j = i, i+pk-1 llk = min( kd, n-j ) + 1 - call stdlib_qcopy( llk, a( j, j ), 1, ab( 1, j ), 1 ) + call stdlib_${ri}$copy( llk, a( j, j ), 1, ab( 1, j ), 1 ) end do - call stdlib_qlaset( 'UPPER', pk, pk, zero, one,a( i+kd, i ), lda ) + call stdlib_${ri}$laset( 'UPPER', pk, pk, zero, one,a( i+kd, i ), lda ) ! form the matrix t - call stdlib_qlarft( 'FORWARD', 'COLUMNWISE', pn, pk,a( i+kd, i ), lda, tau( i ),& + call stdlib_${ri}$larft( 'FORWARD', 'COLUMNWISE', pn, pk,a( i+kd, i ), lda, tau( i ),& work( tpos ), ldt ) ! compute w: - call stdlib_qgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', pn, pk, pk,one, a( i+kd, i ),& + call stdlib_${ri}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', pn, pk, pk,one, a( i+kd, i ),& lda,work( tpos ), ldt,zero, work( s2pos ), lds2 ) - call stdlib_qsymm( 'LEFT', uplo, pn, pk,one, a( i+kd, i+kd ), lda,work( s2pos ),& + call stdlib_${ri}$symm( 'LEFT', uplo, pn, pk,one, a( i+kd, i+kd ), lda,work( s2pos ),& lds2,zero, work( wpos ), ldw ) - call stdlib_qgemm( 'CONJUGATE', 'NO TRANSPOSE', pk, pk, pn,one, work( s2pos ), & + call stdlib_${ri}$gemm( 'CONJUGATE', 'NO TRANSPOSE', pk, pk, pn,one, work( s2pos ), & lds2,work( wpos ), ldw,zero, work( s1pos ), lds1 ) - call stdlib_qgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', pn, pk, pk,-half, a( i+kd, i & + call stdlib_${ri}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', pn, pk, pk,-half, a( i+kd, i & ), lda,work( s1pos ), lds1,one, work( wpos ), ldw ) ! update the unreduced submatrix a(i+kd:n,i+kd:n), using ! an update of the form: a := a - v*w' - w*v' - call stdlib_qsyr2k( uplo, 'NO TRANSPOSE', pn, pk,-one, a( i+kd, i ), lda,work( & + call stdlib_${ri}$syr2k( uplo, 'NO TRANSPOSE', pn, pk,-one, a( i+kd, i ), lda,work( & wpos ), ldw,rone, a( i+kd, i+kd ), lda ) ! ================================================================== ! restore a for comparison and checking to be removed ! do 45 j = i, i+pk-1 ! llk = min( kd, n-j ) + 1 - ! call stdlib_qcopy( llk, ab( 1, j ), 1, a( j, j ), 1 ) + ! call stdlib_${ri}$copy( llk, ab( 1, j ), 1, a( j, j ), 1 ) 45 continue ! ================================================================== end do loop_40 ! copy the lower band to ab which is the band storage matrix do j = n-kd+1, n llk = min(kd, n-j) + 1 - call stdlib_qcopy( llk, a( j, j ), 1, ab( 1, j ), 1 ) + call stdlib_${ri}$copy( llk, a( j, j ), 1, ab( 1, j ), 1 ) end do end if work( 1 ) = lwmin return - end subroutine stdlib_qsytrd_sy2sb + end subroutine stdlib_${ri}$sytrd_sy2sb - pure subroutine stdlib_qsytrf( uplo, n, a, lda, ipiv, work, lwork, info ) + pure subroutine stdlib_${ri}$sytrf( uplo, n, a, lda, ipiv, work, lwork, info ) !! DSYTRF: computes the factorization of a real symmetric matrix A using !! the Bunch-Kaufman diagonal pivoting method. The form of the !! factorization is @@ -73089,8 +73090,8 @@ module stdlib_linalg_lapack_q integer(ilp), intent(in) :: lda, lwork, n ! Array Arguments integer(ilp), intent(out) :: ipiv(*) - real(qp), intent(inout) :: a(lda,*) - real(qp), intent(out) :: work(*) + real(${rk}$), intent(inout) :: a(lda,*) + real(${rk}$), intent(out) :: work(*) ! ===================================================================== ! Local Scalars logical(lk) :: lquery, upper @@ -73138,7 +73139,7 @@ module stdlib_linalg_lapack_q if( upper ) then ! factorize a as u**t*d*u 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_qlasyf; + ! kb, where kb is the number of columns factorized by stdlib_${ri}$lasyf; ! kb is either nb or nb-1, or k for the last block k = n 10 continue @@ -73147,10 +73148,10 @@ module stdlib_linalg_lapack_q if( k>nb ) then ! factorize columns k-kb+1:k of a and use blocked code to ! update columns 1:k-kb - call stdlib_qlasyf( uplo, k, nb, kb, a, lda, ipiv, work, ldwork,iinfo ) + call stdlib_${ri}$lasyf( uplo, k, nb, kb, a, lda, ipiv, work, ldwork,iinfo ) else ! use unblocked code to factorize columns 1:k of a - call stdlib_qsytf2( uplo, k, a, lda, ipiv, iinfo ) + call stdlib_${ri}$sytf2( uplo, k, a, lda, ipiv, iinfo ) kb = k end if ! set info on the first occurrence of a zero pivot @@ -73161,7 +73162,7 @@ module stdlib_linalg_lapack_q 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_qlasyf; + ! kb, where kb is the number of columns factorized by stdlib_${ri}$lasyf; ! kb is either nb or nb-1, or n-k+1 for the last block k = 1 20 continue @@ -73170,11 +73171,11 @@ module stdlib_linalg_lapack_q 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_qlasyf( uplo, n-k+1, nb, kb, a( k, k ), lda, ipiv( k ),work, ldwork, & + call stdlib_${ri}$lasyf( 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_qsytf2( uplo, n-k+1, a( k, k ), lda, ipiv( k ), iinfo ) + call stdlib_${ri}$sytf2( uplo, n-k+1, a( k, k ), lda, ipiv( k ), iinfo ) kb = n - k + 1 end if ! set info on the first occurrence of a zero pivot @@ -73194,10 +73195,10 @@ module stdlib_linalg_lapack_q 40 continue work( 1 ) = lwkopt return - end subroutine stdlib_qsytrf + end subroutine stdlib_${ri}$sytrf - pure subroutine stdlib_qsytrf_aa( uplo, n, a, lda, ipiv, work, lwork, info) + pure subroutine stdlib_${ri}$sytrf_aa( uplo, n, a, lda, ipiv, work, lwork, info) !! DSYTRF_AA: computes the factorization of a real symmetric matrix A !! using the Aasen's algorithm. The form of the factorization is !! A = U**T*T*U or A = L*T*L**T @@ -73213,15 +73214,15 @@ module stdlib_linalg_lapack_q integer(ilp), intent(out) :: info ! Array Arguments integer(ilp), intent(out) :: ipiv(*) - real(qp), intent(inout) :: a(lda,*) - real(qp), intent(out) :: work(*) + real(${rk}$), intent(inout) :: a(lda,*) + real(${rk}$), intent(out) :: work(*) ! ===================================================================== ! Local Scalars logical(lk) :: lquery, upper integer(ilp) :: j, lwkopt integer(ilp) :: nb, mj, nj, k1, k2, j1, j2, j3, jb - real(qp) :: alpha + real(${rk}$) :: alpha ! Intrinsic Functions intrinsic :: max ! Executable Statements @@ -73267,9 +73268,9 @@ module stdlib_linalg_lapack_q ! factorize a as u**t*d*u using the upper triangle of a ! ..................................................... ! copy first row a(1, 1:n) into h(1:n) (stored in work(1:n)) - call stdlib_qcopy( n, a( 1, 1 ), lda, work( 1 ), 1 ) + call stdlib_${ri}$copy( n, a( 1, 1 ), lda, work( 1 ), 1 ) ! j is the main loop index, increasing from 1 to n in steps of - ! jb, where jb is the number of columns factorized by stdlib_qlasyf; + ! jb, where jb is the number of columns factorized by stdlib_${ri}$lasyf; ! jb is either nb, or n-j+1 for the last block j = 0 10 continue @@ -73284,13 +73285,13 @@ module stdlib_linalg_lapack_q jb = min( n-j1+1, nb ) k1 = max(1, j)-j ! panel factorization - call stdlib_qlasyf_aa( uplo, 2-k1, n-j, jb,a( max(1, j), j+1 ), lda,ipiv( j+1 ), & + call stdlib_${ri}$lasyf_aa( uplo, 2-k1, n-j, jb,a( max(1, j), j+1 ), lda,ipiv( j+1 ), & work, n, work( n*nb+1 ) ) ! adjust ipiv and apply it back (j-th step picks (j+1)-th pivot) do j2 = j+2, min(n, j+jb+1) ipiv( j2 ) = ipiv( j2 ) + j if( (j2/=ipiv(j2)) .and. ((j1-k1)>2) ) then - call stdlib_qswap( j1-k1-2, a( 1, j2 ), 1,a( 1, ipiv(j2) ), 1 ) + call stdlib_${ri}$swap( j1-k1-2, a( 1, j2 ), 1,a( 1, ipiv(j2) ), 1 ) end if end do j = j + jb @@ -73303,9 +73304,9 @@ module stdlib_linalg_lapack_q ! merge rank-1 update with blas-3 update alpha = a( j, j+1 ) a( j, j+1 ) = one - call stdlib_qcopy( n-j, a( j-1, j+1 ), lda,work( (j+1-j1+1)+jb*n ), 1 ) + call stdlib_${ri}$copy( n-j, a( j-1, j+1 ), lda,work( (j+1-j1+1)+jb*n ), 1 ) - call stdlib_qscal( n-j, alpha, work( (j+1-j1+1)+jb*n ), 1 ) + call stdlib_${ri}$scal( n-j, alpha, work( (j+1-j1+1)+jb*n ), 1 ) ! k1 identifies if the previous column of the panel has been ! explicitly stored, e.g., k1=1 and k2= 0 for the first panel, ! while k1=0 and k2=1 for the rest @@ -73320,22 +73321,22 @@ module stdlib_linalg_lapack_q end if do j2 = j+1, n, nb nj = min( nb, n-j2+1 ) - ! update (j2, j2) diagonal block with stdlib_qgemv + ! update (j2, j2) diagonal block with stdlib_${ri}$gemv j3 = j2 do mj = nj-1, 1, -1 - call stdlib_qgemv( 'NO TRANSPOSE', mj, jb+1,-one, work( j3-j1+1+k1*n ), & + call stdlib_${ri}$gemv( 'NO TRANSPOSE', mj, jb+1,-one, work( j3-j1+1+k1*n ), & n,a( j1-k2, j3 ), 1,one, a( j3, j3 ), lda ) j3 = j3 + 1 end do - ! update off-diagonal block of j2-th block row with stdlib_qgemm - call stdlib_qgemm( 'TRANSPOSE', 'TRANSPOSE',nj, n-j3+1, jb+1,-one, a( j1-& + ! update off-diagonal block of j2-th block row with stdlib_${ri}$gemm + call stdlib_${ri}$gemm( 'TRANSPOSE', 'TRANSPOSE',nj, n-j3+1, jb+1,-one, a( j1-& k2, j2 ), lda,work( j3-j1+1+k1*n ), n,one, a( j2, j3 ), lda ) end do ! recover t( j, j+1 ) a( j, j+1 ) = alpha end if ! work(j+1, 1) stores h(j+1, 1) - call stdlib_qcopy( n-j, a( j+1, j+1 ), lda, work( 1 ), 1 ) + call stdlib_${ri}$copy( n-j, a( j+1, j+1 ), lda, work( 1 ), 1 ) end if go to 10 else @@ -73344,9 +73345,9 @@ module stdlib_linalg_lapack_q ! ..................................................... ! copy first column a(1:n, 1) into h(1:n, 1) ! (stored in work(1:n)) - call stdlib_qcopy( n, a( 1, 1 ), 1, work( 1 ), 1 ) + call stdlib_${ri}$copy( n, a( 1, 1 ), 1, work( 1 ), 1 ) ! j is the main loop index, increasing from 1 to n in steps of - ! jb, where jb is the number of columns factorized by stdlib_qlasyf; + ! jb, where jb is the number of columns factorized by stdlib_${ri}$lasyf; ! jb is either nb, or n-j+1 for the last block j = 0 11 continue @@ -73361,13 +73362,13 @@ module stdlib_linalg_lapack_q jb = min( n-j1+1, nb ) k1 = max(1, j)-j ! panel factorization - call stdlib_qlasyf_aa( uplo, 2-k1, n-j, jb,a( j+1, max(1, j) ), lda,ipiv( j+1 ), & + call stdlib_${ri}$lasyf_aa( uplo, 2-k1, n-j, jb,a( j+1, max(1, j) ), lda,ipiv( j+1 ), & work, n, work( n*nb+1 ) ) ! adjust ipiv and apply it back (j-th step picks (j+1)-th pivot) do j2 = j+2, min(n, j+jb+1) ipiv( j2 ) = ipiv( j2 ) + j if( (j2/=ipiv(j2)) .and. ((j1-k1)>2) ) then - call stdlib_qswap( j1-k1-2, a( j2, 1 ), lda,a( ipiv(j2), 1 ), lda ) + call stdlib_${ri}$swap( j1-k1-2, a( j2, 1 ), lda,a( ipiv(j2), 1 ), lda ) end if end do j = j + jb @@ -73380,8 +73381,8 @@ module stdlib_linalg_lapack_q ! merge rank-1 update with blas-3 update alpha = a( j+1, j ) a( j+1, j ) = one - call stdlib_qcopy( n-j, a( j+1, j-1 ), 1,work( (j+1-j1+1)+jb*n ), 1 ) - call stdlib_qscal( n-j, alpha, work( (j+1-j1+1)+jb*n ), 1 ) + call stdlib_${ri}$copy( n-j, a( j+1, j-1 ), 1,work( (j+1-j1+1)+jb*n ), 1 ) + call stdlib_${ri}$scal( n-j, alpha, work( (j+1-j1+1)+jb*n ), 1 ) ! k1 identifies if the previous column of the panel has been ! explicitly stored, e.g., k1=1 and k2= 0 for the first panel, ! while k1=0 and k2=1 for the rest @@ -73396,32 +73397,32 @@ module stdlib_linalg_lapack_q end if do j2 = j+1, n, nb nj = min( nb, n-j2+1 ) - ! update (j2, j2) diagonal block with stdlib_qgemv + ! update (j2, j2) diagonal block with stdlib_${ri}$gemv j3 = j2 do mj = nj-1, 1, -1 - call stdlib_qgemv( 'NO TRANSPOSE', mj, jb+1,-one, work( j3-j1+1+k1*n ), & + call stdlib_${ri}$gemv( 'NO TRANSPOSE', mj, jb+1,-one, work( j3-j1+1+k1*n ), & n,a( j3, j1-k2 ), lda,one, a( j3, j3 ), 1 ) j3 = j3 + 1 end do - ! update off-diagonal block in j2-th block column with stdlib_qgemm - call stdlib_qgemm( 'NO TRANSPOSE', 'TRANSPOSE',n-j3+1, nj, jb+1,-one, work(& + ! update off-diagonal block in j2-th block column with stdlib_${ri}$gemm + call stdlib_${ri}$gemm( 'NO TRANSPOSE', 'TRANSPOSE',n-j3+1, nj, jb+1,-one, work(& j3-j1+1+k1*n ), n,a( j2, j1-k2 ), lda,one, a( j3, j2 ), lda ) end do ! recover t( j+1, j ) a( j+1, j ) = alpha end if ! work(j+1, 1) stores h(j+1, 1) - call stdlib_qcopy( n-j, a( j+1, j+1 ), 1, work( 1 ), 1 ) + call stdlib_${ri}$copy( n-j, a( j+1, j+1 ), 1, work( 1 ), 1 ) end if go to 11 end if 20 continue work( 1 ) = lwkopt return - end subroutine stdlib_qsytrf_aa + end subroutine stdlib_${ri}$sytrf_aa - pure subroutine stdlib_qsytrf_rk( uplo, n, a, lda, e, ipiv, work, lwork,info ) + pure subroutine stdlib_${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), @@ -73440,8 +73441,8 @@ module stdlib_linalg_lapack_q integer(ilp), intent(in) :: lda, lwork, n ! Array Arguments integer(ilp), intent(out) :: ipiv(*) - real(qp), intent(inout) :: a(lda,*) - real(qp), intent(out) :: e(*), work(*) + real(${rk}$), intent(inout) :: a(lda,*) + real(${rk}$), intent(out) :: e(*), work(*) ! ===================================================================== ! Local Scalars logical(lk) :: lquery, upper @@ -73489,7 +73490,7 @@ module stdlib_linalg_lapack_q 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_qlasyf_rk; + ! kb, where kb is the number of columns factorized by stdlib_${ri}$lasyf_rk; ! kb is either nb or nb-1, or k for the last block k = n 10 continue @@ -73498,11 +73499,11 @@ module stdlib_linalg_lapack_q if( k>nb ) then ! factorize columns k-kb+1:k of a and use blocked code to ! update columns 1:k-kb - call stdlib_qlasyf_rk( uplo, k, nb, kb, a, lda, e,ipiv, work, ldwork, iinfo ) + call stdlib_${ri}$lasyf_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_qsytf2_rk( uplo, k, a, lda, e, ipiv, iinfo ) + call stdlib_${ri}$sytf2_rk( uplo, k, a, lda, e, ipiv, iinfo ) kb = k end if ! set info on the first occurrence of a zero pivot @@ -73519,7 +73520,7 @@ module stdlib_linalg_lapack_q do i = k, ( k - kb + 1 ), -1 ip = abs( ipiv( i ) ) if( ip/=i ) then - call stdlib_qswap( n-k, a( i, k+1 ), lda,a( ip, k+1 ), lda ) + call stdlib_${ri}$swap( n-k, a( i, k+1 ), lda,a( ip, k+1 ), lda ) end if end do end if @@ -73532,7 +73533,7 @@ module stdlib_linalg_lapack_q 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_qlasyf_rk; + ! kb, where kb is the number of columns factorized by stdlib_${ri}$lasyf_rk; ! kb is either nb or nb-1, or n-k+1 for the last block k = 1 20 continue @@ -73541,11 +73542,11 @@ module stdlib_linalg_lapack_q 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_qlasyf_rk( uplo, n-k+1, nb, kb, a( k, k ), lda, e( k ),ipiv( k ), & + call stdlib_${ri}$lasyf_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_qsytf2_rk( uplo, n-k+1, a( k, k ), lda, e( k ),ipiv( k ), iinfo ) + call stdlib_${ri}$sytf2_rk( uplo, n-k+1, a( k, k ), lda, e( k ),ipiv( k ), iinfo ) kb = n - k + 1 end if @@ -73570,7 +73571,7 @@ module stdlib_linalg_lapack_q do i = k, ( k + kb - 1 ), 1 ip = abs( ipiv( i ) ) if( ip/=i ) then - call stdlib_qswap( k-1, a( i, 1 ), lda,a( ip, 1 ), lda ) + call stdlib_${ri}$swap( k-1, a( i, 1 ), lda,a( ip, 1 ), lda ) end if end do end if @@ -73584,10 +73585,10 @@ module stdlib_linalg_lapack_q end if work( 1 ) = lwkopt return - end subroutine stdlib_qsytrf_rk + end subroutine stdlib_${ri}$sytrf_rk - pure subroutine stdlib_qsytrf_rook( uplo, n, a, lda, ipiv, work, lwork, info ) + pure subroutine stdlib_${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 @@ -73605,8 +73606,8 @@ module stdlib_linalg_lapack_q integer(ilp), intent(in) :: lda, lwork, n ! Array Arguments integer(ilp), intent(out) :: ipiv(*) - real(qp), intent(inout) :: a(lda,*) - real(qp), intent(out) :: work(*) + real(${rk}$), intent(inout) :: a(lda,*) + real(${rk}$), intent(out) :: work(*) ! ===================================================================== ! Local Scalars logical(lk) :: lquery, upper @@ -73654,7 +73655,7 @@ module stdlib_linalg_lapack_q 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_qlasyf_rook; + ! kb, where kb is the number of columns factorized by stdlib_${ri}$lasyf_rook; ! kb is either nb or nb-1, or k for the last block k = n 10 continue @@ -73663,11 +73664,11 @@ module stdlib_linalg_lapack_q if( k>nb ) then ! factorize columns k-kb+1:k of a and use blocked code to ! update columns 1:k-kb - call stdlib_qlasyf_rook( uplo, k, nb, kb, a, lda,ipiv, work, ldwork, iinfo ) + call stdlib_${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_qsytf2_rook( uplo, k, a, lda, ipiv, iinfo ) + call stdlib_${ri}$sytf2_rook( uplo, k, a, lda, ipiv, iinfo ) kb = k end if ! set info on the first occurrence of a zero pivot @@ -73679,7 +73680,7 @@ module stdlib_linalg_lapack_q 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_qlasyf_rook; + ! kb, where kb is the number of columns factorized by stdlib_${ri}$lasyf_rook; ! kb is either nb or nb-1, or n-k+1 for the last block k = 1 20 continue @@ -73688,11 +73689,11 @@ module stdlib_linalg_lapack_q 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_qlasyf_rook( uplo, n-k+1, nb, kb, a( k, k ), lda,ipiv( k ), work, & + call stdlib_${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_qsytf2_rook( uplo, n-k+1, a( k, k ), lda, ipiv( k ),iinfo ) + call stdlib_${ri}$sytf2_rook( uplo, n-k+1, a( k, k ), lda, ipiv( k ),iinfo ) kb = n - k + 1 end if ! set info on the first occurrence of a zero pivot @@ -73712,10 +73713,10 @@ module stdlib_linalg_lapack_q 40 continue work( 1 ) = lwkopt return - end subroutine stdlib_qsytrf_rook + end subroutine stdlib_${ri}$sytrf_rook - pure subroutine stdlib_qsytri( uplo, n, a, lda, ipiv, work, info ) + pure subroutine stdlib_${ri}$sytri( uplo, n, a, lda, ipiv, work, info ) !! DSYTRI: computes the inverse of a real symmetric indefinite matrix !! A using the factorization A = U*D*U**T or A = L*D*L**T computed by !! DSYTRF. @@ -73728,14 +73729,14 @@ module stdlib_linalg_lapack_q integer(ilp), intent(in) :: lda, n ! Array Arguments integer(ilp), intent(in) :: ipiv(*) - real(qp), intent(inout) :: a(lda,*) - real(qp), intent(out) :: work(*) + real(${rk}$), intent(inout) :: a(lda,*) + real(${rk}$), intent(out) :: work(*) ! ===================================================================== ! Local Scalars logical(lk) :: upper integer(ilp) :: k, kp, kstep - real(qp) :: ak, akkp1, akp1, d, t, temp + real(${rk}$) :: ak, akkp1, akp1, d, t, temp ! Intrinsic Functions intrinsic :: abs,max ! Executable Statements @@ -73782,10 +73783,10 @@ module stdlib_linalg_lapack_q a( k, k ) = one / a( k, k ) ! compute column k of the inverse. if( k>1 ) then - call stdlib_qcopy( k-1, a( 1, k ), 1, work, 1 ) - call stdlib_qsymv( uplo, k-1, -one, a, lda, work, 1, zero,a( 1, k ), 1 ) + call stdlib_${ri}$copy( k-1, a( 1, k ), 1, work, 1 ) + call stdlib_${ri}$symv( uplo, k-1, -one, a, lda, work, 1, zero,a( 1, k ), 1 ) - a( k, k ) = a( k, k ) - stdlib_qdot( k-1, work, 1, a( 1, k ),1 ) + a( k, k ) = a( k, k ) - stdlib_${ri}$dot( k-1, work, 1, a( 1, k ),1 ) end if kstep = 1 else @@ -73801,16 +73802,16 @@ module stdlib_linalg_lapack_q a( k, k+1 ) = -akkp1 / d ! compute columns k and k+1 of the inverse. if( k>1 ) then - call stdlib_qcopy( k-1, a( 1, k ), 1, work, 1 ) - call stdlib_qsymv( uplo, k-1, -one, a, lda, work, 1, zero,a( 1, k ), 1 ) + call stdlib_${ri}$copy( k-1, a( 1, k ), 1, work, 1 ) + call stdlib_${ri}$symv( uplo, k-1, -one, a, lda, work, 1, zero,a( 1, k ), 1 ) - a( k, k ) = a( k, k ) - stdlib_qdot( k-1, work, 1, a( 1, k ),1 ) - a( k, k+1 ) = a( k, k+1 ) -stdlib_qdot( k-1, a( 1, k ), 1, a( 1, k+1 ), 1 ) + a( k, k ) = a( k, k ) - stdlib_${ri}$dot( k-1, work, 1, a( 1, k ),1 ) + a( k, k+1 ) = a( k, k+1 ) -stdlib_${ri}$dot( k-1, a( 1, k ), 1, a( 1, k+1 ), 1 ) - call stdlib_qcopy( k-1, a( 1, k+1 ), 1, work, 1 ) - call stdlib_qsymv( uplo, k-1, -one, a, lda, work, 1, zero,a( 1, k+1 ), 1 ) + call stdlib_${ri}$copy( k-1, a( 1, k+1 ), 1, work, 1 ) + call stdlib_${ri}$symv( uplo, k-1, -one, a, lda, work, 1, zero,a( 1, k+1 ), 1 ) - a( k+1, k+1 ) = a( k+1, k+1 ) -stdlib_qdot( k-1, work, 1, a( 1, k+1 ), 1 ) + a( k+1, k+1 ) = a( k+1, k+1 ) -stdlib_${ri}$dot( k-1, work, 1, a( 1, k+1 ), 1 ) end if kstep = 2 @@ -73819,8 +73820,8 @@ module stdlib_linalg_lapack_q if( kp/=k ) then ! interchange rows and columns k and kp in the leading ! submatrix a(1:k+1,1:k+1) - call stdlib_qswap( kp-1, a( 1, k ), 1, a( 1, kp ), 1 ) - call stdlib_qswap( k-kp-1, a( kp+1, k ), 1, a( kp, kp+1 ), lda ) + call stdlib_${ri}$swap( kp-1, a( 1, k ), 1, a( 1, kp ), 1 ) + call stdlib_${ri}$swap( k-kp-1, a( kp+1, k ), 1, a( kp, kp+1 ), lda ) temp = a( k, k ) a( k, k ) = a( kp, kp ) a( kp, kp ) = temp @@ -73847,10 +73848,10 @@ module stdlib_linalg_lapack_q a( k, k ) = one / a( k, k ) ! compute column k of the inverse. if( k1 ) then - call stdlib_qcopy( k-1, a( 1, k ), 1, work, 1 ) - call stdlib_qsymv( uplo, k-1, -one, a, lda, work, 1, zero,a( 1, k ), 1 ) + call stdlib_${ri}$copy( k-1, a( 1, k ), 1, work, 1 ) + call stdlib_${ri}$symv( uplo, k-1, -one, a, lda, work, 1, zero,a( 1, k ), 1 ) - a( k, k ) = a( k, k ) - stdlib_qdot( k-1, work, 1, a( 1, k ),1 ) + a( k, k ) = a( k, k ) - stdlib_${ri}$dot( k-1, work, 1, a( 1, k ),1 ) end if kstep = 1 else @@ -73989,16 +73990,16 @@ module stdlib_linalg_lapack_q a( k, k+1 ) = -akkp1 / d ! compute columns k and k+1 of the inverse. if( k>1 ) then - call stdlib_qcopy( k-1, a( 1, k ), 1, work, 1 ) - call stdlib_qsymv( uplo, k-1, -one, a, lda, work, 1, zero,a( 1, k ), 1 ) + call stdlib_${ri}$copy( k-1, a( 1, k ), 1, work, 1 ) + call stdlib_${ri}$symv( uplo, k-1, -one, a, lda, work, 1, zero,a( 1, k ), 1 ) - a( k, k ) = a( k, k ) - stdlib_qdot( k-1, work, 1, a( 1, k ),1 ) - a( k, k+1 ) = a( k, k+1 ) -stdlib_qdot( k-1, a( 1, k ), 1, a( 1, k+1 ), 1 ) + a( k, k ) = a( k, k ) - stdlib_${ri}$dot( k-1, work, 1, a( 1, k ),1 ) + a( k, k+1 ) = a( k, k+1 ) -stdlib_${ri}$dot( k-1, a( 1, k ), 1, a( 1, k+1 ), 1 ) - call stdlib_qcopy( k-1, a( 1, k+1 ), 1, work, 1 ) - call stdlib_qsymv( uplo, k-1, -one, a, lda, work, 1, zero,a( 1, k+1 ), 1 ) + call stdlib_${ri}$copy( k-1, a( 1, k+1 ), 1, work, 1 ) + call stdlib_${ri}$symv( uplo, k-1, -one, a, lda, work, 1, zero,a( 1, k+1 ), 1 ) - a( k+1, k+1 ) = a( k+1, k+1 ) -stdlib_qdot( k-1, work, 1, a( 1, k+1 ), 1 ) + a( k+1, k+1 ) = a( k+1, k+1 ) -stdlib_${ri}$dot( k-1, work, 1, a( 1, k+1 ), 1 ) end if kstep = 2 @@ -74008,8 +74009,8 @@ module stdlib_linalg_lapack_q ! submatrix a(1:k+1,1:k+1) kp = ipiv( k ) if( kp/=k ) then - if( kp>1 )call stdlib_qswap( kp-1, a( 1, k ), 1, a( 1, kp ), 1 ) - call stdlib_qswap( k-kp-1, a( kp+1, k ), 1, a( kp, kp+1 ), lda ) + if( kp>1 )call stdlib_${ri}$swap( kp-1, a( 1, k ), 1, a( 1, kp ), 1 ) + call stdlib_${ri}$swap( k-kp-1, a( kp+1, k ), 1, a( kp, kp+1 ), lda ) temp = a( k, k ) a( k, k ) = a( kp, kp ) a( kp, kp ) = temp @@ -74019,8 +74020,8 @@ module stdlib_linalg_lapack_q ! -ipiv(k+1)in the leading submatrix a(1:k+1,1:k+1) kp = -ipiv( k ) if( kp/=k ) then - if( kp>1 )call stdlib_qswap( kp-1, a( 1, k ), 1, a( 1, kp ), 1 ) - call stdlib_qswap( k-kp-1, a( kp+1, k ), 1, a( kp, kp+1 ), lda ) + if( kp>1 )call stdlib_${ri}$swap( kp-1, a( 1, k ), 1, a( 1, kp ), 1 ) + call stdlib_${ri}$swap( k-kp-1, a( kp+1, k ), 1, a( kp, kp+1 ), lda ) temp = a( k, k ) a( k, k ) = a( kp, kp ) a( kp, kp ) = temp @@ -74031,8 +74032,8 @@ module stdlib_linalg_lapack_q k = k + 1 kp = -ipiv( k ) if( kp/=k ) then - if( kp>1 )call stdlib_qswap( kp-1, a( 1, k ), 1, a( 1, kp ), 1 ) - call stdlib_qswap( k-kp-1, a( kp+1, k ), 1, a( kp, kp+1 ), lda ) + if( kp>1 )call stdlib_${ri}$swap( kp-1, a( 1, k ), 1, a( 1, kp ), 1 ) + call stdlib_${ri}$swap( k-kp-1, a( kp+1, k ), 1, a( kp, kp+1 ), lda ) temp = a( k, k ) a( k, k ) = a( kp, kp ) a( kp, kp ) = temp @@ -74055,10 +74056,10 @@ module stdlib_linalg_lapack_q a( k, k ) = one / a( k, k ) ! compute column k of the inverse. if( k b [ (u \p**t * b) ] - call stdlib_qtrsm('L','U','N','U',n,nrhs,one,a,lda,b,ldb) + call stdlib_${ri}$trsm('L','U','N','U',n,nrhs,one,a,lda,b,ldb) ! compute d \ b -> b [ d \ (u \p**t * b) ] i=n do while ( i >= 1 ) if( ipiv(i) > 0 ) then - call stdlib_qscal( nrhs, one / a( i, i ), b( i, 1 ), ldb ) + call stdlib_${ri}$scal( nrhs, one / a( i, i ), b( i, 1 ), ldb ) elseif ( i > 1) then if ( ipiv(i-1) == ipiv(i) ) then akm1k = work(i) @@ -74431,7 +74432,7 @@ module stdlib_linalg_lapack_q i = i - 1 end do ! compute (u**t \ b) -> b [ u**t \ (d \ (u \p**t * b) ) ] - call stdlib_qtrsm('L','U','T','U',n,nrhs,one,a,lda,b,ldb) + call stdlib_${ri}$trsm('L','U','T','U',n,nrhs,one,a,lda,b,ldb) ! p * b [ p * (u**t \ (d \ (u \p**t * b) )) ] k=1 do while ( k <= n ) @@ -74439,13 +74440,13 @@ module stdlib_linalg_lapack_q ! 1 x 1 diagonal block ! interchange rows k and ipiv(k). kp = ipiv( k ) - if( kp/=k )call stdlib_qswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib_${ri}$swap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) k=k+1 else ! 2 x 2 diagonal block ! interchange rows k-1 and -ipiv(k). kp = -ipiv( k ) - if( k < n .and. kp==-ipiv( k+1 ) )call stdlib_qswap( nrhs, b( k, 1 ), ldb, b( kp,& + if( k < n .and. kp==-ipiv( k+1 ) )call stdlib_${ri}$swap( nrhs, b( k, 1 ), ldb, b( kp,& 1 ), ldb ) k=k+2 endif @@ -74459,24 +74460,24 @@ module stdlib_linalg_lapack_q ! 1 x 1 diagonal block ! interchange rows k and ipiv(k). kp = ipiv( k ) - if( kp/=k )call stdlib_qswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib_${ri}$swap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) k=k+1 else ! 2 x 2 diagonal block ! interchange rows k and -ipiv(k+1). kp = -ipiv( k+1 ) - if( kp==-ipiv( k ) )call stdlib_qswap( nrhs, b( k+1, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp==-ipiv( k ) )call stdlib_${ri}$swap( nrhs, b( k+1, 1 ), ldb, b( kp, 1 ), ldb ) k=k+2 endif end do ! compute (l \p**t * b) -> b [ (l \p**t * b) ] - call stdlib_qtrsm('L','L','N','U',n,nrhs,one,a,lda,b,ldb) + call stdlib_${ri}$trsm('L','L','N','U',n,nrhs,one,a,lda,b,ldb) ! compute d \ b -> b [ d \ (l \p**t * b) ] i=1 do while ( i <= n ) if( ipiv(i) > 0 ) then - call stdlib_qscal( nrhs, one / a( i, i ), b( i, 1 ), ldb ) + call stdlib_${ri}$scal( nrhs, one / a( i, i ), b( i, 1 ), ldb ) else akm1k = work(i) akm1 = a( i, i ) / akm1k @@ -74493,7 +74494,7 @@ module stdlib_linalg_lapack_q i = i + 1 end do ! compute (l**t \ b) -> b [ l**t \ (d \ (l \p**t * b) ) ] - call stdlib_qtrsm('L','L','T','U',n,nrhs,one,a,lda,b,ldb) + call stdlib_${ri}$trsm('L','L','T','U',n,nrhs,one,a,lda,b,ldb) ! p * b [ p * (l**t \ (d \ (l \p**t * b) )) ] k=n do while ( k >= 1 ) @@ -74501,25 +74502,25 @@ module stdlib_linalg_lapack_q ! 1 x 1 diagonal block ! interchange rows k and ipiv(k). kp = ipiv( k ) - if( kp/=k )call stdlib_qswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib_${ri}$swap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) k=k-1 else ! 2 x 2 diagonal block ! interchange rows k-1 and -ipiv(k). kp = -ipiv( k ) - if( k>1 .and. kp==-ipiv( k-1 ) )call stdlib_qswap( nrhs, b( k, 1 ), ldb, b( kp, & + if( k>1 .and. kp==-ipiv( k-1 ) )call stdlib_${ri}$swap( nrhs, b( k, 1 ), ldb, b( kp, & 1 ), ldb ) k=k-2 endif end do end if ! revert a - call stdlib_qsyconv( uplo, 'R', n, a, lda, ipiv, work, iinfo ) + call stdlib_${ri}$syconv( uplo, 'R', n, a, lda, ipiv, work, iinfo ) return - end subroutine stdlib_qsytrs2 + end subroutine stdlib_${ri}$sytrs2 - pure subroutine stdlib_qsytrs_3( uplo, n, nrhs, a, lda, e, ipiv, b, ldb,info ) + pure subroutine stdlib_${ri}$sytrs_3( uplo, n, nrhs, a, lda, e, ipiv, b, ldb,info ) !! DSYTRS_3: solves a system of linear equations A * X = B with a real !! symmetric matrix A using the factorization computed !! by DSYTRF_RK or DSYTRF_BK: @@ -74538,14 +74539,14 @@ module stdlib_linalg_lapack_q integer(ilp), intent(in) :: lda, ldb, n, nrhs ! Array Arguments integer(ilp), intent(in) :: ipiv(*) - real(qp), intent(in) :: a(lda,*), e(*) - real(qp), intent(inout) :: b(ldb,*) + real(${rk}$), intent(in) :: a(lda,*), e(*) + real(${rk}$), intent(inout) :: b(ldb,*) ! ===================================================================== ! Local Scalars logical(lk) :: upper integer(ilp) :: i, j, k, kp - real(qp) :: ak, akm1, akm1k, bk, bkm1, denom + real(${rk}$) :: ak, akm1, akm1k, bk, bkm1, denom ! Intrinsic Functions intrinsic :: abs,max ! Executable Statements @@ -74580,16 +74581,16 @@ module stdlib_linalg_lapack_q do k = n, 1, -1 kp = abs( ipiv( k ) ) if( kp/=k ) then - call stdlib_qswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + call stdlib_${ri}$swap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) end if end do ! compute (u \p**t * b) -> b [ (u \p**t * b) ] - call stdlib_qtrsm( 'L', 'U', 'N', 'U', n, nrhs, one, a, lda, b, ldb ) + call stdlib_${ri}$trsm( 'L', 'U', 'N', 'U', n, nrhs, one, a, lda, b, ldb ) ! compute d \ b -> b [ d \ (u \p**t * b) ] i = n do while ( i>=1 ) if( ipiv( i )>0 ) then - call stdlib_qscal( nrhs, one / a( i, i ), b( i, 1 ), ldb ) + call stdlib_${ri}$scal( nrhs, one / a( i, i ), b( i, 1 ), ldb ) else if ( i>1 ) then akm1k = e( i ) akm1 = a( i-1, i-1 ) / akm1k @@ -74606,7 +74607,7 @@ module stdlib_linalg_lapack_q i = i - 1 end do ! compute (u**t \ b) -> b [ u**t \ (d \ (u \p**t * b) ) ] - call stdlib_qtrsm( 'L', 'U', 'T', 'U', n, nrhs, one, a, lda, b, ldb ) + call stdlib_${ri}$trsm( 'L', 'U', 'T', 'U', n, nrhs, one, a, lda, b, ldb ) ! p * b [ p * (u**t \ (d \ (u \p**t * b) )) ] ! interchange rows k and ipiv(k) of matrix b in reverse order ! from the formation order of ipiv(i) vector for upper case. @@ -74616,7 +74617,7 @@ module stdlib_linalg_lapack_q do k = 1, n kp = abs( ipiv( k ) ) if( kp/=k ) then - call stdlib_qswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + call stdlib_${ri}$swap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) end if end do else @@ -74631,16 +74632,16 @@ module stdlib_linalg_lapack_q do k = 1, n kp = abs( ipiv( k ) ) if( kp/=k ) then - call stdlib_qswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + call stdlib_${ri}$swap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) end if end do ! compute (l \p**t * b) -> b [ (l \p**t * b) ] - call stdlib_qtrsm( 'L', 'L', 'N', 'U', n, nrhs, one, a, lda, b, ldb ) + call stdlib_${ri}$trsm( 'L', 'L', 'N', 'U', n, nrhs, one, a, lda, b, ldb ) ! compute d \ b -> b [ d \ (l \p**t * b) ] i = 1 do while ( i<=n ) if( ipiv( i )>0 ) then - call stdlib_qscal( nrhs, one / a( i, i ), b( i, 1 ), ldb ) + call stdlib_${ri}$scal( nrhs, one / a( i, i ), b( i, 1 ), ldb ) else if( i b [ l**t \ (d \ (l \p**t * b) ) ] - call stdlib_qtrsm('L', 'L', 'T', 'U', n, nrhs, one, a, lda, b, ldb ) + call stdlib_${ri}$trsm('L', 'L', 'T', 'U', n, nrhs, one, a, lda, b, ldb ) ! p * b [ p * (l**t \ (d \ (l \p**t * b) )) ] ! interchange rows k and ipiv(k) of matrix b in reverse order ! from the formation order of ipiv(i) vector for lower case. @@ -74667,16 +74668,16 @@ module stdlib_linalg_lapack_q do k = n, 1, -1 kp = abs( ipiv( k ) ) if( kp/=k ) then - call stdlib_qswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + call stdlib_${ri}$swap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) end if end do ! end lower end if return - end subroutine stdlib_qsytrs_3 + end subroutine stdlib_${ri}$sytrs_3 - pure subroutine stdlib_qsytrs_aa( uplo, n, nrhs, a, lda, ipiv, b, ldb,work, lwork, info ) + pure subroutine stdlib_${ri}$sytrs_aa( uplo, n, nrhs, a, lda, ipiv, b, ldb,work, lwork, info ) !! DSYTRS_AA: solves a system of linear equations A*X = B with a real !! symmetric matrix A using the factorization A = U**T*T*U or !! A = L*T*L**T computed by DSYTRF_AA. @@ -74690,9 +74691,9 @@ module stdlib_linalg_lapack_q integer(ilp), intent(out) :: info ! Array Arguments integer(ilp), intent(in) :: ipiv(*) - real(qp), intent(in) :: a(lda,*) - real(qp), intent(inout) :: b(ldb,*) - real(qp), intent(out) :: work(*) + real(${rk}$), intent(in) :: a(lda,*) + real(${rk}$), intent(inout) :: b(ldb,*) + real(${rk}$), intent(out) :: work(*) ! ===================================================================== logical(lk) :: lquery, upper @@ -74733,29 +74734,29 @@ module stdlib_linalg_lapack_q ! pivot, p**t * b -> b do k = 1, n kp = ipiv( k ) - if( kp/=k )call stdlib_qswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib_${ri}$swap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) end do ! compute u**t \ b -> b [ (u**t \p**t * b) ] - call stdlib_qtrsm('L', 'U', 'T', 'U', n-1, nrhs, one, a( 1, 2 ),lda, b( 2, 1 ), & + call stdlib_${ri}$trsm('L', 'U', 'T', 'U', n-1, nrhs, one, a( 1, 2 ),lda, b( 2, 1 ), & ldb) end if ! 2) solve with triangular matrix t ! compute t \ b -> b [ t \ (u**t \p**t * b) ] - call stdlib_qlacpy( 'F', 1, n, a( 1, 1 ), lda+1, work( n ), 1) + call stdlib_${ri}$lacpy( 'F', 1, n, a( 1, 1 ), lda+1, work( n ), 1) if( n>1 ) then - call stdlib_qlacpy( 'F', 1, n-1, a( 1, 2 ), lda+1, work( 1 ), 1 ) - call stdlib_qlacpy( 'F', 1, n-1, a( 1, 2 ), lda+1, work( 2*n ), 1 ) + call stdlib_${ri}$lacpy( 'F', 1, n-1, a( 1, 2 ), lda+1, work( 1 ), 1 ) + call stdlib_${ri}$lacpy( 'F', 1, n-1, a( 1, 2 ), lda+1, work( 2*n ), 1 ) end if - call stdlib_qgtsv( n, nrhs, work( 1 ), work( n ), work( 2*n ), b, ldb,info ) + call stdlib_${ri}$gtsv( n, nrhs, work( 1 ), work( n ), work( 2*n ), b, ldb,info ) ! 3) backward substitution with u if( n>1 ) then ! compute u \ b -> b [ u \ (t \ (u**t \p**t * b) ) ] - call stdlib_qtrsm( 'L', 'U', 'N', 'U', n-1, nrhs, one, a( 1, 2 ),lda, b( 2, 1 ), & + call stdlib_${ri}$trsm( 'L', 'U', 'N', 'U', n-1, nrhs, one, a( 1, 2 ),lda, b( 2, 1 ), & ldb) ! pivot, p * b -> b [ p * (u \ (t \ (u**t \p**t * b) )) ] do k = n, 1, -1 kp = ipiv( k ) - if( kp/=k )call stdlib_qswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib_${ri}$swap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) end do end if else @@ -74765,37 +74766,37 @@ module stdlib_linalg_lapack_q ! pivot, p**t * b -> b do k = 1, n kp = ipiv( k ) - if( kp/=k )call stdlib_qswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib_${ri}$swap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) end do ! compute l \ b -> b [ (l \p**t * b) ] - call stdlib_qtrsm( 'L', 'L', 'N', 'U', n-1, nrhs, one, a( 2, 1 ),lda, b( 2, 1 ), & + call stdlib_${ri}$trsm( 'L', 'L', 'N', 'U', n-1, nrhs, one, a( 2, 1 ),lda, b( 2, 1 ), & ldb) end if ! 2) solve with triangular matrix t ! compute t \ b -> b [ t \ (l \p**t * b) ] - call stdlib_qlacpy( 'F', 1, n, a(1, 1), lda+1, work(n), 1) + call stdlib_${ri}$lacpy( 'F', 1, n, a(1, 1), lda+1, work(n), 1) if( n>1 ) then - call stdlib_qlacpy( 'F', 1, n-1, a( 2, 1 ), lda+1, work( 1 ), 1 ) - call stdlib_qlacpy( 'F', 1, n-1, a( 2, 1 ), lda+1, work( 2*n ), 1 ) + call stdlib_${ri}$lacpy( 'F', 1, n-1, a( 2, 1 ), lda+1, work( 1 ), 1 ) + call stdlib_${ri}$lacpy( 'F', 1, n-1, a( 2, 1 ), lda+1, work( 2*n ), 1 ) end if - call stdlib_qgtsv( n, nrhs, work( 1 ), work(n), work( 2*n ), b, ldb,info) + call stdlib_${ri}$gtsv( n, nrhs, work( 1 ), work(n), work( 2*n ), b, ldb,info) ! 3) backward substitution with l**t if( n>1 ) then ! compute (l**t \ b) -> b [ l**t \ (t \ (l \p**t * b) ) ] - call stdlib_qtrsm( 'L', 'L', 'T', 'U', n-1, nrhs, one, a( 2, 1 ),lda, b( 2, 1 ), & + call stdlib_${ri}$trsm( 'L', 'L', 'T', 'U', n-1, nrhs, one, a( 2, 1 ),lda, b( 2, 1 ), & ldb) ! pivot, p * b -> b [ p * (l**t \ (t \ (l \p**t * b) )) ] do k = n, 1, -1 kp = ipiv( k ) - if( kp/=k )call stdlib_qswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib_${ri}$swap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) end do end if end if return - end subroutine stdlib_qsytrs_aa + end subroutine stdlib_${ri}$sytrs_aa - pure subroutine stdlib_qsytrs_rook( uplo, n, nrhs, a, lda, ipiv, b, ldb,info ) + pure subroutine stdlib_${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. @@ -74808,14 +74809,14 @@ module stdlib_linalg_lapack_q integer(ilp), intent(in) :: lda, ldb, n, nrhs ! Array Arguments integer(ilp), intent(in) :: ipiv(*) - real(qp), intent(in) :: a(lda,*) - real(qp), intent(inout) :: b(ldb,*) + real(${rk}$), intent(in) :: a(lda,*) + real(${rk}$), intent(inout) :: b(ldb,*) ! ===================================================================== ! Local Scalars logical(lk) :: upper integer(ilp) :: j, k, kp - real(qp) :: ak, akm1, akm1k, bk, bkm1, denom + real(${rk}$) :: ak, akm1, akm1k, bk, bkm1, denom ! Intrinsic Functions intrinsic :: max ! Executable Statements @@ -74851,27 +74852,27 @@ module stdlib_linalg_lapack_q ! 1 x 1 diagonal block ! interchange rows k and ipiv(k). kp = ipiv( k ) - if( kp/=k )call stdlib_qswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib_${ri}$swap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) ! multiply by inv(u(k)), where u(k) is the transformation ! stored in column k of a. - call stdlib_qger( k-1, nrhs, -one, a( 1, k ), 1, b( k, 1 ), ldb,b( 1, 1 ), ldb ) + call stdlib_${ri}$ger( k-1, nrhs, -one, a( 1, k ), 1, b( k, 1 ), ldb,b( 1, 1 ), ldb ) ! multiply by the inverse of the diagonal block. - call stdlib_qscal( nrhs, one / a( k, k ), b( k, 1 ), ldb ) + call stdlib_${ri}$scal( nrhs, one / a( k, k ), b( k, 1 ), ldb ) k = k - 1 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_qswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib_${ri}$swap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) kp = -ipiv( k-1 ) - if( kp/=k-1 )call stdlib_qswap( nrhs, b( k-1, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k-1 )call stdlib_${ri}$swap( nrhs, b( k-1, 1 ), ldb, b( kp, 1 ), ldb ) ! multiply by inv(u(k)), where u(k) is the transformation ! stored in columns k-1 and k of a. if( k>2 ) then - call stdlib_qger( k-2, nrhs, -one, a( 1, k ), 1, b( k, 1 ),ldb, b( 1, 1 ), & + call stdlib_${ri}$ger( k-2, nrhs, -one, a( 1, k ), 1, b( k, 1 ),ldb, b( 1, 1 ), & ldb ) - call stdlib_qger( k-2, nrhs, -one, a( 1, k-1 ), 1, b( k-1, 1 ),ldb, b( 1, 1 ),& + call stdlib_${ri}$ger( k-2, nrhs, -one, a( 1, k-1 ), 1, b( k-1, 1 ),ldb, b( 1, 1 ),& ldb ) end if ! multiply by the inverse of the diagonal block. @@ -74900,27 +74901,27 @@ module stdlib_linalg_lapack_q ! 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 )call stdlib_qgemv( 'TRANSPOSE', k-1, nrhs, -one, b,ldb, a( 1, k ), 1, & + if( k>1 )call stdlib_${ri}$gemv( 'TRANSPOSE', k-1, nrhs, -one, b,ldb, a( 1, k ), 1, & one, b( k, 1 ), ldb ) ! interchange rows k and ipiv(k). kp = ipiv( k ) - if( kp/=k )call stdlib_qswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib_${ri}$swap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) k = k + 1 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 ) then - call stdlib_qgemv( 'TRANSPOSE', k-1, nrhs, -one, b,ldb, a( 1, k ), 1, one, b( & + call stdlib_${ri}$gemv( 'TRANSPOSE', k-1, nrhs, -one, b,ldb, a( 1, k ), 1, one, b( & k, 1 ), ldb ) - call stdlib_qgemv( 'TRANSPOSE', k-1, nrhs, -one, b,ldb, a( 1, k+1 ), 1, one, & + call stdlib_${ri}$gemv( 'TRANSPOSE', k-1, nrhs, -one, b,ldb, a( 1, k+1 ), 1, one, & b( k+1, 1 ), ldb ) end if ! interchange rows k and -ipiv(k) then k+1 and -ipiv(k+1). kp = -ipiv( k ) - if( kp/=k )call stdlib_qswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib_${ri}$swap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) kp = -ipiv( k+1 ) - if( kp/=k+1 )call stdlib_qswap( nrhs, b( k+1, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k+1 )call stdlib_${ri}$swap( nrhs, b( k+1, 1 ), ldb, b( kp, 1 ), ldb ) k = k + 2 end if go to 40 @@ -74938,27 +74939,27 @@ module stdlib_linalg_lapack_q ! 1 x 1 diagonal block ! interchange rows k and ipiv(k). kp = ipiv( k ) - if( kp/=k )call stdlib_qswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib_${ri}$swap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) ! multiply by inv(l(k)), where l(k) is the transformation ! stored in column k of a. - if( k 0. if( anorm>zero ) then ! estimate the norm of the inverse of a. @@ -75092,24 +75093,24 @@ module stdlib_linalg_lapack_q end if kase = 0 10 continue - call stdlib_qlacn2( n, work( n+1 ), work, iwork, ainvnm, kase, isave ) + call stdlib_${ri}$lacn2( n, work( n+1 ), work, iwork, ainvnm, kase, isave ) if( kase/=0 ) then if( kase==kase1 ) then ! multiply by inv(a). - call stdlib_qlatbs( uplo, 'NO TRANSPOSE', diag, normin, n, kd,ab, ldab, work, & + call stdlib_${ri}$latbs( uplo, 'NO TRANSPOSE', diag, normin, n, kd,ab, ldab, work, & scale, work( 2*n+1 ), info ) else ! multiply by inv(a**t). - call stdlib_qlatbs( uplo, 'TRANSPOSE', diag, normin, n, kd, ab,ldab, work, & + call stdlib_${ri}$latbs( uplo, 'TRANSPOSE', diag, normin, n, kd, ab,ldab, work, & scale, work( 2*n+1 ), info ) end if normin = 'Y' ! multiply by 1/scale if doing so will not cause overflow. if( scale/=one ) then - ix = stdlib_iqamax( n, work, 1 ) + ix = stdlib_i${ri}$amax( n, work, 1 ) xnorm = abs( work( ix ) ) if( scale a(0,0), t2 -> a(0,1), s -> a(n1,0) ! t1 -> a(0), t2 -> a(n), s -> a(n1) - call stdlib_qtrtri( 'L', diag, n1, a( 0 ), n, info ) + call stdlib_${ri}$trtri( 'L', diag, n1, a( 0 ), n, info ) if( info>0 )return - call stdlib_qtrmm( 'R', 'L', 'N', diag, n2, n1, -one, a( 0 ),n, a( n1 ), n ) + call stdlib_${ri}$trmm( 'R', 'L', 'N', diag, n2, n1, -one, a( 0 ),n, a( n1 ), n ) - call stdlib_qtrtri( 'U', diag, n2, a( n ), n, info ) + call stdlib_${ri}$trtri( 'U', diag, n2, a( n ), n, info ) if( info>0 )info = info + n1 if( info>0 )return - call stdlib_qtrmm( 'L', 'U', 'T', diag, n2, n1, one, a( n ), n,a( n1 ), n ) + call stdlib_${ri}$trmm( 'L', 'U', 'T', diag, n2, n1, one, a( n ), n,a( n1 ), n ) else ! srpa for upper, normal and n is odd ( a(0:n-1,0:n2-1) ! t1 -> a(n1+1,0), t2 -> a(n1,0), s -> a(0,0) ! t1 -> a(n2), t2 -> a(n1), s -> a(0) - call stdlib_qtrtri( 'L', diag, n1, a( n2 ), n, info ) + call stdlib_${ri}$trtri( 'L', diag, n1, a( n2 ), n, info ) if( info>0 )return - call stdlib_qtrmm( 'L', 'L', 'T', diag, n1, n2, -one, a( n2 ),n, a( 0 ), n ) + call stdlib_${ri}$trmm( 'L', 'L', 'T', diag, n1, n2, -one, a( n2 ),n, a( 0 ), n ) - call stdlib_qtrtri( 'U', diag, n2, a( n1 ), n, info ) + call stdlib_${ri}$trtri( 'U', diag, n2, a( n1 ), n, info ) if( info>0 )info = info + n1 if( info>0 )return - call stdlib_qtrmm( 'R', 'U', 'N', diag, n1, n2, one, a( n1 ),n, a( 0 ), n ) + call stdlib_${ri}$trmm( 'R', 'U', 'N', diag, n1, n2, one, a( n1 ),n, a( 0 ), n ) end if else @@ -76028,26 +76029,26 @@ module stdlib_linalg_lapack_q if( lower ) then ! srpa for lower, transpose and n is odd ! t1 -> a(0), t2 -> a(1), s -> a(0+n1*n1) - call stdlib_qtrtri( 'U', diag, n1, a( 0 ), n1, info ) + call stdlib_${ri}$trtri( 'U', diag, n1, a( 0 ), n1, info ) if( info>0 )return - call stdlib_qtrmm( 'L', 'U', 'N', diag, n1, n2, -one, a( 0 ),n1, a( n1*n1 ), & + call stdlib_${ri}$trmm( 'L', 'U', 'N', diag, n1, n2, -one, a( 0 ),n1, a( n1*n1 ), & n1 ) - call stdlib_qtrtri( 'L', diag, n2, a( 1 ), n1, info ) + call stdlib_${ri}$trtri( 'L', diag, n2, a( 1 ), n1, info ) if( info>0 )info = info + n1 if( info>0 )return - call stdlib_qtrmm( 'R', 'L', 'T', diag, n1, n2, one, a( 1 ),n1, a( n1*n1 ), & + call stdlib_${ri}$trmm( 'R', 'L', 'T', diag, n1, n2, one, a( 1 ),n1, a( n1*n1 ), & n1 ) else ! srpa for upper, transpose and n is odd ! t1 -> a(0+n2*n2), t2 -> a(0+n1*n2), s -> a(0) - call stdlib_qtrtri( 'U', diag, n1, a( n2*n2 ), n2, info ) + call stdlib_${ri}$trtri( 'U', diag, n1, a( n2*n2 ), n2, info ) if( info>0 )return - call stdlib_qtrmm( 'R', 'U', 'T', diag, n2, n1, -one,a( n2*n2 ), n2, a( 0 ), & + call stdlib_${ri}$trmm( 'R', 'U', 'T', diag, n2, n1, -one,a( n2*n2 ), n2, a( 0 ), & n2 ) - call stdlib_qtrtri( 'L', diag, n2, a( n1*n2 ), n2, info ) + call stdlib_${ri}$trtri( 'L', diag, n2, a( n1*n2 ), n2, info ) if( info>0 )info = info + n1 if( info>0 )return - call stdlib_qtrmm( 'L', 'L', 'N', diag, n2, n1, one,a( n1*n2 ), n2, a( 0 ), & + call stdlib_${ri}$trmm( 'L', 'L', 'N', diag, n2, n1, one,a( n1*n2 ), n2, a( 0 ), & n2 ) end if end if @@ -76059,27 +76060,27 @@ module stdlib_linalg_lapack_q ! srpa for lower, normal, and n is even ( a(0:n,0:k-1) ) ! t1 -> a(1,0), t2 -> a(0,0), s -> a(k+1,0) ! t1 -> a(1), t2 -> a(0), s -> a(k+1) - call stdlib_qtrtri( 'L', diag, k, a( 1 ), n+1, info ) + call stdlib_${ri}$trtri( 'L', diag, k, a( 1 ), n+1, info ) if( info>0 )return - call stdlib_qtrmm( 'R', 'L', 'N', diag, k, k, -one, a( 1 ),n+1, a( k+1 ), n+1 & + call stdlib_${ri}$trmm( 'R', 'L', 'N', diag, k, k, -one, a( 1 ),n+1, a( k+1 ), n+1 & ) - call stdlib_qtrtri( 'U', diag, k, a( 0 ), n+1, info ) + call stdlib_${ri}$trtri( 'U', diag, k, a( 0 ), n+1, info ) if( info>0 )info = info + k if( info>0 )return - call stdlib_qtrmm( 'L', 'U', 'T', diag, k, k, one, a( 0 ), n+1,a( k+1 ), n+1 ) + call stdlib_${ri}$trmm( 'L', 'U', 'T', diag, k, k, one, a( 0 ), n+1,a( k+1 ), n+1 ) else ! srpa for upper, normal, and n is even ( a(0:n,0:k-1) ) ! t1 -> a(k+1,0) , t2 -> a(k,0), s -> a(0,0) ! t1 -> a(k+1), t2 -> a(k), s -> a(0) - call stdlib_qtrtri( 'L', diag, k, a( k+1 ), n+1, info ) + call stdlib_${ri}$trtri( 'L', diag, k, a( k+1 ), n+1, info ) if( info>0 )return - call stdlib_qtrmm( 'L', 'L', 'T', diag, k, k, -one, a( k+1 ),n+1, a( 0 ), n+1 & + call stdlib_${ri}$trmm( 'L', 'L', 'T', diag, k, k, -one, a( k+1 ),n+1, a( 0 ), n+1 & ) - call stdlib_qtrtri( 'U', diag, k, a( k ), n+1, info ) + call stdlib_${ri}$trtri( 'U', diag, k, a( k ), n+1, info ) if( info>0 )info = info + k if( info>0 )return - call stdlib_qtrmm( 'R', 'U', 'N', diag, k, k, one, a( k ), n+1,a( 0 ), n+1 ) + call stdlib_${ri}$trmm( 'R', 'U', 'N', diag, k, k, one, a( k ), n+1,a( 0 ), n+1 ) end if else @@ -76088,36 +76089,36 @@ module stdlib_linalg_lapack_q ! srpa for lower, transpose and n is even (see paper) ! t1 -> b(0,1), t2 -> b(0,0), s -> b(0,k+1) ! t1 -> a(0+k), t2 -> a(0+0), s -> a(0+k*(k+1)); lda=k - call stdlib_qtrtri( 'U', diag, k, a( k ), k, info ) + call stdlib_${ri}$trtri( 'U', diag, k, a( k ), k, info ) if( info>0 )return - call stdlib_qtrmm( 'L', 'U', 'N', diag, k, k, -one, a( k ), k,a( k*( k+1 ) ), & + call stdlib_${ri}$trmm( 'L', 'U', 'N', diag, k, k, -one, a( k ), k,a( k*( k+1 ) ), & k ) - call stdlib_qtrtri( 'L', diag, k, a( 0 ), k, info ) + call stdlib_${ri}$trtri( 'L', diag, k, a( 0 ), k, info ) if( info>0 )info = info + k if( info>0 )return - call stdlib_qtrmm( 'R', 'L', 'T', diag, k, k, one, a( 0 ), k,a( k*( k+1 ) ), & + call stdlib_${ri}$trmm( 'R', 'L', 'T', diag, k, k, one, a( 0 ), k,a( k*( k+1 ) ), & k ) else ! srpa for upper, transpose and n is even (see paper) ! t1 -> b(0,k+1), t2 -> b(0,k), s -> b(0,0) ! t1 -> a(0+k*(k+1)), t2 -> a(0+k*k), s -> a(0+0)); lda=k - call stdlib_qtrtri( 'U', diag, k, a( k*( k+1 ) ), k, info ) + call stdlib_${ri}$trtri( 'U', diag, k, a( k*( k+1 ) ), k, info ) if( info>0 )return - call stdlib_qtrmm( 'R', 'U', 'T', diag, k, k, -one,a( k*( k+1 ) ), k, a( 0 ), & + call stdlib_${ri}$trmm( 'R', 'U', 'T', diag, k, k, -one,a( k*( k+1 ) ), k, a( 0 ), & k ) - call stdlib_qtrtri( 'L', diag, k, a( k*k ), k, info ) + call stdlib_${ri}$trtri( 'L', diag, k, a( k*k ), k, info ) if( info>0 )info = info + k if( info>0 )return - call stdlib_qtrmm( 'L', 'L', 'N', diag, k, k, one, a( k*k ), k,a( 0 ), k ) + call stdlib_${ri}$trmm( 'L', 'L', 'N', diag, k, k, one, a( k*k ), k,a( 0 ), k ) end if end if end if return - end subroutine stdlib_qtftri + end subroutine stdlib_${ri}$tftri - pure subroutine stdlib_qtfttp( transr, uplo, n, arf, ap, info ) + pure subroutine stdlib_${ri}$tfttp( transr, uplo, n, arf, ap, info ) !! DTFTTP: copies a triangular matrix A from rectangular full packed !! format (TF) to standard packed format (TP). ! -- lapack computational routine -- @@ -76128,8 +76129,8 @@ module stdlib_linalg_lapack_q integer(ilp), intent(out) :: info integer(ilp), intent(in) :: n ! Array Arguments - real(qp), intent(out) :: ap(0:*) - real(qp), intent(in) :: arf(0:*) + real(${rk}$), intent(out) :: ap(0:*) + real(${rk}$), intent(in) :: arf(0:*) ! ===================================================================== ! Parameters ! Local Scalars @@ -76370,10 +76371,10 @@ module stdlib_linalg_lapack_q end if end if return - end subroutine stdlib_qtfttp + end subroutine stdlib_${ri}$tfttp - pure subroutine stdlib_qtfttr( transr, uplo, n, arf, a, lda, info ) + pure subroutine stdlib_${ri}$tfttr( transr, uplo, n, arf, a, lda, info ) !! DTFTTR: copies a triangular matrix A from rectangular full packed !! format (TF) to standard full format (TR). ! -- lapack computational routine -- @@ -76384,8 +76385,8 @@ module stdlib_linalg_lapack_q integer(ilp), intent(out) :: info integer(ilp), intent(in) :: n, lda ! Array Arguments - real(qp), intent(out) :: a(0:lda-1,0:*) - real(qp), intent(in) :: arf(0:*) + real(${rk}$), intent(out) :: a(0:lda-1,0:*) + real(${rk}$), intent(in) :: arf(0:*) ! ===================================================================== ! Local Scalars logical(lk) :: lower, nisodd, normaltransr @@ -76599,10 +76600,10 @@ module stdlib_linalg_lapack_q end if end if return - end subroutine stdlib_qtfttr + end subroutine stdlib_${ri}$tfttr - pure subroutine stdlib_qtgevc( side, howmny, select, n, s, lds, p, ldp, vl,ldvl, vr, ldvr, & + pure subroutine stdlib_${ri}$tgevc( side, howmny, select, n, s, lds, p, ldp, vl,ldvl, vr, ldvr, & !! DTGEVC: computes some or all of the right and/or left eigenvectors of !! a pair of real matrices (S,P), where S is a quasi-triangular matrix !! and P is upper triangular. Matrix pairs of this type are produced by @@ -76631,23 +76632,23 @@ module stdlib_linalg_lapack_q integer(ilp), intent(in) :: ldp, lds, ldvl, ldvr, mm, n ! Array Arguments logical(lk), intent(in) :: select(*) - real(qp), intent(in) :: p(ldp,*), s(lds,*) - real(qp), intent(inout) :: vl(ldvl,*), vr(ldvr,*) - real(qp), intent(out) :: work(*) + real(${rk}$), intent(in) :: p(ldp,*), s(lds,*) + real(${rk}$), intent(inout) :: vl(ldvl,*), vr(ldvr,*) + real(${rk}$), intent(out) :: work(*) ! ===================================================================== ! Parameters - real(qp), parameter :: safety = 1.0e+2_qp + real(${rk}$), parameter :: safety = 1.0e+2_${rk}$ ! Local Scalars logical(lk) :: compl, compr, il2by2, ilabad, ilall, ilback, ilbbad, ilcomp, ilcplx, & lsa, lsb integer(ilp) :: i, ibeg, ieig, iend, ihwmny, iinfo, im, iside, j, ja, jc, je, jr, jw, & na, nw - real(qp) :: acoef, acoefa, anorm, ascale, bcoefa, bcoefi, bcoefr, big, bignum, bnorm, & + real(${rk}$) :: acoef, acoefa, anorm, ascale, bcoefa, bcoefi, bcoefr, big, bignum, bnorm, & bscale, cim2a, cim2b, cimaga, cimagb, cre2a, cre2b, creala, crealb, dmin, safmin, & salfar, sbeta, scale, small, temp, temp2, temp2i, temp2r, ulp, xmax, xscale ! Local Arrays - real(qp) :: bdiag(2), sum(2,2), sums(2,2), sump(2,2) + real(${rk}$) :: bdiag(2), sum(2,2), sums(2,2), sump(2,2) ! Intrinsic Functions intrinsic :: abs,max,min ! Executable Statements @@ -76751,10 +76752,10 @@ module stdlib_linalg_lapack_q m = im if( n==0 )return ! machine constants - safmin = stdlib_qlamch( 'SAFE MINIMUM' ) + safmin = stdlib_${ri}$lamch( 'SAFE MINIMUM' ) big = one / safmin - call stdlib_qlabad( safmin, big ) - ulp = stdlib_qlamch( 'EPSILON' )*stdlib_qlamch( 'BASE' ) + call stdlib_${ri}$labad( safmin, big ) + ulp = stdlib_${ri}$lamch( 'EPSILON' )*stdlib_${ri}$lamch( 'BASE' ) small = safmin*n / ulp big = one / small bignum = one / ( safmin*n ) @@ -76877,7 +76878,7 @@ module stdlib_linalg_lapack_q xmax = one else ! complex eigenvalue - call stdlib_qlag2( s( je, je ), lds, p( je, je ), ldp,safmin*safety, acoef, & + call stdlib_${ri}$lag2( s( je, je ), lds, p( je, je ), ldp,safmin*safety, acoef, & temp, bcoefr, temp2,bcoefi ) bcoefi = -bcoefi if( bcoefi==zero ) then @@ -76991,7 +76992,7 @@ module stdlib_linalg_lapack_q ! t ! solve ( a a - b b ) y = sum(,) ! with scaling and perturbation of the denominator - call stdlib_qlaln2( .true., na, nw, dmin, acoef, s( j, j ), lds,bdiag( 1 ), & + call stdlib_${ri}$laln2( .true., na, nw, dmin, acoef, s( j, j ), lds,bdiag( 1 ), & bdiag( 2 ), sum, 2, bcoefr,bcoefi, work( 2*n+j ), n, scale, temp,iinfo ) if( scale=sb ) then - call stdlib_qlartg( s( 1, 1 ), s( 2, 1 ), li( 1, 1 ), li( 2, 1 ),ddum ) + call stdlib_${ri}$lartg( s( 1, 1 ), s( 2, 1 ), li( 1, 1 ), li( 2, 1 ),ddum ) else - call stdlib_qlartg( t( 1, 1 ), t( 2, 1 ), li( 1, 1 ), li( 2, 1 ),ddum ) + call stdlib_${ri}$lartg( t( 1, 1 ), t( 2, 1 ), li( 1, 1 ), li( 2, 1 ),ddum ) end if - call stdlib_qrot( 2, s( 1, 1 ), ldst, s( 2, 1 ), ldst, li( 1, 1 ),li( 2, 1 ) ) + call stdlib_${ri}$rot( 2, s( 1, 1 ), ldst, s( 2, 1 ), ldst, li( 1, 1 ),li( 2, 1 ) ) - call stdlib_qrot( 2, t( 1, 1 ), ldst, t( 2, 1 ), ldst, li( 1, 1 ),li( 2, 1 ) ) + call stdlib_${ri}$rot( 2, t( 1, 1 ), ldst, t( 2, 1 ), ldst, li( 1, 1 ),li( 2, 1 ) ) li( 2, 2 ) = li( 1, 1 ) li( 1, 2 ) = -li( 2, 1 ) @@ -77450,44 +77451,44 @@ module stdlib_linalg_lapack_q ! f-norm((a-ql**h*s*qr)) <= o(eps*f-norm((a))) ! and ! f-norm((b-ql**h*t*qr)) <= o(eps*f-norm((b))) - call stdlib_qlacpy( 'FULL', m, m, a( j1, j1 ), lda, work( m*m+1 ),m ) - call stdlib_qgemm( 'N', 'N', m, m, m, one, li, ldst, s, ldst, zero,work, m ) + call stdlib_${ri}$lacpy( 'FULL', m, m, a( j1, j1 ), lda, work( m*m+1 ),m ) + call stdlib_${ri}$gemm( 'N', 'N', m, m, m, one, li, ldst, s, ldst, zero,work, m ) - call stdlib_qgemm( 'N', 'T', m, m, m, -one, work, m, ir, ldst, one,work( m*m+1 ),& + call stdlib_${ri}$gemm( 'N', 'T', m, m, m, -one, work, m, ir, ldst, one,work( m*m+1 ),& m ) dscale = zero dsum = one - call stdlib_qlassq( m*m, work( m*m+1 ), 1, dscale, dsum ) + call stdlib_${ri}$lassq( m*m, work( m*m+1 ), 1, dscale, dsum ) sa = dscale*sqrt( dsum ) - call stdlib_qlacpy( 'FULL', m, m, b( j1, j1 ), ldb, work( m*m+1 ),m ) - call stdlib_qgemm( 'N', 'N', m, m, m, one, li, ldst, t, ldst, zero,work, m ) + call stdlib_${ri}$lacpy( 'FULL', m, m, b( j1, j1 ), ldb, work( m*m+1 ),m ) + call stdlib_${ri}$gemm( 'N', 'N', m, m, m, one, li, ldst, t, ldst, zero,work, m ) - call stdlib_qgemm( 'N', 'T', m, m, m, -one, work, m, ir, ldst, one,work( m*m+1 ),& + call stdlib_${ri}$gemm( 'N', 'T', m, m, m, -one, work, m, ir, ldst, one,work( m*m+1 ),& m ) dscale = zero dsum = one - call stdlib_qlassq( m*m, work( m*m+1 ), 1, dscale, dsum ) + call stdlib_${ri}$lassq( m*m, work( m*m+1 ), 1, dscale, dsum ) sb = dscale*sqrt( dsum ) strong = sa<=thresha .and. sb<=threshb if( .not.strong )go to 70 end if ! update (a(j1:j1+m-1, m+j1:n), b(j1:j1+m-1, m+j1:n)) and ! (a(1:j1-1, j1:j1+m), b(1:j1-1, j1:j1+m)). - call stdlib_qrot( j1+1, a( 1, j1 ), 1, a( 1, j1+1 ), 1, ir( 1, 1 ),ir( 2, 1 ) ) + call stdlib_${ri}$rot( j1+1, a( 1, j1 ), 1, a( 1, j1+1 ), 1, ir( 1, 1 ),ir( 2, 1 ) ) - call stdlib_qrot( j1+1, b( 1, j1 ), 1, b( 1, j1+1 ), 1, ir( 1, 1 ),ir( 2, 1 ) ) + call stdlib_${ri}$rot( j1+1, b( 1, j1 ), 1, b( 1, j1+1 ), 1, ir( 1, 1 ),ir( 2, 1 ) ) - call stdlib_qrot( n-j1+1, a( j1, j1 ), lda, a( j1+1, j1 ), lda,li( 1, 1 ), li( 2, 1 & + call stdlib_${ri}$rot( n-j1+1, a( j1, j1 ), lda, a( j1+1, j1 ), lda,li( 1, 1 ), li( 2, 1 & ) ) - call stdlib_qrot( n-j1+1, b( j1, j1 ), ldb, b( j1+1, j1 ), ldb,li( 1, 1 ), li( 2, 1 & + call stdlib_${ri}$rot( n-j1+1, b( j1, j1 ), ldb, b( j1+1, j1 ), ldb,li( 1, 1 ), li( 2, 1 & ) ) ! set n1-by-n2 (2,1) - blocks to zero. a( j1+1, j1 ) = zero b( j1+1, j1 ) = zero ! accumulate transformations into q and z if requested. - if( wantz )call stdlib_qrot( n, z( 1, j1 ), 1, z( 1, j1+1 ), 1, ir( 1, 1 ),ir( 2, 1 & + if( wantz )call stdlib_${ri}$rot( n, z( 1, j1 ), 1, z( 1, j1+1 ), 1, ir( 1, 1 ),ir( 2, 1 & ) ) - if( wantq )call stdlib_qrot( n, q( 1, j1 ), 1, q( 1, j1+1 ), 1, li( 1, 1 ),li( 2, 1 & + if( wantq )call stdlib_${ri}$rot( n, q( 1, j1 ), 1, q( 1, j1+1 ), 1, li( 1, 1 ),li( 2, 1 & ) ) ! exit with info = 0 if swap was successfully performed. return @@ -77498,10 +77499,10 @@ module stdlib_linalg_lapack_q ! s11 * r - l * s22 = scale * s12 ! t11 * r - l * t22 = scale * t12 ! for r and l. solutions in li and ir. - call stdlib_qlacpy( 'FULL', n1, n2, t( 1, n1+1 ), ldst, li, ldst ) - call stdlib_qlacpy( 'FULL', n1, n2, s( 1, n1+1 ), ldst,ir( n2+1, n1+1 ), ldst ) + call stdlib_${ri}$lacpy( 'FULL', n1, n2, t( 1, n1+1 ), ldst, li, ldst ) + call stdlib_${ri}$lacpy( 'FULL', n1, n2, s( 1, n1+1 ), ldst,ir( n2+1, n1+1 ), ldst ) - call stdlib_qtgsy2( 'N', 0, n1, n2, s, ldst, s( n1+1, n1+1 ), ldst,ir( n2+1, n1+1 ),& + call stdlib_${ri}$tgsy2( 'N', 0, n1, n2, s, ldst, s( n1+1, n1+1 ), ldst,ir( n2+1, n1+1 ),& ldst, t, ldst, t( n1+1, n1+1 ),ldst, li, ldst, scale, dsum, dscale, iwork, idum,& linfo ) if( linfo/=0 )go to 70 @@ -77512,12 +77513,12 @@ module stdlib_linalg_lapack_q ! li = [ -l ] ! [ scale * identity(n2) ] do i = 1, n2 - call stdlib_qscal( n1, -one, li( 1, i ), 1 ) + call stdlib_${ri}$scal( n1, -one, li( 1, i ), 1 ) li( n1+i, i ) = scale end do - call stdlib_qgeqr2( m, n2, li, ldst, taul, work, linfo ) + call stdlib_${ri}$geqr2( m, n2, li, ldst, taul, work, linfo ) if( linfo/=0 )go to 70 - call stdlib_qorg2r( m, m, n2, li, ldst, taul, work, linfo ) + call stdlib_${ri}$org2r( m, m, n2, li, ldst, taul, work, linfo ) if( linfo/=0 )go to 70 ! compute orthogonal matrix rq: ! ir * rq**t = [ 0 tr], @@ -77525,103 +77526,103 @@ module stdlib_linalg_lapack_q do i = 1, n1 ir( n2+i, i ) = scale end do - call stdlib_qgerq2( n1, m, ir( n2+1, 1 ), ldst, taur, work, linfo ) + call stdlib_${ri}$gerq2( n1, m, ir( n2+1, 1 ), ldst, taur, work, linfo ) if( linfo/=0 )go to 70 - call stdlib_qorgr2( m, m, n1, ir, ldst, taur, work, linfo ) + call stdlib_${ri}$orgr2( m, m, n1, ir, ldst, taur, work, linfo ) if( linfo/=0 )go to 70 ! perform the swapping tentatively: - call stdlib_qgemm( 'T', 'N', m, m, m, one, li, ldst, s, ldst, zero,work, m ) - call stdlib_qgemm( 'N', 'T', m, m, m, one, work, m, ir, ldst, zero, s,ldst ) - call stdlib_qgemm( 'T', 'N', m, m, m, one, li, ldst, t, ldst, zero,work, m ) - call stdlib_qgemm( 'N', 'T', m, m, m, one, work, m, ir, ldst, zero, t,ldst ) - call stdlib_qlacpy( 'F', m, m, s, ldst, scpy, ldst ) - call stdlib_qlacpy( 'F', m, m, t, ldst, tcpy, ldst ) - call stdlib_qlacpy( 'F', m, m, ir, ldst, ircop, ldst ) - call stdlib_qlacpy( 'F', m, m, li, ldst, licop, ldst ) + call stdlib_${ri}$gemm( 'T', 'N', m, m, m, one, li, ldst, s, ldst, zero,work, m ) + call stdlib_${ri}$gemm( 'N', 'T', m, m, m, one, work, m, ir, ldst, zero, s,ldst ) + call stdlib_${ri}$gemm( 'T', 'N', m, m, m, one, li, ldst, t, ldst, zero,work, m ) + call stdlib_${ri}$gemm( 'N', 'T', m, m, m, one, work, m, ir, ldst, zero, t,ldst ) + call stdlib_${ri}$lacpy( 'F', m, m, s, ldst, scpy, ldst ) + call stdlib_${ri}$lacpy( 'F', m, m, t, ldst, tcpy, ldst ) + call stdlib_${ri}$lacpy( 'F', m, m, ir, ldst, ircop, ldst ) + call stdlib_${ri}$lacpy( 'F', m, m, li, ldst, licop, ldst ) ! triangularize the b-part by an rq factorization. ! apply transformation (from left) to a-part, giving s. - call stdlib_qgerq2( m, m, t, ldst, taur, work, linfo ) + call stdlib_${ri}$gerq2( m, m, t, ldst, taur, work, linfo ) if( linfo/=0 )go to 70 - call stdlib_qormr2( 'R', 'T', m, m, m, t, ldst, taur, s, ldst, work,linfo ) + call stdlib_${ri}$ormr2( 'R', 'T', m, m, m, t, ldst, taur, s, ldst, work,linfo ) if( linfo/=0 )go to 70 - call stdlib_qormr2( 'L', 'N', m, m, m, t, ldst, taur, ir, ldst, work,linfo ) + call stdlib_${ri}$ormr2( 'L', 'N', m, m, m, t, ldst, taur, ir, ldst, work,linfo ) if( linfo/=0 )go to 70 ! compute f-norm(s21) in brqa21. (t21 is 0.) dscale = zero dsum = one do i = 1, n2 - call stdlib_qlassq( n1, s( n2+1, i ), 1, dscale, dsum ) + call stdlib_${ri}$lassq( n1, s( n2+1, i ), 1, dscale, dsum ) end do brqa21 = dscale*sqrt( dsum ) ! triangularize the b-part by a qr factorization. ! apply transformation (from right) to a-part, giving s. - call stdlib_qgeqr2( m, m, tcpy, ldst, taul, work, linfo ) + call stdlib_${ri}$geqr2( m, m, tcpy, ldst, taul, work, linfo ) if( linfo/=0 )go to 70 - call stdlib_qorm2r( 'L', 'T', m, m, m, tcpy, ldst, taul, scpy, ldst,work, info ) + call stdlib_${ri}$orm2r( 'L', 'T', m, m, m, tcpy, ldst, taul, scpy, ldst,work, info ) - call stdlib_qorm2r( 'R', 'N', m, m, m, tcpy, ldst, taul, licop, ldst,work, info ) + call stdlib_${ri}$orm2r( 'R', 'N', m, m, m, tcpy, ldst, taul, licop, ldst,work, info ) if( linfo/=0 )go to 70 ! compute f-norm(s21) in bqra21. (t21 is 0.) dscale = zero dsum = one do i = 1, n2 - call stdlib_qlassq( n1, scpy( n2+1, i ), 1, dscale, dsum ) + call stdlib_${ri}$lassq( n1, scpy( n2+1, i ), 1, dscale, dsum ) end do bqra21 = dscale*sqrt( dsum ) ! decide which method to use. ! weak stability test: ! f-norm(s21) <= o(eps * f-norm((s))) if( bqra21<=brqa21 .and. bqra21<=thresha ) then - call stdlib_qlacpy( 'F', m, m, scpy, ldst, s, ldst ) - call stdlib_qlacpy( 'F', m, m, tcpy, ldst, t, ldst ) - call stdlib_qlacpy( 'F', m, m, ircop, ldst, ir, ldst ) - call stdlib_qlacpy( 'F', m, m, licop, ldst, li, ldst ) + call stdlib_${ri}$lacpy( 'F', m, m, scpy, ldst, s, ldst ) + call stdlib_${ri}$lacpy( 'F', m, m, tcpy, ldst, t, ldst ) + call stdlib_${ri}$lacpy( 'F', m, m, ircop, ldst, ir, ldst ) + call stdlib_${ri}$lacpy( 'F', m, m, licop, ldst, li, ldst ) else if( brqa21>=thresha ) then go to 70 end if ! set lower triangle of b-part to zero - if (m>1) call stdlib_qlaset( 'LOWER', m-1, m-1, zero, zero, t(2,1), ldst ) + if (m>1) call stdlib_${ri}$laset( 'LOWER', m-1, m-1, zero, zero, t(2,1), ldst ) if( wands ) then ! strong stability test: ! f-norm((a-ql**h*s*qr)) <= o(eps*f-norm((a))) ! and ! f-norm((b-ql**h*t*qr)) <= o(eps*f-norm((b))) - call stdlib_qlacpy( 'FULL', m, m, a( j1, j1 ), lda, work( m*m+1 ),m ) - call stdlib_qgemm( 'N', 'N', m, m, m, one, li, ldst, s, ldst, zero,work, m ) + call stdlib_${ri}$lacpy( 'FULL', m, m, a( j1, j1 ), lda, work( m*m+1 ),m ) + call stdlib_${ri}$gemm( 'N', 'N', m, m, m, one, li, ldst, s, ldst, zero,work, m ) - call stdlib_qgemm( 'N', 'N', m, m, m, -one, work, m, ir, ldst, one,work( m*m+1 ),& + call stdlib_${ri}$gemm( 'N', 'N', m, m, m, -one, work, m, ir, ldst, one,work( m*m+1 ),& m ) dscale = zero dsum = one - call stdlib_qlassq( m*m, work( m*m+1 ), 1, dscale, dsum ) + call stdlib_${ri}$lassq( m*m, work( m*m+1 ), 1, dscale, dsum ) sa = dscale*sqrt( dsum ) - call stdlib_qlacpy( 'FULL', m, m, b( j1, j1 ), ldb, work( m*m+1 ),m ) - call stdlib_qgemm( 'N', 'N', m, m, m, one, li, ldst, t, ldst, zero,work, m ) + call stdlib_${ri}$lacpy( 'FULL', m, m, b( j1, j1 ), ldb, work( m*m+1 ),m ) + call stdlib_${ri}$gemm( 'N', 'N', m, m, m, one, li, ldst, t, ldst, zero,work, m ) - call stdlib_qgemm( 'N', 'N', m, m, m, -one, work, m, ir, ldst, one,work( m*m+1 ),& + call stdlib_${ri}$gemm( 'N', 'N', m, m, m, -one, work, m, ir, ldst, one,work( m*m+1 ),& m ) dscale = zero dsum = one - call stdlib_qlassq( m*m, work( m*m+1 ), 1, dscale, dsum ) + call stdlib_${ri}$lassq( m*m, work( m*m+1 ), 1, dscale, dsum ) sb = dscale*sqrt( dsum ) strong = sa<=thresha .and. sb<=threshb if( .not.strong )go to 70 end if ! if the swap is accepted ("weakly" and "strongly"), apply the ! transformations and set n1-by-n2 (2,1)-block to zero. - call stdlib_qlaset( 'FULL', n1, n2, zero, zero, s(n2+1,1), ldst ) + call stdlib_${ri}$laset( 'FULL', n1, n2, zero, zero, s(n2+1,1), ldst ) ! copy back m-by-m diagonal block starting at index j1 of (a, b) - call stdlib_qlacpy( 'F', m, m, s, ldst, a( j1, j1 ), lda ) - call stdlib_qlacpy( 'F', m, m, t, ldst, b( j1, j1 ), ldb ) - call stdlib_qlaset( 'FULL', ldst, ldst, zero, zero, t, ldst ) + call stdlib_${ri}$lacpy( 'F', m, m, s, ldst, a( j1, j1 ), lda ) + call stdlib_${ri}$lacpy( 'F', m, m, t, ldst, b( j1, j1 ), ldb ) + call stdlib_${ri}$laset( 'FULL', ldst, ldst, zero, zero, t, ldst ) ! standardize existing 2-by-2 blocks. - call stdlib_qlaset( 'FULL', m, m, zero, zero, work, m ) + call stdlib_${ri}$laset( 'FULL', m, m, zero, zero, work, m ) work( 1 ) = one t( 1, 1 ) = one idum = lwork - m*m - 2 if( n2>1 ) then - call stdlib_qlagv2( a( j1, j1 ), lda, b( j1, j1 ), ldb, ar, ai, be,work( 1 ), & + call stdlib_${ri}$lagv2( a( j1, j1 ), lda, b( j1, j1 ), ldb, ar, ai, be,work( 1 ), & work( 2 ), t( 1, 1 ), t( 2, 1 ) ) work( m+1 ) = -work( 2 ) work( m+2 ) = work( 1 ) @@ -77631,7 +77632,7 @@ module stdlib_linalg_lapack_q work( m*m ) = one t( m, m ) = one if( n1>1 ) then - call stdlib_qlagv2( a( j1+n2, j1+n2 ), lda, b( j1+n2, j1+n2 ), ldb,taur, taul, & + call stdlib_${ri}$lagv2( a( j1+n2, j1+n2 ), lda, b( j1+n2, j1+n2 ), ldb,taur, taul, & work( m*m+1 ), work( n2*m+n2+1 ),work( n2*m+n2+2 ), t( n2+1, n2+1 ),t( m, m-1 ) ) work( m*m ) = work( n2*m+n2+1 ) @@ -77639,53 +77640,53 @@ module stdlib_linalg_lapack_q t( m, m ) = t( n2+1, n2+1 ) t( m-1, m ) = -t( m, m-1 ) end if - call stdlib_qgemm( 'T', 'N', n2, n1, n2, one, work, m, a( j1, j1+n2 ),lda, zero, & + call stdlib_${ri}$gemm( 'T', 'N', n2, n1, n2, one, work, m, a( j1, j1+n2 ),lda, zero, & work( m*m+1 ), n2 ) - call stdlib_qlacpy( 'FULL', n2, n1, work( m*m+1 ), n2, a( j1, j1+n2 ),lda ) - call stdlib_qgemm( 'T', 'N', n2, n1, n2, one, work, m, b( j1, j1+n2 ),ldb, zero, & + call stdlib_${ri}$lacpy( 'FULL', n2, n1, work( m*m+1 ), n2, a( j1, j1+n2 ),lda ) + call stdlib_${ri}$gemm( 'T', 'N', n2, n1, n2, one, work, m, b( j1, j1+n2 ),ldb, zero, & work( m*m+1 ), n2 ) - call stdlib_qlacpy( 'FULL', n2, n1, work( m*m+1 ), n2, b( j1, j1+n2 ),ldb ) - call stdlib_qgemm( 'N', 'N', m, m, m, one, li, ldst, work, m, zero,work( m*m+1 ), m & + call stdlib_${ri}$lacpy( 'FULL', n2, n1, work( m*m+1 ), n2, b( j1, j1+n2 ),ldb ) + call stdlib_${ri}$gemm( 'N', 'N', m, m, m, one, li, ldst, work, m, zero,work( m*m+1 ), m & ) - call stdlib_qlacpy( 'FULL', m, m, work( m*m+1 ), m, li, ldst ) - call stdlib_qgemm( 'N', 'N', n2, n1, n1, one, a( j1, j1+n2 ), lda,t( n2+1, n2+1 ), & + call stdlib_${ri}$lacpy( 'FULL', m, m, work( m*m+1 ), m, li, ldst ) + call stdlib_${ri}$gemm( 'N', 'N', n2, n1, n1, one, a( j1, j1+n2 ), lda,t( n2+1, n2+1 ), & ldst, zero, work, n2 ) - call stdlib_qlacpy( 'FULL', n2, n1, work, n2, a( j1, j1+n2 ), lda ) - call stdlib_qgemm( 'N', 'N', n2, n1, n1, one, b( j1, j1+n2 ), ldb,t( n2+1, n2+1 ), & + call stdlib_${ri}$lacpy( 'FULL', n2, n1, work, n2, a( j1, j1+n2 ), lda ) + call stdlib_${ri}$gemm( 'N', 'N', n2, n1, n1, one, b( j1, j1+n2 ), ldb,t( n2+1, n2+1 ), & ldst, zero, work, n2 ) - call stdlib_qlacpy( 'FULL', n2, n1, work, n2, b( j1, j1+n2 ), ldb ) - call stdlib_qgemm( 'T', 'N', m, m, m, one, ir, ldst, t, ldst, zero,work, m ) - call stdlib_qlacpy( 'FULL', m, m, work, m, ir, ldst ) + call stdlib_${ri}$lacpy( 'FULL', n2, n1, work, n2, b( j1, j1+n2 ), ldb ) + call stdlib_${ri}$gemm( 'T', 'N', m, m, m, one, ir, ldst, t, ldst, zero,work, m ) + call stdlib_${ri}$lacpy( 'FULL', m, m, work, m, ir, ldst ) ! accumulate transformations into q and z if requested. if( wantq ) then - call stdlib_qgemm( 'N', 'N', n, m, m, one, q( 1, j1 ), ldq, li,ldst, zero, work, & + call stdlib_${ri}$gemm( 'N', 'N', n, m, m, one, q( 1, j1 ), ldq, li,ldst, zero, work, & n ) - call stdlib_qlacpy( 'FULL', n, m, work, n, q( 1, j1 ), ldq ) + call stdlib_${ri}$lacpy( 'FULL', n, m, work, n, q( 1, j1 ), ldq ) end if if( wantz ) then - call stdlib_qgemm( 'N', 'N', n, m, m, one, z( 1, j1 ), ldz, ir,ldst, zero, work, & + call stdlib_${ri}$gemm( 'N', 'N', n, m, m, one, z( 1, j1 ), ldz, ir,ldst, zero, work, & n ) - call stdlib_qlacpy( 'FULL', n, m, work, n, z( 1, j1 ), ldz ) + call stdlib_${ri}$lacpy( 'FULL', n, m, work, n, z( 1, j1 ), ldz ) end if ! update (a(j1:j1+m-1, m+j1:n), b(j1:j1+m-1, m+j1:n)) and ! (a(1:j1-1, j1:j1+m), b(1:j1-1, j1:j1+m)). i = j1 + m if( i<=n ) then - call stdlib_qgemm( 'T', 'N', m, n-i+1, m, one, li, ldst,a( j1, i ), lda, zero, & + call stdlib_${ri}$gemm( 'T', 'N', m, n-i+1, m, one, li, ldst,a( j1, i ), lda, zero, & work, m ) - call stdlib_qlacpy( 'FULL', m, n-i+1, work, m, a( j1, i ), lda ) - call stdlib_qgemm( 'T', 'N', m, n-i+1, m, one, li, ldst,b( j1, i ), ldb, zero, & + call stdlib_${ri}$lacpy( 'FULL', m, n-i+1, work, m, a( j1, i ), lda ) + call stdlib_${ri}$gemm( 'T', 'N', m, n-i+1, m, one, li, ldst,b( j1, i ), ldb, zero, & work, m ) - call stdlib_qlacpy( 'FULL', m, n-i+1, work, m, b( j1, i ), ldb ) + call stdlib_${ri}$lacpy( 'FULL', m, n-i+1, work, m, b( j1, i ), ldb ) end if i = j1 - 1 if( i>0 ) then - call stdlib_qgemm( 'N', 'N', i, m, m, one, a( 1, j1 ), lda, ir,ldst, zero, work, & + call stdlib_${ri}$gemm( 'N', 'N', i, m, m, one, a( 1, j1 ), lda, ir,ldst, zero, work, & i ) - call stdlib_qlacpy( 'FULL', i, m, work, i, a( 1, j1 ), lda ) - call stdlib_qgemm( 'N', 'N', i, m, m, one, b( 1, j1 ), ldb, ir,ldst, zero, work, & + call stdlib_${ri}$lacpy( 'FULL', i, m, work, i, a( 1, j1 ), lda ) + call stdlib_${ri}$gemm( 'N', 'N', i, m, m, one, b( 1, j1 ), ldb, ir,ldst, zero, work, & i ) - call stdlib_qlacpy( 'FULL', i, m, work, i, b( 1, j1 ), ldb ) + call stdlib_${ri}$lacpy( 'FULL', i, m, work, i, b( 1, j1 ), ldb ) end if ! exit with info = 0 if swap was successfully performed. return @@ -77694,10 +77695,10 @@ module stdlib_linalg_lapack_q 70 continue info = 1 return - end subroutine stdlib_qtgex2 + end subroutine stdlib_${ri}$tgex2 - pure subroutine stdlib_qtgexc( wantq, wantz, n, a, lda, b, ldb, q, ldq, z,ldz, ifst, ilst, & + pure subroutine stdlib_${ri}$tgexc( wantq, wantz, n, a, lda, b, ldb, q, ldq, z,ldz, ifst, ilst, & !! DTGEXC: reorders the generalized real Schur decomposition of a real !! matrix pair (A,B) using an orthogonal equivalence transformation !! (A, B) = Q * (A, B) * Z**T, @@ -77720,8 +77721,8 @@ module stdlib_linalg_lapack_q integer(ilp), intent(out) :: info integer(ilp), intent(in) :: lda, ldb, ldq, ldz, lwork, n ! Array Arguments - real(qp), intent(inout) :: a(lda,*), b(ldb,*), q(ldq,*), z(ldz,*) - real(qp), intent(out) :: work(*) + real(${rk}$), intent(inout) :: a(lda,*), b(ldb,*), q(ldq,*), z(ldz,*) + real(${rk}$), intent(out) :: work(*) ! ===================================================================== ! Local Scalars @@ -77799,7 +77800,7 @@ module stdlib_linalg_lapack_q if( here+nbf+1<=n ) then if( a( here+nbf+1, here+nbf )/=zero )nbnext = 2 end if - call stdlib_qtgex2( wantq, wantz, n, a, lda, b, ldb, q, ldq, z,ldz, here, nbf, & + call stdlib_${ri}$tgex2( wantq, wantz, n, a, lda, b, ldb, q, ldq, z,ldz, here, nbf, & nbnext, work, lwork, info ) if( info/=0 ) then ilst = here @@ -77817,7 +77818,7 @@ module stdlib_linalg_lapack_q if( here+3<=n ) then if( a( here+3, here+2 )/=zero )nbnext = 2 end if - call stdlib_qtgex2( wantq, wantz, n, a, lda, b, ldb, q, ldq, z,ldz, here+1, 1, & + call stdlib_${ri}$tgex2( wantq, wantz, n, a, lda, b, ldb, q, ldq, z,ldz, here+1, 1, & nbnext, work, lwork, info ) if( info/=0 ) then ilst = here @@ -77825,7 +77826,7 @@ module stdlib_linalg_lapack_q end if if( nbnext==1 ) then ! swap two 1-by-1 blocks. - call stdlib_qtgex2( wantq, wantz, n, a, lda, b, ldb, q, ldq, z,ldz, here, 1, & + call stdlib_${ri}$tgex2( wantq, wantz, n, a, lda, b, ldb, q, ldq, z,ldz, here, 1, & 1, work, lwork, info ) if( info/=0 ) then ilst = here @@ -77837,7 +77838,7 @@ module stdlib_linalg_lapack_q if( a( here+2, here+1 )==zero )nbnext = 1 if( nbnext==2 ) then ! 2-by-2 block did not split. - call stdlib_qtgex2( wantq, wantz, n, a, lda, b, ldb, q, ldq,z, ldz, here, & + call stdlib_${ri}$tgex2( wantq, wantz, n, a, lda, b, ldb, q, ldq,z, ldz, here, & 1, nbnext, work, lwork,info ) if( info/=0 ) then ilst = here @@ -77846,14 +77847,14 @@ module stdlib_linalg_lapack_q here = here + 2 else ! 2-by-2 block did split. - call stdlib_qtgex2( wantq, wantz, n, a, lda, b, ldb, q, ldq,z, ldz, here, & + call stdlib_${ri}$tgex2( wantq, wantz, n, a, lda, b, ldb, q, ldq,z, ldz, here, & 1, 1, work, lwork, info ) if( info/=0 ) then ilst = here return end if here = here + 1 - call stdlib_qtgex2( wantq, wantz, n, a, lda, b, ldb, q, ldq,z, ldz, here, & + call stdlib_${ri}$tgex2( wantq, wantz, n, a, lda, b, ldb, q, ldq,z, ldz, here, & 1, 1, work, lwork, info ) if( info/=0 ) then ilst = here @@ -77874,7 +77875,7 @@ module stdlib_linalg_lapack_q if( here>=3 ) then if( a( here-1, here-2 )/=zero )nbnext = 2 end if - call stdlib_qtgex2( wantq, wantz, n, a, lda, b, ldb, q, ldq, z,ldz, here-nbnext, & + call stdlib_${ri}$tgex2( wantq, wantz, n, a, lda, b, ldb, q, ldq, z,ldz, here-nbnext, & nbnext, nbf, work, lwork,info ) if( info/=0 ) then ilst = here @@ -77892,7 +77893,7 @@ module stdlib_linalg_lapack_q if( here>=3 ) then if( a( here-1, here-2 )/=zero )nbnext = 2 end if - call stdlib_qtgex2( wantq, wantz, n, a, lda, b, ldb, q, ldq, z,ldz, here-nbnext, & + call stdlib_${ri}$tgex2( wantq, wantz, n, a, lda, b, ldb, q, ldq, z,ldz, here-nbnext, & nbnext, 1, work, lwork,info ) if( info/=0 ) then ilst = here @@ -77900,7 +77901,7 @@ module stdlib_linalg_lapack_q end if if( nbnext==1 ) then ! swap two 1-by-1 blocks. - call stdlib_qtgex2( wantq, wantz, n, a, lda, b, ldb, q, ldq, z,ldz, here, & + call stdlib_${ri}$tgex2( wantq, wantz, n, a, lda, b, ldb, q, ldq, z,ldz, here, & nbnext, 1, work, lwork, info ) if( info/=0 ) then ilst = here @@ -77912,7 +77913,7 @@ module stdlib_linalg_lapack_q if( a( here, here-1 )==zero )nbnext = 1 if( nbnext==2 ) then ! 2-by-2 block did not split. - call stdlib_qtgex2( wantq, wantz, n, a, lda, b, ldb, q, ldq,z, ldz, here-1,& + call stdlib_${ri}$tgex2( wantq, wantz, n, a, lda, b, ldb, q, ldq,z, ldz, here-1,& 2, 1, work, lwork, info ) if( info/=0 ) then ilst = here @@ -77921,14 +77922,14 @@ module stdlib_linalg_lapack_q here = here - 2 else ! 2-by-2 block did split. - call stdlib_qtgex2( wantq, wantz, n, a, lda, b, ldb, q, ldq,z, ldz, here, & + call stdlib_${ri}$tgex2( wantq, wantz, n, a, lda, b, ldb, q, ldq,z, ldz, here, & 1, 1, work, lwork, info ) if( info/=0 ) then ilst = here return end if here = here - 1 - call stdlib_qtgex2( wantq, wantz, n, a, lda, b, ldb, q, ldq,z, ldz, here, & + call stdlib_${ri}$tgex2( wantq, wantz, n, a, lda, b, ldb, q, ldq,z, ldz, here, & 1, 1, work, lwork, info ) if( info/=0 ) then ilst = here @@ -77943,10 +77944,10 @@ module stdlib_linalg_lapack_q ilst = here work( 1 ) = lwmin return - end subroutine stdlib_qtgexc + end subroutine stdlib_${ri}$tgexc - pure subroutine stdlib_qtgsen( ijob, wantq, wantz, select, n, a, lda, b, ldb,alphar, alphai, & + pure subroutine stdlib_${ri}$tgsen( ijob, wantq, wantz, select, n, a, lda, b, ldb,alphar, alphai, & !! DTGSEN: reorders the generalized real Schur decomposition of a real !! matrix pair (A, B) (in terms of an orthonormal equivalence trans- !! formation Q**T * (A, B) * Z), so that a selected cluster of eigenvalues @@ -77975,12 +77976,12 @@ module stdlib_linalg_lapack_q logical(lk), intent(in) :: wantq, wantz integer(ilp), intent(in) :: ijob, lda, ldb, ldq, ldz, liwork, lwork, n integer(ilp), intent(out) :: info, m - real(qp), intent(out) :: pl, pr + real(${rk}$), intent(out) :: pl, pr ! Array Arguments logical(lk), intent(in) :: select(*) integer(ilp), intent(out) :: iwork(*) - real(qp), intent(inout) :: a(lda,*), b(ldb,*), q(ldq,*), z(ldz,*) - real(qp), intent(out) :: alphai(*), alphar(*), beta(*), dif(*), work(*) + real(${rk}$), intent(inout) :: a(lda,*), b(ldb,*), q(ldq,*), z(ldz,*) + real(${rk}$), intent(out) :: alphai(*), alphar(*), beta(*), dif(*), work(*) ! ===================================================================== ! Parameters integer(ilp), parameter :: idifjb = 3 @@ -77989,7 +77990,7 @@ module stdlib_linalg_lapack_q ! Local Scalars logical(lk) :: lquery, pair, swap, wantd, wantd1, wantd2, wantp integer(ilp) :: i, ierr, ijb, k, kase, kk, ks, liwmin, lwmin, mn2, n1, n2 - real(qp) :: dscale, dsum, eps, rdscal, smlnum + real(${rk}$) :: dscale, dsum, eps, rdscal, smlnum ! Local Arrays integer(ilp) :: isave(3) ! Intrinsic Functions @@ -78016,8 +78017,8 @@ module stdlib_linalg_lapack_q return end if ! get machine constants - eps = stdlib_qlamch( 'P' ) - smlnum = stdlib_qlamch( 'S' ) / eps + eps = stdlib_${ri}$lamch( 'P' ) + smlnum = stdlib_${ri}$lamch( 'S' ) / eps ierr = 0 wantp = ijob==1 .or. ijob>=4 wantd1 = ijob==2 .or. ijob==4 @@ -78078,8 +78079,8 @@ module stdlib_linalg_lapack_q dscale = zero dsum = one do i = 1, n - call stdlib_qlassq( n, a( 1, i ), 1, dscale, dsum ) - call stdlib_qlassq( n, b( 1, i ), 1, dscale, dsum ) + call stdlib_${ri}$lassq( n, a( 1, i ), 1, dscale, dsum ) + call stdlib_${ri}$lassq( n, b( 1, i ), 1, dscale, dsum ) end do dif( 1 ) = dscale*sqrt( dsum ) dif( 2 ) = dif( 1 ) @@ -78107,7 +78108,7 @@ module stdlib_linalg_lapack_q ! by orthogonal transformation matrices and update ! q and z accordingly (if requested): kk = k - if( k/=ks )call stdlib_qtgexc( wantq, wantz, n, a, lda, b, ldb, q, ldq,z, ldz,& + if( k/=ks )call stdlib_${ri}$tgexc( wantq, wantz, n, a, lda, b, ldb, q, ldq,z, ldz,& kk, ks, work, lwork, ierr ) if( ierr>0 ) then ! swap is rejected: exit. @@ -78133,16 +78134,16 @@ module stdlib_linalg_lapack_q n2 = n - m i = n1 + 1 ijb = 0 - call stdlib_qlacpy( 'FULL', n1, n2, a( 1, i ), lda, work, n1 ) - call stdlib_qlacpy( 'FULL', n1, n2, b( 1, i ), ldb, work( n1*n2+1 ),n1 ) - call stdlib_qtgsyl( 'N', ijb, n1, n2, a, lda, a( i, i ), lda, work,n1, b, ldb, b( i,& + call stdlib_${ri}$lacpy( 'FULL', n1, n2, a( 1, i ), lda, work, n1 ) + call stdlib_${ri}$lacpy( 'FULL', n1, n2, b( 1, i ), ldb, work( n1*n2+1 ),n1 ) + call stdlib_${ri}$tgsyl( 'N', ijb, n1, n2, a, lda, a( i, i ), lda, work,n1, b, ldb, b( i,& i ), ldb, work( n1*n2+1 ), n1,dscale, dif( 1 ), work( n1*n2*2+1 ),lwork-2*n1*n2, & iwork, ierr ) ! estimate the reciprocal of norms of "projections" onto left ! and right eigenspaces. rdscal = zero dsum = one - call stdlib_qlassq( n1*n2, work, 1, rdscal, dsum ) + call stdlib_${ri}$lassq( n1*n2, work, 1, rdscal, dsum ) pl = rdscal*sqrt( dsum ) if( pl==zero ) then pl = one @@ -78151,7 +78152,7 @@ module stdlib_linalg_lapack_q end if rdscal = zero dsum = one - call stdlib_qlassq( n1*n2, work( n1*n2+1 ), 1, rdscal, dsum ) + call stdlib_${ri}$lassq( n1*n2, work( n1*n2+1 ), 1, rdscal, dsum ) pr = rdscal*sqrt( dsum ) if( pr==zero ) then pr = one @@ -78167,16 +78168,16 @@ module stdlib_linalg_lapack_q i = n1 + 1 ijb = idifjb ! frobenius norm-based difu-estimate. - call stdlib_qtgsyl( 'N', ijb, n1, n2, a, lda, a( i, i ), lda, work,n1, b, ldb, b(& + call stdlib_${ri}$tgsyl( 'N', ijb, n1, n2, a, lda, a( i, i ), lda, work,n1, b, ldb, b(& i, i ), ldb, work( n1*n2+1 ),n1, dscale, dif( 1 ), work( 2*n1*n2+1 ),lwork-& 2*n1*n2, iwork, ierr ) ! frobenius norm-based difl-estimate. - call stdlib_qtgsyl( 'N', ijb, n2, n1, a( i, i ), lda, a, lda, work,n2, b( i, i ),& + call stdlib_${ri}$tgsyl( 'N', ijb, n2, n1, a( i, i ), lda, a, lda, work,n2, b( i, i ),& ldb, b, ldb, work( n1*n2+1 ),n2, dscale, dif( 2 ), work( 2*n1*n2+1 ),lwork-& 2*n1*n2, iwork, ierr ) else ! compute 1-norm-based estimates of difu and difl using - ! reversed communication with stdlib_qlacn2. in each step a + ! reversed communication with stdlib_${ri}$lacn2. in each step a ! generalized sylvester equation or a transposed variant ! is solved. kase = 0 @@ -78187,17 +78188,17 @@ module stdlib_linalg_lapack_q mn2 = 2*n1*n2 ! 1-norm-based estimate of difu. 40 continue - call stdlib_qlacn2( mn2, work( mn2+1 ), work, iwork, dif( 1 ),kase, isave ) + call stdlib_${ri}$lacn2( mn2, work( mn2+1 ), work, iwork, dif( 1 ),kase, isave ) if( kase/=0 ) then if( kase==1 ) then ! solve generalized sylvester equation. - call stdlib_qtgsyl( 'N', ijb, n1, n2, a, lda, a( i, i ), lda,work, n1, b, & + call stdlib_${ri}$tgsyl( 'N', ijb, n1, n2, a, lda, a( i, i ), lda,work, n1, b, & ldb, b( i, i ), ldb,work( n1*n2+1 ), n1, dscale, dif( 1 ),work( 2*n1*n2+1 )& , lwork-2*n1*n2, iwork,ierr ) else ! solve the transposed variant. - call stdlib_qtgsyl( 'T', ijb, n1, n2, a, lda, a( i, i ), lda,work, n1, b, & + call stdlib_${ri}$tgsyl( 'T', ijb, n1, n2, a, lda, a( i, i ), lda,work, n1, b, & ldb, b( i, i ), ldb,work( n1*n2+1 ), n1, dscale, dif( 1 ),work( 2*n1*n2+1 )& , lwork-2*n1*n2, iwork,ierr ) end if @@ -78206,17 +78207,17 @@ module stdlib_linalg_lapack_q dif( 1 ) = dscale / dif( 1 ) ! 1-norm-based estimate of difl. 50 continue - call stdlib_qlacn2( mn2, work( mn2+1 ), work, iwork, dif( 2 ),kase, isave ) + call stdlib_${ri}$lacn2( mn2, work( mn2+1 ), work, iwork, dif( 2 ),kase, isave ) if( kase/=0 ) then if( kase==1 ) then ! solve generalized sylvester equation. - call stdlib_qtgsyl( 'N', ijb, n2, n1, a( i, i ), lda, a, lda,work, n2, b( & + call stdlib_${ri}$tgsyl( 'N', ijb, n2, n1, a( i, i ), lda, a, lda,work, n2, b( & i, i ), ldb, b, ldb,work( n1*n2+1 ), n2, dscale, dif( 2 ),work( 2*n1*n2+1 )& , lwork-2*n1*n2, iwork,ierr ) else ! solve the transposed variant. - call stdlib_qtgsyl( 'T', ijb, n2, n1, a( i, i ), lda, a, lda,work, n2, b( & + call stdlib_${ri}$tgsyl( 'T', ijb, n2, n1, a( i, i ), lda, a, lda,work, n2, b( & i, i ), ldb, b, ldb,work( n1*n2+1 ), n2, dscale, dif( 2 ),work( 2*n1*n2+1 )& , lwork-2*n1*n2, iwork,ierr ) end if @@ -78248,7 +78249,7 @@ module stdlib_linalg_lapack_q work( 6 ) = b( k+1, k ) work( 7 ) = b( k, k+1 ) work( 8 ) = b( k+1, k+1 ) - call stdlib_qlag2( work, 2, work( 5 ), 2, smlnum*eps, beta( k ),beta( k+1 ), & + call stdlib_${ri}$lag2( work, 2, work( 5 ), 2, smlnum*eps, beta( k ),beta( k+1 ), & alphar( k ), alphar( k+1 ),alphai( k ) ) alphai( k+1 ) = -alphai( k ) else @@ -78269,10 +78270,10 @@ module stdlib_linalg_lapack_q work( 1 ) = lwmin iwork( 1 ) = liwmin return - end subroutine stdlib_qtgsen + end subroutine stdlib_${ri}$tgsen - pure subroutine stdlib_qtgsja( jobu, jobv, jobq, m, p, n, k, l, a, lda, b,ldb, tola, tolb, & + pure subroutine stdlib_${ri}$tgsja( jobu, jobv, jobq, m, p, n, k, l, a, lda, b,ldb, tola, tolb, & !! DTGSJA: computes the generalized singular value decomposition (GSVD) !! of two real upper triangular (or trapezoidal) matrices A and B. !! On entry, it is assumed that matrices A and B have the following @@ -78342,20 +78343,20 @@ module stdlib_linalg_lapack_q character, intent(in) :: jobq, jobu, jobv integer(ilp), intent(out) :: info, ncycle integer(ilp), intent(in) :: k, l, lda, ldb, ldq, ldu, ldv, m, n, p - real(qp), intent(in) :: tola, tolb + real(${rk}$), intent(in) :: tola, tolb ! Array Arguments - real(qp), intent(inout) :: a(lda,*), b(ldb,*), q(ldq,*), u(ldu,*), v(ldv,*) - real(qp), intent(out) :: alpha(*), beta(*), work(*) + real(${rk}$), intent(inout) :: a(lda,*), b(ldb,*), q(ldq,*), u(ldu,*), v(ldv,*) + real(${rk}$), intent(out) :: alpha(*), beta(*), work(*) ! ===================================================================== ! Parameters integer(ilp), parameter :: maxit = 40 - real(qp), parameter :: hugenum = huge(zero) + real(${rk}$), parameter :: hugenum = huge(zero) ! Local Scalars logical(lk) :: initq, initu, initv, upper, wantq, wantu, wantv integer(ilp) :: i, j, kcycle - real(qp) :: a1, a2, a3, b1, b2, b3, csq, csu, csv, error, gamma, rwk, snq, snu, snv, & + real(${rk}$) :: a1, a2, a3, b1, b2, b3, csq, csu, csv, error, gamma, rwk, snq, snu, snv, & ssmin ! Intrinsic Functions intrinsic :: abs,max,min,huge @@ -78396,9 +78397,9 @@ module stdlib_linalg_lapack_q return end if ! initialize u, v and q, if necessary - if( initu )call stdlib_qlaset( 'FULL', m, m, zero, one, u, ldu ) - if( initv )call stdlib_qlaset( 'FULL', p, p, zero, one, v, ldv ) - if( initq )call stdlib_qlaset( 'FULL', n, n, zero, one, q, ldq ) + if( initu )call stdlib_${ri}$laset( 'FULL', m, m, zero, one, u, ldu ) + if( initv )call stdlib_${ri}$laset( 'FULL', p, p, zero, one, v, ldv ) + if( initq )call stdlib_${ri}$laset( 'FULL', n, n, zero, one, q, ldq ) ! loop until convergence upper = .false. loop_40: do kcycle = 1, maxit @@ -78419,18 +78420,18 @@ module stdlib_linalg_lapack_q if( k+j<=m )a2 = a( k+j, n-l+i ) b2 = b( j, n-l+i ) end if - call stdlib_qlags2( upper, a1, a2, a3, b1, b2, b3, csu, snu,csv, snv, csq, & + call stdlib_${ri}$lags2( upper, a1, a2, a3, b1, b2, b3, csu, snu,csv, snv, csq, & snq ) ! update (k+i)-th and (k+j)-th rows of matrix a: u**t *a - if( k+j<=m )call stdlib_qrot( l, a( k+j, n-l+1 ), lda, a( k+i, n-l+1 ),lda, & + if( k+j<=m )call stdlib_${ri}$rot( l, a( k+j, n-l+1 ), lda, a( k+i, n-l+1 ),lda, & csu, snu ) ! update i-th and j-th rows of matrix b: v**t *b - call stdlib_qrot( l, b( j, n-l+1 ), ldb, b( i, n-l+1 ), ldb,csv, snv ) + call stdlib_${ri}$rot( l, b( j, n-l+1 ), ldb, b( i, n-l+1 ), ldb,csv, snv ) ! update (n-l+i)-th and (n-l+j)-th columns of matrices ! a and b: a*q and b*q - call stdlib_qrot( min( k+l, m ), a( 1, n-l+j ), 1,a( 1, n-l+i ), 1, csq, snq ) + call stdlib_${ri}$rot( min( k+l, m ), a( 1, n-l+j ), 1,a( 1, n-l+i ), 1, csq, snq ) - call stdlib_qrot( l, b( 1, n-l+j ), 1, b( 1, n-l+i ), 1, csq,snq ) + call stdlib_${ri}$rot( l, b( 1, n-l+j ), 1, b( 1, n-l+i ), 1, csq,snq ) if( upper ) then if( k+i<=m )a( k+i, n-l+j ) = zero b( i, n-l+j ) = zero @@ -78439,10 +78440,10 @@ module stdlib_linalg_lapack_q b( j, n-l+i ) = zero end if ! update orthogonal matrices u, v, q, if desired. - if( wantu .and. k+j<=m )call stdlib_qrot( m, u( 1, k+j ), 1, u( 1, k+i ), 1, & + if( wantu .and. k+j<=m )call stdlib_${ri}$rot( m, u( 1, k+j ), 1, u( 1, k+i ), 1, & csu,snu ) - if( wantv )call stdlib_qrot( p, v( 1, j ), 1, v( 1, i ), 1, csv, snv ) - if( wantq )call stdlib_qrot( n, q( 1, n-l+j ), 1, q( 1, n-l+i ), 1, csq,snq ) + if( wantv )call stdlib_${ri}$rot( p, v( 1, j ), 1, v( 1, i ), 1, csv, snv ) + if( wantq )call stdlib_${ri}$rot( n, q( 1, n-l+j ), 1, q( 1, n-l+i ), 1, csq,snq ) end do loop_10 end do loop_20 @@ -78453,9 +78454,9 @@ module stdlib_linalg_lapack_q ! rows of a and b. error = zero do i = 1, min( l, m-k ) - call stdlib_qcopy( l-i+1, a( k+i, n-l+i ), lda, work, 1 ) - call stdlib_qcopy( l-i+1, b( i, n-l+i ), ldb, work( l+1 ), 1 ) - call stdlib_qlapll( l-i+1, work, 1, work( l+1 ), 1, ssmin ) + call stdlib_${ri}$copy( l-i+1, a( k+i, n-l+i ), lda, work, 1 ) + call stdlib_${ri}$copy( l-i+1, b( i, n-l+i ), ldb, work( l+1 ), 1 ) + call stdlib_${ri}$lapll( l-i+1, work, 1, work( l+1 ), 1, ssmin ) error = max( error, ssmin ) end do if( abs( error )<=min( tola, tolb ) )go to 50 @@ -78480,20 +78481,20 @@ module stdlib_linalg_lapack_q if( (gamma<=hugenum).and.(gamma>=-hugenum) ) then ! change sign if necessary if( gamma=beta( k+i ) ) then - call stdlib_qscal( l-i+1, one / alpha( k+i ), a( k+i, n-l+i ),lda ) + call stdlib_${ri}$scal( l-i+1, one / alpha( k+i ), a( k+i, n-l+i ),lda ) else - call stdlib_qscal( l-i+1, one / beta( k+i ), b( i, n-l+i ),ldb ) - call stdlib_qcopy( l-i+1, b( i, n-l+i ), ldb, a( k+i, n-l+i ),lda ) + call stdlib_${ri}$scal( l-i+1, one / beta( k+i ), b( i, n-l+i ),ldb ) + call stdlib_${ri}$copy( l-i+1, b( i, n-l+i ), ldb, a( k+i, n-l+i ),lda ) end if else alpha( k+i ) = zero beta( k+i ) = one - call stdlib_qcopy( l-i+1, b( i, n-l+i ), ldb, a( k+i, n-l+i ),lda ) + call stdlib_${ri}$copy( l-i+1, b( i, n-l+i ), ldb, a( k+i, n-l+i ),lda ) end if end do ! post-assignment @@ -78510,10 +78511,10 @@ module stdlib_linalg_lapack_q 100 continue ncycle = kcycle return - end subroutine stdlib_qtgsja + end subroutine stdlib_${ri}$tgsja - pure subroutine stdlib_qtgsna( job, howmny, select, n, a, lda, b, ldb, vl,ldvl, vr, ldvr, s, & + pure subroutine stdlib_${ri}$tgsna( job, howmny, select, n, a, lda, b, ldb, vl,ldvl, vr, ldvr, s, & !! DTGSNA: estimates reciprocal condition numbers for specified !! eigenvalues and/or eigenvectors of a matrix pair (A, B) in !! generalized real Schur canonical form (or of any matrix pair @@ -78533,8 +78534,8 @@ module stdlib_linalg_lapack_q ! Array Arguments logical(lk), intent(in) :: select(*) integer(ilp), intent(out) :: iwork(*) - real(qp), intent(in) :: a(lda,*), b(ldb,*), vl(ldvl,*), vr(ldvr,*) - real(qp), intent(out) :: dif(*), s(*), work(*) + real(${rk}$), intent(in) :: a(lda,*), b(ldb,*), vl(ldvl,*), vr(ldvr,*) + real(${rk}$), intent(out) :: dif(*), s(*), work(*) ! ===================================================================== ! Parameters integer(ilp), parameter :: difdri = 3 @@ -78543,10 +78544,10 @@ module stdlib_linalg_lapack_q ! Local Scalars logical(lk) :: lquery, pair, somcon, wantbh, wantdf, wants integer(ilp) :: i, ierr, ifst, ilst, iz, k, ks, lwmin, n1, n2 - real(qp) :: alphai, alphar, alprqt, beta, c1, c2, cond, eps, lnrm, rnrm, root1, root2, & + real(${rk}$) :: alphai, alphar, alprqt, beta, c1, c2, cond, eps, lnrm, rnrm, root1, root2, & scale, smlnum, tmpii, tmpir, tmpri, tmprr, uhav, uhavi, uhbv, uhbvi ! Local Arrays - real(qp) :: dummy(1), dummy1(1) + real(${rk}$) :: dummy(1), dummy1(1) ! Intrinsic Functions intrinsic :: max,min,sqrt ! Executable Statements @@ -78619,8 +78620,8 @@ module stdlib_linalg_lapack_q ! quick return if possible if( n==0 )return ! get machine constants - eps = stdlib_qlamch( 'P' ) - smlnum = stdlib_qlamch( 'S' ) / eps + eps = stdlib_${ri}$lamch( 'P' ) + smlnum = stdlib_${ri}$lamch( 'S' ) / eps ks = 0 pair = .false. loop_20: do k = 1, n @@ -78646,46 +78647,46 @@ module stdlib_linalg_lapack_q ! eigenvalue. if( pair ) then ! complex eigenvalue pair. - rnrm = stdlib_qlapy2( stdlib_qnrm2( n, vr( 1, ks ), 1 ),stdlib_qnrm2( n, vr( & + rnrm = stdlib_${ri}$lapy2( stdlib_${ri}$nrm2( n, vr( 1, ks ), 1 ),stdlib_${ri}$nrm2( n, vr( & 1, ks+1 ), 1 ) ) - lnrm = stdlib_qlapy2( stdlib_qnrm2( n, vl( 1, ks ), 1 ),stdlib_qnrm2( n, vl( & + lnrm = stdlib_${ri}$lapy2( stdlib_${ri}$nrm2( n, vl( 1, ks ), 1 ),stdlib_${ri}$nrm2( n, vl( & 1, ks+1 ), 1 ) ) - call stdlib_qgemv( 'N', n, n, one, a, lda, vr( 1, ks ), 1, zero,work, 1 ) + call stdlib_${ri}$gemv( 'N', n, n, one, a, lda, vr( 1, ks ), 1, zero,work, 1 ) - tmprr = stdlib_qdot( n, work, 1, vl( 1, ks ), 1 ) - tmpri = stdlib_qdot( n, work, 1, vl( 1, ks+1 ), 1 ) - call stdlib_qgemv( 'N', n, n, one, a, lda, vr( 1, ks+1 ), 1,zero, work, 1 ) + tmprr = stdlib_${ri}$dot( n, work, 1, vl( 1, ks ), 1 ) + tmpri = stdlib_${ri}$dot( n, work, 1, vl( 1, ks+1 ), 1 ) + call stdlib_${ri}$gemv( 'N', n, n, one, a, lda, vr( 1, ks+1 ), 1,zero, work, 1 ) - tmpii = stdlib_qdot( n, work, 1, vl( 1, ks+1 ), 1 ) - tmpir = stdlib_qdot( n, work, 1, vl( 1, ks ), 1 ) + tmpii = stdlib_${ri}$dot( n, work, 1, vl( 1, ks+1 ), 1 ) + tmpir = stdlib_${ri}$dot( n, work, 1, vl( 1, ks ), 1 ) uhav = tmprr + tmpii uhavi = tmpir - tmpri - call stdlib_qgemv( 'N', n, n, one, b, ldb, vr( 1, ks ), 1, zero,work, 1 ) + call stdlib_${ri}$gemv( 'N', n, n, one, b, ldb, vr( 1, ks ), 1, zero,work, 1 ) - tmprr = stdlib_qdot( n, work, 1, vl( 1, ks ), 1 ) - tmpri = stdlib_qdot( n, work, 1, vl( 1, ks+1 ), 1 ) - call stdlib_qgemv( 'N', n, n, one, b, ldb, vr( 1, ks+1 ), 1,zero, work, 1 ) + tmprr = stdlib_${ri}$dot( n, work, 1, vl( 1, ks ), 1 ) + tmpri = stdlib_${ri}$dot( n, work, 1, vl( 1, ks+1 ), 1 ) + call stdlib_${ri}$gemv( 'N', n, n, one, b, ldb, vr( 1, ks+1 ), 1,zero, work, 1 ) - tmpii = stdlib_qdot( n, work, 1, vl( 1, ks+1 ), 1 ) - tmpir = stdlib_qdot( n, work, 1, vl( 1, ks ), 1 ) + tmpii = stdlib_${ri}$dot( n, work, 1, vl( 1, ks+1 ), 1 ) + tmpir = stdlib_${ri}$dot( n, work, 1, vl( 1, ks ), 1 ) uhbv = tmprr + tmpii uhbvi = tmpir - tmpri - uhav = stdlib_qlapy2( uhav, uhavi ) - uhbv = stdlib_qlapy2( uhbv, uhbvi ) - cond = stdlib_qlapy2( uhav, uhbv ) + uhav = stdlib_${ri}$lapy2( uhav, uhavi ) + uhbv = stdlib_${ri}$lapy2( uhbv, uhbvi ) + cond = stdlib_${ri}$lapy2( uhav, uhbv ) s( ks ) = cond / ( rnrm*lnrm ) s( ks+1 ) = s( ks ) else ! real eigenvalue. - rnrm = stdlib_qnrm2( n, vr( 1, ks ), 1 ) - lnrm = stdlib_qnrm2( n, vl( 1, ks ), 1 ) - call stdlib_qgemv( 'N', n, n, one, a, lda, vr( 1, ks ), 1, zero,work, 1 ) + rnrm = stdlib_${ri}$nrm2( n, vr( 1, ks ), 1 ) + lnrm = stdlib_${ri}$nrm2( n, vl( 1, ks ), 1 ) + call stdlib_${ri}$gemv( 'N', n, n, one, a, lda, vr( 1, ks ), 1, zero,work, 1 ) - uhav = stdlib_qdot( n, work, 1, vl( 1, ks ), 1 ) - call stdlib_qgemv( 'N', n, n, one, b, ldb, vr( 1, ks ), 1, zero,work, 1 ) + uhav = stdlib_${ri}$dot( n, work, 1, vl( 1, ks ), 1 ) + call stdlib_${ri}$gemv( 'N', n, n, one, b, ldb, vr( 1, ks ), 1, zero,work, 1 ) - uhbv = stdlib_qdot( n, work, 1, vl( 1, ks ), 1 ) - cond = stdlib_qlapy2( uhav, uhbv ) + uhbv = stdlib_${ri}$dot( n, work, 1, vl( 1, ks ), 1 ) + cond = stdlib_${ri}$lapy2( uhav, uhbv ) if( cond==zero ) then s( ks ) = -one else @@ -78695,7 +78696,7 @@ module stdlib_linalg_lapack_q end if if( wantdf ) then if( n==1 ) then - dif( ks ) = stdlib_qlapy2( a( 1, 1 ), b( 1, 1 ) ) + dif( ks ) = stdlib_${ri}$lapy2( a( 1, 1 ), b( 1, 1 ) ) cycle loop_20 end if ! estimate the reciprocal condition number of the k-th @@ -78711,23 +78712,23 @@ module stdlib_linalg_lapack_q work( 6 ) = b( k+1, k ) work( 7 ) = b( k, k+1 ) work( 8 ) = b( k+1, k+1 ) - call stdlib_qlag2( work, 2, work( 5 ), 2, smlnum*eps, beta,dummy1( 1 ), & + call stdlib_${ri}$lag2( work, 2, work( 5 ), 2, smlnum*eps, beta,dummy1( 1 ), & alphar, dummy( 1 ), alphai ) alprqt = one c1 = two*( alphar*alphar+alphai*alphai+beta*beta ) c2 = four*beta*beta*alphai*alphai - root1 = c1 + sqrt( c1*c1-4.0_qp*c2 ) + root1 = c1 + sqrt( c1*c1-4.0_${rk}$*c2 ) root2 = c2 / root1 root1 = root1 / two cond = min( sqrt( root1 ), sqrt( root2 ) ) end if ! copy the matrix (a, b) to the array work and swap the ! diagonal block beginning at a(k,k) to the (1,1) position. - call stdlib_qlacpy( 'FULL', n, n, a, lda, work, n ) - call stdlib_qlacpy( 'FULL', n, n, b, ldb, work( n*n+1 ), n ) + call stdlib_${ri}$lacpy( 'FULL', n, n, a, lda, work, n ) + call stdlib_${ri}$lacpy( 'FULL', n, n, b, ldb, work( n*n+1 ), n ) ifst = k ilst = 1 - call stdlib_qtgexc( .false., .false., n, work, n, work( n*n+1 ), n,dummy, 1, & + call stdlib_${ri}$tgexc( .false., .false., n, work, n, work( n*n+1 ), n,dummy, 1, & dummy1, 1, ifst, ilst,work( n*n*2+1 ), lwork-2*n*n, ierr ) if( ierr>0 ) then ! ill-conditioned problem - swap rejected. @@ -78746,7 +78747,7 @@ module stdlib_linalg_lapack_q else i = n*n + 1 iz = 2*n*n + 1 - call stdlib_qtgsyl( 'N', difdri, n2, n1, work( n*n1+n1+1 ),n, work, n, & + call stdlib_${ri}$tgsyl( 'N', difdri, n2, n1, work( n*n1+n1+1 ),n, work, n, & work( n1+1 ), n,work( n*n1+n1+i ), n, work( i ), n,work( n1+i ), n, scale, & dif( ks ),work( iz+1 ), lwork-2*n*n, iwork, ierr ) if( pair )dif( ks ) = min( max( one, alprqt )*dif( ks ),cond ) @@ -78758,10 +78759,10 @@ module stdlib_linalg_lapack_q end do loop_20 work( 1 ) = lwmin return - end subroutine stdlib_qtgsna + end subroutine stdlib_${ri}$tgsna - pure subroutine stdlib_qtgsy2( trans, ijob, m, n, a, lda, b, ldb, c, ldc, d,ldd, e, lde, f, & + pure subroutine stdlib_${ri}$tgsy2( trans, ijob, m, n, a, lda, b, ldb, c, ldc, d,ldd, e, lde, f, & !! DTGSY2: solves the generalized Sylvester equation: !! A * R - L * B = scale * C (1) !! D * R - L * E = scale * F, @@ -78798,14 +78799,14 @@ module stdlib_linalg_lapack_q character, intent(in) :: trans integer(ilp), intent(in) :: ijob, lda, ldb, ldc, ldd, lde, ldf, m, n integer(ilp), intent(out) :: info, pq - real(qp), intent(inout) :: rdscal, rdsum - real(qp), intent(out) :: scale + real(${rk}$), intent(inout) :: rdscal, rdsum + real(${rk}$), intent(out) :: scale ! Array Arguments integer(ilp), intent(out) :: iwork(*) - real(qp), intent(in) :: a(lda,*), b(ldb,*), d(ldd,*), e(lde,*) - real(qp), intent(inout) :: c(ldc,*), f(ldf,*) + real(${rk}$), intent(in) :: a(lda,*), b(ldb,*), d(ldd,*), e(lde,*) + real(${rk}$), intent(inout) :: c(ldc,*), f(ldf,*) ! ===================================================================== - ! replaced various illegal calls to stdlib_qcopy by calls to stdlib_qlaset. + ! replaced various illegal calls to stdlib_${ri}$copy by calls to stdlib_${ri}$laset. ! sven hammarling, 27/5/02. ! Parameters integer(ilp), parameter :: ldz = 8 @@ -78815,10 +78816,10 @@ module stdlib_linalg_lapack_q logical(lk) :: notran integer(ilp) :: i, ie, ierr, ii, is, isp1, j, je, jj, js, jsp1, k, mb, nb, p, q, & zdim - real(qp) :: alpha, scaloc + real(${rk}$) :: alpha, scaloc ! Local Arrays integer(ilp) :: ipiv(ldz), jpiv(ldz) - real(qp) :: rhs(ldz), z(ldz,ldz) + real(${rk}$) :: rhs(ldz), z(ldz,ldz) ! Intrinsic Functions intrinsic :: max ! Executable Statements @@ -78918,19 +78919,19 @@ module stdlib_linalg_lapack_q rhs( 1 ) = c( is, js ) rhs( 2 ) = f( is, js ) ! solve z * x = rhs - call stdlib_qgetc2( zdim, z, ldz, ipiv, jpiv, ierr ) + call stdlib_${ri}$getc2( zdim, z, ldz, ipiv, jpiv, ierr ) if( ierr>0 )info = ierr if( ijob==0 ) then - call stdlib_qgesc2( zdim, z, ldz, rhs, ipiv, jpiv,scaloc ) + call stdlib_${ri}$gesc2( zdim, z, ldz, rhs, ipiv, jpiv,scaloc ) if( scaloc/=one ) then do k = 1, n - call stdlib_qscal( m, scaloc, c( 1, k ), 1 ) - call stdlib_qscal( m, scaloc, f( 1, k ), 1 ) + call stdlib_${ri}$scal( m, scaloc, c( 1, k ), 1 ) + call stdlib_${ri}$scal( m, scaloc, f( 1, k ), 1 ) end do scale = scale*scaloc end if else - call stdlib_qlatdf( ijob, zdim, z, ldz, rhs, rdsum,rdscal, ipiv, jpiv ) + call stdlib_${ri}$latdf( ijob, zdim, z, ldz, rhs, rdsum,rdscal, ipiv, jpiv ) end if ! unpack solution vector(s) @@ -78940,13 +78941,13 @@ module stdlib_linalg_lapack_q ! equation. if( i>1 ) then alpha = -rhs( 1 ) - call stdlib_qaxpy( is-1, alpha, a( 1, is ), 1, c( 1, js ),1 ) - call stdlib_qaxpy( is-1, alpha, d( 1, is ), 1, f( 1, js ),1 ) + call stdlib_${ri}$axpy( is-1, alpha, a( 1, is ), 1, c( 1, js ),1 ) + call stdlib_${ri}$axpy( is-1, alpha, d( 1, is ), 1, f( 1, js ),1 ) end if if( j0 )info = ierr if( ijob==0 ) then - call stdlib_qgesc2( zdim, z, ldz, rhs, ipiv, jpiv,scaloc ) + call stdlib_${ri}$gesc2( zdim, z, ldz, rhs, ipiv, jpiv,scaloc ) if( scaloc/=one ) then do k = 1, n - call stdlib_qscal( m, scaloc, c( 1, k ), 1 ) - call stdlib_qscal( m, scaloc, f( 1, k ), 1 ) + call stdlib_${ri}$scal( m, scaloc, c( 1, k ), 1 ) + call stdlib_${ri}$scal( m, scaloc, f( 1, k ), 1 ) end do scale = scale*scaloc end if else - call stdlib_qlatdf( ijob, zdim, z, ldz, rhs, rdsum,rdscal, ipiv, jpiv ) + call stdlib_${ri}$latdf( ijob, zdim, z, ldz, rhs, rdsum,rdscal, ipiv, jpiv ) end if ! unpack solution vector(s) @@ -78996,19 +78997,19 @@ module stdlib_linalg_lapack_q ! substitute r(i, j) and l(i, j) into remaining ! equation. if( i>1 ) then - call stdlib_qger( is-1, nb, -one, a( 1, is ), 1, rhs( 1 ),1, c( 1, js ),& + call stdlib_${ri}$ger( is-1, nb, -one, a( 1, is ), 1, rhs( 1 ),1, c( 1, js ),& ldc ) - call stdlib_qger( is-1, nb, -one, d( 1, is ), 1, rhs( 1 ),1, f( 1, js ),& + call stdlib_${ri}$ger( is-1, nb, -one, d( 1, is ), 1, rhs( 1 ),1, f( 1, js ),& ldf ) end if if( j0 )info = ierr if( ijob==0 ) then - call stdlib_qgesc2( zdim, z, ldz, rhs, ipiv, jpiv,scaloc ) + call stdlib_${ri}$gesc2( zdim, z, ldz, rhs, ipiv, jpiv,scaloc ) if( scaloc/=one ) then do k = 1, n - call stdlib_qscal( m, scaloc, c( 1, k ), 1 ) - call stdlib_qscal( m, scaloc, f( 1, k ), 1 ) + call stdlib_${ri}$scal( m, scaloc, c( 1, k ), 1 ) + call stdlib_${ri}$scal( m, scaloc, f( 1, k ), 1 ) end do scale = scale*scaloc end if else - call stdlib_qlatdf( ijob, zdim, z, ldz, rhs, rdsum,rdscal, ipiv, jpiv ) + call stdlib_${ri}$latdf( ijob, zdim, z, ldz, rhs, rdsum,rdscal, ipiv, jpiv ) end if ! unpack solution vector(s) @@ -79058,20 +79059,20 @@ module stdlib_linalg_lapack_q ! substitute r(i, j) and l(i, j) into remaining ! equation. if( i>1 ) then - call stdlib_qgemv( 'N', is-1, mb, -one, a( 1, is ), lda,rhs( 1 ), 1, & + call stdlib_${ri}$gemv( 'N', is-1, mb, -one, a( 1, is ), lda,rhs( 1 ), 1, & one, c( 1, js ), 1 ) - call stdlib_qgemv( 'N', is-1, mb, -one, d( 1, is ), ldd,rhs( 1 ), 1, & + call stdlib_${ri}$gemv( 'N', is-1, mb, -one, d( 1, is ), ldd,rhs( 1 ), 1, & one, f( 1, js ), 1 ) end if if( j0 )info = ierr if( ijob==0 ) then - call stdlib_qgesc2( zdim, z, ldz, rhs, ipiv, jpiv,scaloc ) + call stdlib_${ri}$gesc2( zdim, z, ldz, rhs, ipiv, jpiv,scaloc ) if( scaloc/=one ) then do k = 1, n - call stdlib_qscal( m, scaloc, c( 1, k ), 1 ) - call stdlib_qscal( m, scaloc, f( 1, k ), 1 ) + call stdlib_${ri}$scal( m, scaloc, c( 1, k ), 1 ) + call stdlib_${ri}$scal( m, scaloc, f( 1, k ), 1 ) end do scale = scale*scaloc end if else - call stdlib_qlatdf( ijob, zdim, z, ldz, rhs, rdsum,rdscal, ipiv, jpiv ) + call stdlib_${ri}$latdf( ijob, zdim, z, ldz, rhs, rdsum,rdscal, ipiv, jpiv ) end if ! unpack solution vector(s) k = 1 ii = mb*nb + 1 do jj = 0, nb - 1 - call stdlib_qcopy( mb, rhs( k ), 1, c( is, js+jj ), 1 ) - call stdlib_qcopy( mb, rhs( ii ), 1, f( is, js+jj ), 1 ) + call stdlib_${ri}$copy( mb, rhs( k ), 1, c( is, js+jj ), 1 ) + call stdlib_${ri}$copy( mb, rhs( ii ), 1, f( is, js+jj ), 1 ) k = k + mb ii = ii + mb end do ! substitute r(i, j) and l(i, j) into remaining ! equation. if( i>1 ) then - call stdlib_qgemm( 'N', 'N', is-1, nb, mb, -one,a( 1, is ), lda, rhs( 1 & + call stdlib_${ri}$gemm( 'N', 'N', is-1, nb, mb, -one,a( 1, is ), lda, rhs( 1 & ), mb, one,c( 1, js ), ldc ) - call stdlib_qgemm( 'N', 'N', is-1, nb, mb, -one,d( 1, is ), ldd, rhs( 1 & + call stdlib_${ri}$gemm( 'N', 'N', is-1, nb, mb, -one,d( 1, is ), ldd, rhs( 1 & ), mb, one,f( 1, js ), ldf ) end if if( j0 )info = ierr - call stdlib_qgesc2( zdim, z, ldz, rhs, ipiv, jpiv, scaloc ) + call stdlib_${ri}$gesc2( zdim, z, ldz, rhs, ipiv, jpiv, scaloc ) if( scaloc/=one ) then do k = 1, n - call stdlib_qscal( m, scaloc, c( 1, k ), 1 ) - call stdlib_qscal( m, scaloc, f( 1, k ), 1 ) + call stdlib_${ri}$scal( m, scaloc, c( 1, k ), 1 ) + call stdlib_${ri}$scal( m, scaloc, f( 1, k ), 1 ) end do scale = scale*scaloc end if @@ -79197,16 +79198,16 @@ module stdlib_linalg_lapack_q ! equation. if( j>p+2 ) then alpha = rhs( 1 ) - call stdlib_qaxpy( js-1, alpha, b( 1, js ), 1, f( is, 1 ),ldf ) + call stdlib_${ri}$axpy( js-1, alpha, b( 1, js ), 1, f( is, 1 ),ldf ) alpha = rhs( 2 ) - call stdlib_qaxpy( js-1, alpha, e( 1, js ), 1, f( is, 1 ),ldf ) + call stdlib_${ri}$axpy( js-1, alpha, e( 1, js ), 1, f( is, 1 ),ldf ) end if if( i

0 )info = ierr - call stdlib_qgesc2( zdim, z, ldz, rhs, ipiv, jpiv, scaloc ) + call stdlib_${ri}$gesc2( zdim, z, ldz, rhs, ipiv, jpiv, scaloc ) if( scaloc/=one ) then do k = 1, n - call stdlib_qscal( m, scaloc, c( 1, k ), 1 ) - call stdlib_qscal( m, scaloc, f( 1, k ), 1 ) + call stdlib_${ri}$scal( m, scaloc, c( 1, k ), 1 ) + call stdlib_${ri}$scal( m, scaloc, f( 1, k ), 1 ) end do scale = scale*scaloc end if @@ -79251,19 +79252,19 @@ module stdlib_linalg_lapack_q ! substitute r(i, j) and l(i, j) into remaining ! equation. if( j>p+2 ) then - call stdlib_qaxpy( js-1, rhs( 1 ), b( 1, js ), 1,f( is, 1 ), ldf ) + call stdlib_${ri}$axpy( js-1, rhs( 1 ), b( 1, js ), 1,f( is, 1 ), ldf ) - call stdlib_qaxpy( js-1, rhs( 2 ), b( 1, jsp1 ), 1,f( is, 1 ), ldf ) + call stdlib_${ri}$axpy( js-1, rhs( 2 ), b( 1, jsp1 ), 1,f( is, 1 ), ldf ) - call stdlib_qaxpy( js-1, rhs( 3 ), e( 1, js ), 1,f( is, 1 ), ldf ) + call stdlib_${ri}$axpy( js-1, rhs( 3 ), e( 1, js ), 1,f( is, 1 ), ldf ) - call stdlib_qaxpy( js-1, rhs( 4 ), e( 1, jsp1 ), 1,f( is, 1 ), ldf ) + call stdlib_${ri}$axpy( js-1, rhs( 4 ), e( 1, jsp1 ), 1,f( is, 1 ), ldf ) end if if( i

0 )info = ierr - call stdlib_qgesc2( zdim, z, ldz, rhs, ipiv, jpiv, scaloc ) + call stdlib_${ri}$gesc2( zdim, z, ldz, rhs, ipiv, jpiv, scaloc ) if( scaloc/=one ) then do k = 1, n - call stdlib_qscal( m, scaloc, c( 1, k ), 1 ) - call stdlib_qscal( m, scaloc, f( 1, k ), 1 ) + call stdlib_${ri}$scal( m, scaloc, c( 1, k ), 1 ) + call stdlib_${ri}$scal( m, scaloc, f( 1, k ), 1 ) end do scale = scale*scaloc end if @@ -79308,20 +79309,20 @@ module stdlib_linalg_lapack_q ! substitute r(i, j) and l(i, j) into remaining ! equation. if( j>p+2 ) then - call stdlib_qger( mb, js-1, one, rhs( 1 ), 1, b( 1, js ),1, f( is, 1 ), & + call stdlib_${ri}$ger( mb, js-1, one, rhs( 1 ), 1, b( 1, js ),1, f( is, 1 ), & ldf ) - call stdlib_qger( mb, js-1, one, rhs( 3 ), 1, e( 1, js ),1, f( is, 1 ), & + call stdlib_${ri}$ger( mb, js-1, one, rhs( 3 ), 1, e( 1, js ),1, f( is, 1 ), & ldf ) end if if( i

0 )info = ierr - call stdlib_qgesc2( zdim, z, ldz, rhs, ipiv, jpiv, scaloc ) + call stdlib_${ri}$gesc2( zdim, z, ldz, rhs, ipiv, jpiv, scaloc ) if( scaloc/=one ) then do k = 1, n - call stdlib_qscal( m, scaloc, c( 1, k ), 1 ) - call stdlib_qscal( m, scaloc, f( 1, k ), 1 ) + call stdlib_${ri}$scal( m, scaloc, c( 1, k ), 1 ) + call stdlib_${ri}$scal( m, scaloc, f( 1, k ), 1 ) end do scale = scale*scaloc end if @@ -79374,23 +79375,23 @@ module stdlib_linalg_lapack_q k = 1 ii = mb*nb + 1 do jj = 0, nb - 1 - call stdlib_qcopy( mb, rhs( k ), 1, c( is, js+jj ), 1 ) - call stdlib_qcopy( mb, rhs( ii ), 1, f( is, js+jj ), 1 ) + call stdlib_${ri}$copy( mb, rhs( k ), 1, c( is, js+jj ), 1 ) + call stdlib_${ri}$copy( mb, rhs( ii ), 1, f( is, js+jj ), 1 ) k = k + mb ii = ii + mb end do ! substitute r(i, j) and l(i, j) into remaining ! equation. if( j>p+2 ) then - call stdlib_qgemm( 'N', 'T', mb, js-1, nb, one,c( is, js ), ldc, b( 1, & + call stdlib_${ri}$gemm( 'N', 'T', mb, js-1, nb, one,c( is, js ), ldc, b( 1, & js ), ldb, one,f( is, 1 ), ldf ) - call stdlib_qgemm( 'N', 'T', mb, js-1, nb, one,f( is, js ), ldf, e( 1, & + call stdlib_${ri}$gemm( 'N', 'T', mb, js-1, nb, one,f( is, js ), ldf, e( 1, & js ), lde, one,f( is, 1 ), ldf ) end if if( i

=3 ) then ifunc = ijob - 2 - call stdlib_qlaset( 'F', m, n, zero, zero, c, ldc ) - call stdlib_qlaset( 'F', m, n, zero, zero, f, ldf ) + call stdlib_${ri}$laset( 'F', m, n, zero, zero, c, ldc ) + call stdlib_${ri}$laset( 'F', m, n, zero, zero, f, ldf ) else if( ijob>=1 ) then isolve = 2 end if @@ -79537,13 +79538,13 @@ module stdlib_linalg_lapack_q dscale = zero dsum = one pq = 0 - call stdlib_qtgsy2( trans, ifunc, m, n, a, lda, b, ldb, c, ldc, d,ldd, e, lde, f,& + call stdlib_${ri}$tgsy2( trans, ifunc, m, n, a, lda, b, ldb, c, ldc, d,ldd, e, lde, f,& ldf, scale, dsum, dscale,iwork, pq, info ) if( dscale/=zero ) then if( ijob==1 .or. ijob==3 ) then - dif = sqrt( real( 2*m*n,KIND=qp) ) / ( dscale*sqrt( dsum ) ) + dif = sqrt( real( 2*m*n,KIND=${rk}$) ) / ( dscale*sqrt( dsum ) ) else - dif = sqrt( real( pq,KIND=qp) ) / ( dscale*sqrt( dsum ) ) + dif = sqrt( real( pq,KIND=${rk}$) ) / ( dscale*sqrt( dsum ) ) end if end if if( isolve==2 .and. iround==1 ) then @@ -79551,13 +79552,13 @@ module stdlib_linalg_lapack_q ifunc = ijob end if scale2 = scale - call stdlib_qlacpy( 'F', m, n, c, ldc, work, m ) - call stdlib_qlacpy( 'F', m, n, f, ldf, work( m*n+1 ), m ) - call stdlib_qlaset( 'F', m, n, zero, zero, c, ldc ) - call stdlib_qlaset( 'F', m, n, zero, zero, f, ldf ) + call stdlib_${ri}$lacpy( 'F', m, n, c, ldc, work, m ) + call stdlib_${ri}$lacpy( 'F', m, n, f, ldf, work( m*n+1 ), m ) + call stdlib_${ri}$laset( 'F', m, n, zero, zero, c, ldc ) + call stdlib_${ri}$laset( 'F', m, n, zero, zero, f, ldf ) else if( isolve==2 .and. iround==2 ) then - call stdlib_qlacpy( 'F', m, n, work, m, c, ldc ) - call stdlib_qlacpy( 'F', m, n, work( m*n+1 ), m, f, ldf ) + call stdlib_${ri}$lacpy( 'F', m, n, work, m, c, ldc ) + call stdlib_${ri}$lacpy( 'F', m, n, work( m*n+1 ), m, f, ldf ) scale = scale2 end if end do loop_30 @@ -79610,51 +79611,51 @@ module stdlib_linalg_lapack_q ie = iwork( i+1 ) - 1 mb = ie - is + 1 ppqq = 0 - call stdlib_qtgsy2( trans, ifunc, mb, nb, a( is, is ), lda,b( js, js ), & + call stdlib_${ri}$tgsy2( trans, ifunc, mb, nb, a( is, is ), lda,b( js, js ), & ldb, c( is, js ), ldc,d( is, is ), ldd, e( js, js ), lde,f( is, js ), ldf, & scaloc, dsum, dscale,iwork( q+2 ), ppqq, linfo ) if( linfo>0 )info = linfo pq = pq + ppqq if( scaloc/=one ) then do k = 1, js - 1 - call stdlib_qscal( m, scaloc, c( 1, k ), 1 ) - call stdlib_qscal( m, scaloc, f( 1, k ), 1 ) + call stdlib_${ri}$scal( m, scaloc, c( 1, k ), 1 ) + call stdlib_${ri}$scal( m, scaloc, f( 1, k ), 1 ) end do do k = js, je - call stdlib_qscal( is-1, scaloc, c( 1, k ), 1 ) - call stdlib_qscal( is-1, scaloc, f( 1, k ), 1 ) + call stdlib_${ri}$scal( is-1, scaloc, c( 1, k ), 1 ) + call stdlib_${ri}$scal( is-1, scaloc, f( 1, k ), 1 ) end do do k = js, je - call stdlib_qscal( m-ie, scaloc, c( ie+1, k ), 1 ) - call stdlib_qscal( m-ie, scaloc, f( ie+1, k ), 1 ) + call stdlib_${ri}$scal( m-ie, scaloc, c( ie+1, k ), 1 ) + call stdlib_${ri}$scal( m-ie, scaloc, f( ie+1, k ), 1 ) end do do k = je + 1, n - call stdlib_qscal( m, scaloc, c( 1, k ), 1 ) - call stdlib_qscal( m, scaloc, f( 1, k ), 1 ) + call stdlib_${ri}$scal( m, scaloc, c( 1, k ), 1 ) + call stdlib_${ri}$scal( m, scaloc, f( 1, k ), 1 ) end do scale = scale*scaloc end if ! substitute r(i, j) and l(i, j) into remaining ! equation. if( i>1 ) then - call stdlib_qgemm( 'N', 'N', is-1, nb, mb, -one,a( 1, is ), lda, c( is, & + call stdlib_${ri}$gemm( 'N', 'N', is-1, nb, mb, -one,a( 1, is ), lda, c( is, & js ), ldc, one,c( 1, js ), ldc ) - call stdlib_qgemm( 'N', 'N', is-1, nb, mb, -one,d( 1, is ), ldd, c( is, & + call stdlib_${ri}$gemm( 'N', 'N', is-1, nb, mb, -one,d( 1, is ), ldd, c( is, & js ), ldc, one,f( 1, js ), ldf ) end if if( j0 )info = linfo if( scaloc/=one ) then do k = 1, js - 1 - call stdlib_qscal( m, scaloc, c( 1, k ), 1 ) - call stdlib_qscal( m, scaloc, f( 1, k ), 1 ) + call stdlib_${ri}$scal( m, scaloc, c( 1, k ), 1 ) + call stdlib_${ri}$scal( m, scaloc, f( 1, k ), 1 ) end do do k = js, je - call stdlib_qscal( is-1, scaloc, c( 1, k ), 1 ) - call stdlib_qscal( is-1, scaloc, f( 1, k ), 1 ) + call stdlib_${ri}$scal( is-1, scaloc, c( 1, k ), 1 ) + call stdlib_${ri}$scal( is-1, scaloc, f( 1, k ), 1 ) end do do k = js, je - call stdlib_qscal( m-ie, scaloc, c( ie+1, k ), 1 ) - call stdlib_qscal( m-ie, scaloc, f( ie+1, k ), 1 ) + call stdlib_${ri}$scal( m-ie, scaloc, c( ie+1, k ), 1 ) + call stdlib_${ri}$scal( m-ie, scaloc, f( ie+1, k ), 1 ) end do do k = je + 1, n - call stdlib_qscal( m, scaloc, c( 1, k ), 1 ) - call stdlib_qscal( m, scaloc, f( 1, k ), 1 ) + call stdlib_${ri}$scal( m, scaloc, c( 1, k ), 1 ) + call stdlib_${ri}$scal( m, scaloc, f( 1, k ), 1 ) end do scale = scale*scaloc end if ! substitute r(i, j) and l(i, j) into remaining equation. if( j>p+2 ) then - call stdlib_qgemm( 'N', 'T', mb, js-1, nb, one, c( is, js ),ldc, b( 1, js )& + call stdlib_${ri}$gemm( 'N', 'T', mb, js-1, nb, one, c( is, js ),ldc, b( 1, js )& , ldb, one, f( is, 1 ),ldf ) - call stdlib_qgemm( 'N', 'T', mb, js-1, nb, one, f( is, js ),ldf, e( 1, js )& + call stdlib_${ri}$gemm( 'N', 'T', mb, js-1, nb, one, f( is, js ),ldf, e( 1, js )& , lde, one, f( is, 1 ),ldf ) end if if( i

0. if( anorm>zero ) then ! estimate the norm of the inverse of a. @@ -79800,24 +79801,24 @@ module stdlib_linalg_lapack_q end if kase = 0 10 continue - call stdlib_qlacn2( n, work( n+1 ), work, iwork, ainvnm, kase, isave ) + call stdlib_${ri}$lacn2( n, work( n+1 ), work, iwork, ainvnm, kase, isave ) if( kase/=0 ) then if( kase==kase1 ) then ! multiply by inv(a). - call stdlib_qlatps( uplo, 'NO TRANSPOSE', diag, normin, n, ap,work, scale, & + call stdlib_${ri}$latps( uplo, 'NO TRANSPOSE', diag, normin, n, ap,work, scale, & work( 2*n+1 ), info ) else ! multiply by inv(a**t). - call stdlib_qlatps( uplo, 'TRANSPOSE', diag, normin, n, ap,work, scale, work( & + call stdlib_${ri}$latps( uplo, 'TRANSPOSE', diag, normin, n, ap,work, scale, work( & 2*n+1 ), info ) end if normin = 'Y' ! multiply by 1/scale if doing so will not cause overflow. if( scale/=one ) then - ix = stdlib_iqamax( n, work, 1 ) + ix = stdlib_i${ri}$amax( n, work, 1 ) xnorm = abs( work( ix ) ) if( scale 0. if( anorm>zero ) then ! estimate the norm of the inverse of a. @@ -81573,24 +81574,24 @@ module stdlib_linalg_lapack_q end if kase = 0 10 continue - call stdlib_qlacn2( n, work( n+1 ), work, iwork, ainvnm, kase, isave ) + call stdlib_${ri}$lacn2( n, work( n+1 ), work, iwork, ainvnm, kase, isave ) if( kase/=0 ) then if( kase==kase1 ) then ! multiply by inv(a). - call stdlib_qlatrs( uplo, 'NO TRANSPOSE', diag, normin, n, a,lda, work, scale,& + call stdlib_${ri}$latrs( uplo, 'NO TRANSPOSE', diag, normin, n, a,lda, work, scale,& work( 2*n+1 ), info ) else ! multiply by inv(a**t). - call stdlib_qlatrs( uplo, 'TRANSPOSE', diag, normin, n, a, lda,work, scale, & + call stdlib_${ri}$latrs( uplo, 'TRANSPOSE', diag, normin, n, a, lda,work, scale, & work( 2*n+1 ), info ) end if normin = 'Y' ! multiply by 1/scale if doing so will not cause overflow. if( scale/=one ) then - ix = stdlib_iqamax( n, work, 1 ) + ix = stdlib_i${ri}$amax( n, work, 1 ) xnorm = abs( work( ix ) ) if( scale1 )call stdlib_qgemv( 'N', n, ki-1, one, vr, ldvr,work( 1+n ), 1, & + if( ki>1 )call stdlib_${ri}$gemv( 'N', n, ki-1, one, vr, ldvr,work( 1+n ), 1, & work( ki+n ),vr( 1, ki ), 1 ) - ii = stdlib_iqamax( n, vr( 1, ki ), 1 ) + ii = stdlib_i${ri}$amax( n, vr( 1, ki ), 1 ) remax = one / abs( vr( ii, ki ) ) - call stdlib_qscal( n, remax, vr( 1, ki ), 1 ) + call stdlib_${ri}$scal( n, remax, vr( 1, ki ), 1 ) end if else ! complex right eigenvector. @@ -81861,7 +81862,7 @@ module stdlib_linalg_lapack_q end if if( j1==j2 ) then ! 1-by-1 diagonal block - call stdlib_qlaln2( .false., 1, 2, smin, one, t( j, j ),ldt, one, one, & + call stdlib_${ri}$laln2( .false., 1, 2, smin, one, t( j, j ),ldt, one, one, & work( j+n ), n, wr, wi,x, 2, scale, xnorm, ierr ) ! scale x(1,1) and x(1,2) to avoid overflow when ! updating the right-hand side. @@ -81874,19 +81875,19 @@ module stdlib_linalg_lapack_q end if ! scale if necessary if( scale/=one ) then - call stdlib_qscal( ki, scale, work( 1+n ), 1 ) - call stdlib_qscal( ki, scale, work( 1+n2 ), 1 ) + call stdlib_${ri}$scal( ki, scale, work( 1+n ), 1 ) + call stdlib_${ri}$scal( ki, scale, work( 1+n2 ), 1 ) end if work( j+n ) = x( 1, 1 ) work( j+n2 ) = x( 1, 2 ) ! update the right-hand side - call stdlib_qaxpy( j-1, -x( 1, 1 ), t( 1, j ), 1,work( 1+n ), 1 ) + call stdlib_${ri}$axpy( j-1, -x( 1, 1 ), t( 1, j ), 1,work( 1+n ), 1 ) - call stdlib_qaxpy( j-1, -x( 1, 2 ), t( 1, j ), 1,work( 1+n2 ), 1 ) + call stdlib_${ri}$axpy( j-1, -x( 1, 2 ), t( 1, j ), 1,work( 1+n2 ), 1 ) else ! 2-by-2 diagonal block - call stdlib_qlaln2( .false., 2, 2, smin, one,t( j-1, j-1 ), ldt, one, & + call stdlib_${ri}$laln2( .false., 2, 2, smin, one,t( j-1, j-1 ), ldt, one, & one,work( j-1+n ), n, wr, wi, x, 2, scale,xnorm, ierr ) ! scale x to avoid overflow when updating ! the right-hand side. @@ -81903,56 +81904,56 @@ module stdlib_linalg_lapack_q end if ! scale if necessary if( scale/=one ) then - call stdlib_qscal( ki, scale, work( 1+n ), 1 ) - call stdlib_qscal( ki, scale, work( 1+n2 ), 1 ) + call stdlib_${ri}$scal( ki, scale, work( 1+n ), 1 ) + call stdlib_${ri}$scal( ki, scale, work( 1+n2 ), 1 ) end if work( j-1+n ) = x( 1, 1 ) work( j+n ) = x( 2, 1 ) work( j-1+n2 ) = x( 1, 2 ) work( j+n2 ) = x( 2, 2 ) ! update the right-hand side - call stdlib_qaxpy( j-2, -x( 1, 1 ), t( 1, j-1 ), 1,work( 1+n ), 1 ) + call stdlib_${ri}$axpy( j-2, -x( 1, 1 ), t( 1, j-1 ), 1,work( 1+n ), 1 ) - call stdlib_qaxpy( j-2, -x( 2, 1 ), t( 1, j ), 1,work( 1+n ), 1 ) + call stdlib_${ri}$axpy( j-2, -x( 2, 1 ), t( 1, j ), 1,work( 1+n ), 1 ) - call stdlib_qaxpy( j-2, -x( 1, 2 ), t( 1, j-1 ), 1,work( 1+n2 ), 1 ) + call stdlib_${ri}$axpy( j-2, -x( 1, 2 ), t( 1, j-1 ), 1,work( 1+n2 ), 1 ) - call stdlib_qaxpy( j-2, -x( 2, 2 ), t( 1, j ), 1,work( 1+n2 ), 1 ) + call stdlib_${ri}$axpy( j-2, -x( 2, 2 ), t( 1, j ), 1,work( 1+n2 ), 1 ) end if end do loop_90 ! copy the vector x or q*x to vr and normalize. if( .not.over ) then - call stdlib_qcopy( ki, work( 1+n ), 1, vr( 1, is-1 ), 1 ) - call stdlib_qcopy( ki, work( 1+n2 ), 1, vr( 1, is ), 1 ) + call stdlib_${ri}$copy( ki, work( 1+n ), 1, vr( 1, is-1 ), 1 ) + call stdlib_${ri}$copy( ki, work( 1+n2 ), 1, vr( 1, is ), 1 ) emax = zero do k = 1, ki emax = max( emax, abs( vr( k, is-1 ) )+abs( vr( k, is ) ) ) end do remax = one / emax - call stdlib_qscal( ki, remax, vr( 1, is-1 ), 1 ) - call stdlib_qscal( ki, remax, vr( 1, is ), 1 ) + call stdlib_${ri}$scal( ki, remax, vr( 1, is-1 ), 1 ) + call stdlib_${ri}$scal( ki, remax, vr( 1, is ), 1 ) do k = ki + 1, n vr( k, is-1 ) = zero vr( k, is ) = zero end do else if( ki>2 ) then - call stdlib_qgemv( 'N', n, ki-2, one, vr, ldvr,work( 1+n ), 1, work( ki-& + call stdlib_${ri}$gemv( 'N', n, ki-2, one, vr, ldvr,work( 1+n ), 1, work( ki-& 1+n ),vr( 1, ki-1 ), 1 ) - call stdlib_qgemv( 'N', n, ki-2, one, vr, ldvr,work( 1+n2 ), 1, work( & + call stdlib_${ri}$gemv( 'N', n, ki-2, one, vr, ldvr,work( 1+n2 ), 1, work( & ki+n2 ),vr( 1, ki ), 1 ) else - call stdlib_qscal( n, work( ki-1+n ), vr( 1, ki-1 ), 1 ) - call stdlib_qscal( n, work( ki+n2 ), vr( 1, ki ), 1 ) + call stdlib_${ri}$scal( n, work( ki-1+n ), vr( 1, ki-1 ), 1 ) + call stdlib_${ri}$scal( n, work( ki+n2 ), vr( 1, ki ), 1 ) end if emax = zero do k = 1, n emax = max( emax, abs( vr( k, ki-1 ) )+abs( vr( k, ki ) ) ) end do remax = one / emax - call stdlib_qscal( n, remax, vr( 1, ki-1 ), 1 ) - call stdlib_qscal( n, remax, vr( 1, ki ), 1 ) + call stdlib_${ri}$scal( n, remax, vr( 1, ki-1 ), 1 ) + call stdlib_${ri}$scal( n, remax, vr( 1, ki ), 1 ) end if end if is = is - 1 @@ -82009,17 +82010,17 @@ module stdlib_linalg_lapack_q ! the right-hand side. if( work( j )>vcrit ) then rec = one / vmax - call stdlib_qscal( n-ki+1, rec, work( ki+n ), 1 ) + call stdlib_${ri}$scal( n-ki+1, rec, work( ki+n ), 1 ) vmax = one vcrit = bignum end if - work( j+n ) = work( j+n ) -stdlib_qdot( j-ki-1, t( ki+1, j ), 1,work( & + work( j+n ) = work( j+n ) -stdlib_${ri}$dot( j-ki-1, t( ki+1, j ), 1,work( & ki+1+n ), 1 ) ! solve (t(j,j)-wr)**t*x = work - call stdlib_qlaln2( .false., 1, 1, smin, one, t( j, j ),ldt, one, one, & + call stdlib_${ri}$laln2( .false., 1, 1, smin, one, t( j, j ),ldt, one, one, & work( j+n ), n, wr,zero, x, 2, scale, xnorm, ierr ) ! scale if necessary - if( scale/=one )call stdlib_qscal( n-ki+1, scale, work( ki+n ), 1 ) + if( scale/=one )call stdlib_${ri}$scal( n-ki+1, scale, work( ki+n ), 1 ) work( j+n ) = x( 1, 1 ) vmax = max( abs( work( j+n ) ), vmax ) @@ -82031,21 +82032,21 @@ module stdlib_linalg_lapack_q beta = max( work( j ), work( j+1 ) ) if( beta>vcrit ) then rec = one / vmax - call stdlib_qscal( n-ki+1, rec, work( ki+n ), 1 ) + call stdlib_${ri}$scal( n-ki+1, rec, work( ki+n ), 1 ) vmax = one vcrit = bignum end if - work( j+n ) = work( j+n ) -stdlib_qdot( j-ki-1, t( ki+1, j ), 1,work( & + work( j+n ) = work( j+n ) -stdlib_${ri}$dot( j-ki-1, t( ki+1, j ), 1,work( & ki+1+n ), 1 ) - work( j+1+n ) = work( j+1+n ) -stdlib_qdot( j-ki-1, t( ki+1, j+1 ), 1,& + work( j+1+n ) = work( j+1+n ) -stdlib_${ri}$dot( j-ki-1, t( ki+1, j+1 ), 1,& work( ki+1+n ), 1 ) ! solve ! [t(j,j)-wr t(j,j+1) ]**t * x = scale*( work1 ) ! [t(j+1,j) t(j+1,j+1)-wr] ( work2 ) - call stdlib_qlaln2( .true., 2, 1, smin, one, t( j, j ),ldt, one, one, & + call stdlib_${ri}$laln2( .true., 2, 1, smin, one, t( j, j ),ldt, one, one, & work( j+n ), n, wr,zero, x, 2, scale, xnorm, ierr ) ! scale if necessary - if( scale/=one )call stdlib_qscal( n-ki+1, scale, work( ki+n ), 1 ) + if( scale/=one )call stdlib_${ri}$scal( n-ki+1, scale, work( ki+n ), 1 ) work( j+n ) = x( 1, 1 ) work( j+1+n ) = x( 2, 1 ) @@ -82055,19 +82056,19 @@ module stdlib_linalg_lapack_q end do loop_170 ! copy the vector x or q*x to vl and normalize. if( .not.over ) then - call stdlib_qcopy( n-ki+1, work( ki+n ), 1, vl( ki, is ), 1 ) - ii = stdlib_iqamax( n-ki+1, vl( ki, is ), 1 ) + ki - 1 + call stdlib_${ri}$copy( n-ki+1, work( ki+n ), 1, vl( ki, is ), 1 ) + ii = stdlib_i${ri}$amax( n-ki+1, vl( ki, is ), 1 ) + ki - 1 remax = one / abs( vl( ii, is ) ) - call stdlib_qscal( n-ki+1, remax, vl( ki, is ), 1 ) + call stdlib_${ri}$scal( n-ki+1, remax, vl( ki, is ), 1 ) do k = 1, ki - 1 vl( k, is ) = zero end do else - if( kivcrit ) then rec = one / vmax - call stdlib_qscal( n-ki+1, rec, work( ki+n ), 1 ) - call stdlib_qscal( n-ki+1, rec, work( ki+n2 ), 1 ) + call stdlib_${ri}$scal( n-ki+1, rec, work( ki+n ), 1 ) + call stdlib_${ri}$scal( n-ki+1, rec, work( ki+n2 ), 1 ) vmax = one vcrit = bignum end if - work( j+n ) = work( j+n ) -stdlib_qdot( j-ki-2, t( ki+2, j ), 1,work( & + work( j+n ) = work( j+n ) -stdlib_${ri}$dot( j-ki-2, t( ki+2, j ), 1,work( & ki+2+n ), 1 ) - work( j+n2 ) = work( j+n2 ) -stdlib_qdot( j-ki-2, t( ki+2, j ), 1,work( & + work( j+n2 ) = work( j+n2 ) -stdlib_${ri}$dot( j-ki-2, t( ki+2, j ), 1,work( & ki+2+n2 ), 1 ) ! solve (t(j,j)-(wr-i*wi))*(x11+i*x12)= wk+i*wk2 - call stdlib_qlaln2( .false., 1, 2, smin, one, t( j, j ),ldt, one, one, & + call stdlib_${ri}$laln2( .false., 1, 2, smin, one, t( j, j ),ldt, one, one, & work( j+n ), n, wr,-wi, x, 2, scale, xnorm, ierr ) ! scale if necessary if( scale/=one ) then - call stdlib_qscal( n-ki+1, scale, work( ki+n ), 1 ) - call stdlib_qscal( n-ki+1, scale, work( ki+n2 ), 1 ) + call stdlib_${ri}$scal( n-ki+1, scale, work( ki+n ), 1 ) + call stdlib_${ri}$scal( n-ki+1, scale, work( ki+n2 ), 1 ) end if work( j+n ) = x( 1, 1 ) work( j+n2 ) = x( 1, 2 ) @@ -82138,28 +82139,28 @@ module stdlib_linalg_lapack_q beta = max( work( j ), work( j+1 ) ) if( beta>vcrit ) then rec = one / vmax - call stdlib_qscal( n-ki+1, rec, work( ki+n ), 1 ) - call stdlib_qscal( n-ki+1, rec, work( ki+n2 ), 1 ) + call stdlib_${ri}$scal( n-ki+1, rec, work( ki+n ), 1 ) + call stdlib_${ri}$scal( n-ki+1, rec, work( ki+n2 ), 1 ) vmax = one vcrit = bignum end if - work( j+n ) = work( j+n ) -stdlib_qdot( j-ki-2, t( ki+2, j ), 1,work( & + work( j+n ) = work( j+n ) -stdlib_${ri}$dot( j-ki-2, t( ki+2, j ), 1,work( & ki+2+n ), 1 ) - work( j+n2 ) = work( j+n2 ) -stdlib_qdot( j-ki-2, t( ki+2, j ), 1,work( & + work( j+n2 ) = work( j+n2 ) -stdlib_${ri}$dot( j-ki-2, t( ki+2, j ), 1,work( & ki+2+n2 ), 1 ) - work( j+1+n ) = work( j+1+n ) -stdlib_qdot( j-ki-2, t( ki+2, j+1 ), 1,& + work( j+1+n ) = work( j+1+n ) -stdlib_${ri}$dot( j-ki-2, t( ki+2, j+1 ), 1,& work( ki+2+n ), 1 ) - work( j+1+n2 ) = work( j+1+n2 ) -stdlib_qdot( j-ki-2, t( ki+2, j+1 ), 1,& + work( j+1+n2 ) = work( j+1+n2 ) -stdlib_${ri}$dot( j-ki-2, t( ki+2, j+1 ), 1,& work( ki+2+n2 ), 1 ) ! solve 2-by-2 complex linear equation ! ([t(j,j) t(j,j+1) ]**t-(wr-i*wi)*i)*x = scale*b ! ([t(j+1,j) t(j+1,j+1)] ) - call stdlib_qlaln2( .true., 2, 2, smin, one, t( j, j ),ldt, one, one, & + call stdlib_${ri}$laln2( .true., 2, 2, smin, one, t( j, j ),ldt, one, one, & work( j+n ), n, wr,-wi, x, 2, scale, xnorm, ierr ) ! scale if necessary if( scale/=one ) then - call stdlib_qscal( n-ki+1, scale, work( ki+n ), 1 ) - call stdlib_qscal( n-ki+1, scale, work( ki+n2 ), 1 ) + call stdlib_${ri}$scal( n-ki+1, scale, work( ki+n ), 1 ) + call stdlib_${ri}$scal( n-ki+1, scale, work( ki+n2 ), 1 ) end if work( j+n ) = x( 1, 1 ) work( j+n2 ) = x( 1, 2 ) @@ -82172,36 +82173,36 @@ module stdlib_linalg_lapack_q end do loop_200 ! copy the vector x or q*x to vl and normalize. if( .not.over ) then - call stdlib_qcopy( n-ki+1, work( ki+n ), 1, vl( ki, is ), 1 ) - call stdlib_qcopy( n-ki+1, work( ki+n2 ), 1, vl( ki, is+1 ),1 ) + call stdlib_${ri}$copy( n-ki+1, work( ki+n ), 1, vl( ki, is ), 1 ) + call stdlib_${ri}$copy( n-ki+1, work( ki+n2 ), 1, vl( ki, is+1 ),1 ) emax = zero do k = ki, n emax = max( emax, abs( vl( k, is ) )+abs( vl( k, is+1 ) ) ) end do remax = one / emax - call stdlib_qscal( n-ki+1, remax, vl( ki, is ), 1 ) - call stdlib_qscal( n-ki+1, remax, vl( ki, is+1 ), 1 ) + call stdlib_${ri}$scal( n-ki+1, remax, vl( ki, is ), 1 ) + call stdlib_${ri}$scal( n-ki+1, remax, vl( ki, is+1 ), 1 ) do k = 1, ki - 1 vl( k, is ) = zero vl( k, is+1 ) = zero end do else if( ki= n + 2*n*nbmin ) then nb = (lwork - n) / (2*n) nb = min( nb, nbmax ) - call stdlib_qlaset( 'F', n, 1+2*nb, zero, zero, work, n ) + call stdlib_${ri}$laset( 'F', n, 1+2*nb, zero, zero, work, n ) else nb = 1 end if ! set the constants to control overflow. - unfl = stdlib_qlamch( 'SAFE MINIMUM' ) + unfl = stdlib_${ri}$lamch( 'SAFE MINIMUM' ) ovfl = one / unfl - call stdlib_qlabad( unfl, ovfl ) - ulp = stdlib_qlamch( 'PRECISION' ) + call stdlib_${ri}$labad( unfl, ovfl ) + ulp = stdlib_${ri}$lamch( 'PRECISION' ) smlnum = unfl*( n / ulp ) bignum = ( one-ulp ) / smlnum ! compute 1-norm of each column of strictly upper triangular @@ -82427,7 +82428,7 @@ module stdlib_linalg_lapack_q end if if( j1==j2 ) then ! 1-by-1 diagonal block - call stdlib_qlaln2( .false., 1, 1, smin, one, t( j, j ),ldt, one, one, & + call stdlib_${ri}$laln2( .false., 1, 1, smin, one, t( j, j ),ldt, one, one, & work( j+iv*n ), n, wr,zero, x, 2, scale, xnorm, ierr ) ! scale x(1,1) to avoid overflow when updating ! the right-hand side. @@ -82438,15 +82439,15 @@ module stdlib_linalg_lapack_q end if end if ! scale if necessary - if( scale/=one )call stdlib_qscal( ki, scale, work( 1+iv*n ), 1 ) + if( scale/=one )call stdlib_${ri}$scal( ki, scale, work( 1+iv*n ), 1 ) work( j+iv*n ) = x( 1, 1 ) ! update right-hand side - call stdlib_qaxpy( j-1, -x( 1, 1 ), t( 1, j ), 1,work( 1+iv*n ), 1 ) + call stdlib_${ri}$axpy( j-1, -x( 1, 1 ), t( 1, j ), 1,work( 1+iv*n ), 1 ) else ! 2-by-2 diagonal block - call stdlib_qlaln2( .false., 2, 1, smin, one,t( j-1, j-1 ), ldt, one, & + call stdlib_${ri}$laln2( .false., 2, 1, smin, one,t( j-1, j-1 ), ldt, one, & one,work( j-1+iv*n ), n, wr, zero, x, 2,scale, xnorm, ierr ) ! scale x(1,1) and x(2,1) to avoid overflow when ! updating the right-hand side. @@ -82459,14 +82460,14 @@ module stdlib_linalg_lapack_q end if end if ! scale if necessary - if( scale/=one )call stdlib_qscal( ki, scale, work( 1+iv*n ), 1 ) + if( scale/=one )call stdlib_${ri}$scal( ki, scale, work( 1+iv*n ), 1 ) work( j-1+iv*n ) = x( 1, 1 ) work( j +iv*n ) = x( 2, 1 ) ! update right-hand side - call stdlib_qaxpy( j-2, -x( 1, 1 ), t( 1, j-1 ), 1,work( 1+iv*n ), 1 ) + call stdlib_${ri}$axpy( j-2, -x( 1, 1 ), t( 1, j-1 ), 1,work( 1+iv*n ), 1 ) - call stdlib_qaxpy( j-2, -x( 2, 1 ), t( 1, j ), 1,work( 1+iv*n ), 1 ) + call stdlib_${ri}$axpy( j-2, -x( 2, 1 ), t( 1, j ), 1,work( 1+iv*n ), 1 ) end if end do loop_60 @@ -82474,21 +82475,21 @@ module stdlib_linalg_lapack_q if( .not.over ) then ! ------------------------------ ! no back-transform: copy x to vr and normalize. - call stdlib_qcopy( ki, work( 1 + iv*n ), 1, vr( 1, is ), 1 ) - ii = stdlib_iqamax( ki, vr( 1, is ), 1 ) + call stdlib_${ri}$copy( ki, work( 1 + iv*n ), 1, vr( 1, is ), 1 ) + ii = stdlib_i${ri}$amax( ki, vr( 1, is ), 1 ) remax = one / abs( vr( ii, is ) ) - call stdlib_qscal( ki, remax, vr( 1, is ), 1 ) + call stdlib_${ri}$scal( ki, remax, vr( 1, is ), 1 ) do k = ki + 1, n vr( k, is ) = zero end do else if( nb==1 ) then ! ------------------------------ ! version 1: back-transform each vector with gemv, q*x. - if( ki>1 )call stdlib_qgemv( 'N', n, ki-1, one, vr, ldvr,work( 1 + iv*n ), & + if( ki>1 )call stdlib_${ri}$gemv( 'N', n, ki-1, one, vr, ldvr,work( 1 + iv*n ), & 1, work( ki + iv*n ),vr( 1, ki ), 1 ) - ii = stdlib_iqamax( n, vr( 1, ki ), 1 ) + ii = stdlib_i${ri}$amax( n, vr( 1, ki ), 1 ) remax = one / abs( vr( ii, ki ) ) - call stdlib_qscal( n, remax, vr( 1, ki ), 1 ) + call stdlib_${ri}$scal( n, remax, vr( 1, ki ), 1 ) else ! ------------------------------ ! version 2: back-transform block of vectors with gemm @@ -82535,7 +82536,7 @@ module stdlib_linalg_lapack_q end if if( j1==j2 ) then ! 1-by-1 diagonal block - call stdlib_qlaln2( .false., 1, 2, smin, one, t( j, j ),ldt, one, one, & + call stdlib_${ri}$laln2( .false., 1, 2, smin, one, t( j, j ),ldt, one, one, & work( j+(iv-1)*n ), n,wr, wi, x, 2, scale, xnorm, ierr ) ! scale x(1,1) and x(1,2) to avoid overflow when ! updating the right-hand side. @@ -82548,19 +82549,19 @@ module stdlib_linalg_lapack_q end if ! scale if necessary if( scale/=one ) then - call stdlib_qscal( ki, scale, work( 1+(iv-1)*n ), 1 ) - call stdlib_qscal( ki, scale, work( 1+(iv )*n ), 1 ) + call stdlib_${ri}$scal( ki, scale, work( 1+(iv-1)*n ), 1 ) + call stdlib_${ri}$scal( ki, scale, work( 1+(iv )*n ), 1 ) end if work( j+(iv-1)*n ) = x( 1, 1 ) work( j+(iv )*n ) = x( 1, 2 ) ! update the right-hand side - call stdlib_qaxpy( j-1, -x( 1, 1 ), t( 1, j ), 1,work( 1+(iv-1)*n ), 1 ) + call stdlib_${ri}$axpy( j-1, -x( 1, 1 ), t( 1, j ), 1,work( 1+(iv-1)*n ), 1 ) - call stdlib_qaxpy( j-1, -x( 1, 2 ), t( 1, j ), 1,work( 1+(iv )*n ), 1 ) + call stdlib_${ri}$axpy( j-1, -x( 1, 2 ), t( 1, j ), 1,work( 1+(iv )*n ), 1 ) else ! 2-by-2 diagonal block - call stdlib_qlaln2( .false., 2, 2, smin, one,t( j-1, j-1 ), ldt, one, & + call stdlib_${ri}$laln2( .false., 2, 2, smin, one,t( j-1, j-1 ), ldt, one, & one,work( j-1+(iv-1)*n ), n, wr, wi, x, 2,scale, xnorm, ierr ) ! scale x to avoid overflow when updating ! the right-hand side. @@ -82577,21 +82578,21 @@ module stdlib_linalg_lapack_q end if ! scale if necessary if( scale/=one ) then - call stdlib_qscal( ki, scale, work( 1+(iv-1)*n ), 1 ) - call stdlib_qscal( ki, scale, work( 1+(iv )*n ), 1 ) + call stdlib_${ri}$scal( ki, scale, work( 1+(iv-1)*n ), 1 ) + call stdlib_${ri}$scal( ki, scale, work( 1+(iv )*n ), 1 ) end if work( j-1+(iv-1)*n ) = x( 1, 1 ) work( j +(iv-1)*n ) = x( 2, 1 ) work( j-1+(iv )*n ) = x( 1, 2 ) work( j +(iv )*n ) = x( 2, 2 ) ! update the right-hand side - call stdlib_qaxpy( j-2, -x( 1, 1 ), t( 1, j-1 ), 1,work( 1+(iv-1)*n ),& + call stdlib_${ri}$axpy( j-2, -x( 1, 1 ), t( 1, j-1 ), 1,work( 1+(iv-1)*n ),& 1 ) - call stdlib_qaxpy( j-2, -x( 2, 1 ), t( 1, j ), 1,work( 1+(iv-1)*n ), & + call stdlib_${ri}$axpy( j-2, -x( 2, 1 ), t( 1, j ), 1,work( 1+(iv-1)*n ), & 1 ) - call stdlib_qaxpy( j-2, -x( 1, 2 ), t( 1, j-1 ), 1,work( 1+(iv )*n ), & + call stdlib_${ri}$axpy( j-2, -x( 1, 2 ), t( 1, j-1 ), 1,work( 1+(iv )*n ), & 1 ) - call stdlib_qaxpy( j-2, -x( 2, 2 ), t( 1, j ), 1,work( 1+(iv )*n ), 1 ) + call stdlib_${ri}$axpy( j-2, -x( 2, 2 ), t( 1, j ), 1,work( 1+(iv )*n ), 1 ) end if end do loop_90 @@ -82599,15 +82600,15 @@ module stdlib_linalg_lapack_q if( .not.over ) then ! ------------------------------ ! no back-transform: copy x to vr and normalize. - call stdlib_qcopy( ki, work( 1+(iv-1)*n ), 1, vr(1,is-1), 1 ) - call stdlib_qcopy( ki, work( 1+(iv )*n ), 1, vr(1,is ), 1 ) + call stdlib_${ri}$copy( ki, work( 1+(iv-1)*n ), 1, vr(1,is-1), 1 ) + call stdlib_${ri}$copy( ki, work( 1+(iv )*n ), 1, vr(1,is ), 1 ) emax = zero do k = 1, ki emax = max( emax, abs( vr( k, is-1 ) )+abs( vr( k, is ) ) ) end do remax = one / emax - call stdlib_qscal( ki, remax, vr( 1, is-1 ), 1 ) - call stdlib_qscal( ki, remax, vr( 1, is ), 1 ) + call stdlib_${ri}$scal( ki, remax, vr( 1, is-1 ), 1 ) + call stdlib_${ri}$scal( ki, remax, vr( 1, is ), 1 ) do k = ki + 1, n vr( k, is-1 ) = zero vr( k, is ) = zero @@ -82616,21 +82617,21 @@ module stdlib_linalg_lapack_q ! ------------------------------ ! version 1: back-transform each vector with gemv, q*x. if( ki>2 ) then - call stdlib_qgemv( 'N', n, ki-2, one, vr, ldvr,work( 1 + (iv-1)*n ), & + call stdlib_${ri}$gemv( 'N', n, ki-2, one, vr, ldvr,work( 1 + (iv-1)*n ), & 1,work( ki-1 + (iv-1)*n ), vr(1,ki-1), 1) - call stdlib_qgemv( 'N', n, ki-2, one, vr, ldvr,work( 1 + (iv)*n ), 1,& + call stdlib_${ri}$gemv( 'N', n, ki-2, one, vr, ldvr,work( 1 + (iv)*n ), 1,& work( ki + (iv)*n ), vr( 1, ki ), 1 ) else - call stdlib_qscal( n, work(ki-1+(iv-1)*n), vr(1,ki-1), 1) - call stdlib_qscal( n, work(ki +(iv )*n), vr(1,ki ), 1) + call stdlib_${ri}$scal( n, work(ki-1+(iv-1)*n), vr(1,ki-1), 1) + call stdlib_${ri}$scal( n, work(ki +(iv )*n), vr(1,ki ), 1) end if emax = zero do k = 1, n emax = max( emax, abs( vr( k, ki-1 ) )+abs( vr( k, ki ) ) ) end do remax = one / emax - call stdlib_qscal( n, remax, vr( 1, ki-1 ), 1 ) - call stdlib_qscal( n, remax, vr( 1, ki ), 1 ) + call stdlib_${ri}$scal( n, remax, vr( 1, ki-1 ), 1 ) + call stdlib_${ri}$scal( n, remax, vr( 1, ki ), 1 ) else ! ------------------------------ ! version 2: back-transform block of vectors with gemm @@ -82658,13 +82659,13 @@ module stdlib_linalg_lapack_q ! when the number of vectors stored reaches nb-1 or nb, ! or if this was last vector, do the gemm if( (iv<=2) .or. (ki2==1) ) then - call stdlib_qgemm( 'N', 'N', n, nb-iv+1, ki2+nb-iv, one,vr, ldvr,work( 1 + & + call stdlib_${ri}$gemm( 'N', 'N', n, nb-iv+1, ki2+nb-iv, one,vr, ldvr,work( 1 + & (iv)*n ), n,zero,work( 1 + (nb+iv)*n ), n ) ! normalize vectors do k = iv, nb if( iscomplex(k)==0 ) then ! real eigenvector - ii = stdlib_iqamax( n, work( 1 + (nb+k)*n ), 1 ) + ii = stdlib_i${ri}$amax( n, work( 1 + (nb+k)*n ), 1 ) remax = one / abs( work( ii + (nb+k)*n ) ) else if( iscomplex(k)==1 ) then ! first eigenvector of conjugate pair @@ -82678,9 +82679,9 @@ module stdlib_linalg_lapack_q ! second eigenvector of conjugate pair ! reuse same remax as previous k end if - call stdlib_qscal( n, remax, work( 1 + (nb+k)*n ), 1 ) + call stdlib_${ri}$scal( n, remax, work( 1 + (nb+k)*n ), 1 ) end do - call stdlib_qlacpy( 'F', n, nb-iv+1,work( 1 + (nb+iv)*n ), n,vr( 1, ki2 ), & + call stdlib_${ri}$lacpy( 'F', n, nb-iv+1,work( 1 + (nb+iv)*n ), n,vr( 1, ki2 ), & ldvr ) iv = nb else @@ -82756,17 +82757,17 @@ module stdlib_linalg_lapack_q ! the right-hand side. if( work( j )>vcrit ) then rec = one / vmax - call stdlib_qscal( n-ki+1, rec, work( ki+iv*n ), 1 ) + call stdlib_${ri}$scal( n-ki+1, rec, work( ki+iv*n ), 1 ) vmax = one vcrit = bignum end if - work( j+iv*n ) = work( j+iv*n ) -stdlib_qdot( j-ki-1, t( ki+1, j ), 1,& + work( j+iv*n ) = work( j+iv*n ) -stdlib_${ri}$dot( j-ki-1, t( ki+1, j ), 1,& work( ki+1+iv*n ), 1 ) ! solve [ t(j,j) - wr ]**t * x = work - call stdlib_qlaln2( .false., 1, 1, smin, one, t( j, j ),ldt, one, one, & + call stdlib_${ri}$laln2( .false., 1, 1, smin, one, t( j, j ),ldt, one, one, & work( j+iv*n ), n, wr,zero, x, 2, scale, xnorm, ierr ) ! scale if necessary - if( scale/=one )call stdlib_qscal( n-ki+1, scale, work( ki+iv*n ), 1 ) + if( scale/=one )call stdlib_${ri}$scal( n-ki+1, scale, work( ki+iv*n ), 1 ) work( j+iv*n ) = x( 1, 1 ) vmax = max( abs( work( j+iv*n ) ), vmax ) @@ -82778,21 +82779,21 @@ module stdlib_linalg_lapack_q beta = max( work( j ), work( j+1 ) ) if( beta>vcrit ) then rec = one / vmax - call stdlib_qscal( n-ki+1, rec, work( ki+iv*n ), 1 ) + call stdlib_${ri}$scal( n-ki+1, rec, work( ki+iv*n ), 1 ) vmax = one vcrit = bignum end if - work( j+iv*n ) = work( j+iv*n ) -stdlib_qdot( j-ki-1, t( ki+1, j ), 1,& + work( j+iv*n ) = work( j+iv*n ) -stdlib_${ri}$dot( j-ki-1, t( ki+1, j ), 1,& work( ki+1+iv*n ), 1 ) - work( j+1+iv*n ) = work( j+1+iv*n ) -stdlib_qdot( j-ki-1, t( ki+1, j+1 )& + work( j+1+iv*n ) = work( j+1+iv*n ) -stdlib_${ri}$dot( j-ki-1, t( ki+1, j+1 )& , 1,work( ki+1+iv*n ), 1 ) ! solve ! [ t(j,j)-wr t(j,j+1) ]**t * x = scale*( work1 ) ! [ t(j+1,j) t(j+1,j+1)-wr ] ( work2 ) - call stdlib_qlaln2( .true., 2, 1, smin, one, t( j, j ),ldt, one, one, & + call stdlib_${ri}$laln2( .true., 2, 1, smin, one, t( j, j ),ldt, one, one, & work( j+iv*n ), n, wr,zero, x, 2, scale, xnorm, ierr ) ! scale if necessary - if( scale/=one )call stdlib_qscal( n-ki+1, scale, work( ki+iv*n ), 1 ) + if( scale/=one )call stdlib_${ri}$scal( n-ki+1, scale, work( ki+iv*n ), 1 ) work( j +iv*n ) = x( 1, 1 ) work( j+1+iv*n ) = x( 2, 1 ) @@ -82805,21 +82806,21 @@ module stdlib_linalg_lapack_q if( .not.over ) then ! ------------------------------ ! no back-transform: copy x to vl and normalize. - call stdlib_qcopy( n-ki+1, work( ki + iv*n ), 1,vl( ki, is ), 1 ) - ii = stdlib_iqamax( n-ki+1, vl( ki, is ), 1 ) + ki - 1 + call stdlib_${ri}$copy( n-ki+1, work( ki + iv*n ), 1,vl( ki, is ), 1 ) + ii = stdlib_i${ri}$amax( n-ki+1, vl( ki, is ), 1 ) + ki - 1 remax = one / abs( vl( ii, is ) ) - call stdlib_qscal( n-ki+1, remax, vl( ki, is ), 1 ) + call stdlib_${ri}$scal( n-ki+1, remax, vl( ki, is ), 1 ) do k = 1, ki - 1 vl( k, is ) = zero end do else if( nb==1 ) then ! ------------------------------ ! version 1: back-transform each vector with gemv, q*x. - if( kivcrit ) then rec = one / vmax - call stdlib_qscal( n-ki+1, rec, work(ki+(iv )*n), 1 ) - call stdlib_qscal( n-ki+1, rec, work(ki+(iv+1)*n), 1 ) + call stdlib_${ri}$scal( n-ki+1, rec, work(ki+(iv )*n), 1 ) + call stdlib_${ri}$scal( n-ki+1, rec, work(ki+(iv+1)*n), 1 ) vmax = one vcrit = bignum end if - work( j+(iv )*n ) = work( j+(iv)*n ) -stdlib_qdot( j-ki-2, t( ki+2, j )& + work( j+(iv )*n ) = work( j+(iv)*n ) -stdlib_${ri}$dot( j-ki-2, t( ki+2, j )& , 1,work( ki+2+(iv)*n ), 1 ) - work( j+(iv+1)*n ) = work( j+(iv+1)*n ) -stdlib_qdot( j-ki-2, t( ki+2, & + work( j+(iv+1)*n ) = work( j+(iv+1)*n ) -stdlib_${ri}$dot( j-ki-2, t( ki+2, & j ), 1,work( ki+2+(iv+1)*n ), 1 ) ! solve [ t(j,j)-(wr-i*wi) ]*(x11+i*x12)= wk+i*wk2 - call stdlib_qlaln2( .false., 1, 2, smin, one, t( j, j ),ldt, one, one, & + call stdlib_${ri}$laln2( .false., 1, 2, smin, one, t( j, j ),ldt, one, one, & work( j+iv*n ), n, wr,-wi, x, 2, scale, xnorm, ierr ) ! scale if necessary if( scale/=one ) then - call stdlib_qscal( n-ki+1, scale, work(ki+(iv )*n), 1) - call stdlib_qscal( n-ki+1, scale, work(ki+(iv+1)*n), 1) + call stdlib_${ri}$scal( n-ki+1, scale, work(ki+(iv )*n), 1) + call stdlib_${ri}$scal( n-ki+1, scale, work(ki+(iv+1)*n), 1) end if work( j+(iv )*n ) = x( 1, 1 ) work( j+(iv+1)*n ) = x( 1, 2 ) @@ -82902,28 +82903,28 @@ module stdlib_linalg_lapack_q beta = max( work( j ), work( j+1 ) ) if( beta>vcrit ) then rec = one / vmax - call stdlib_qscal( n-ki+1, rec, work(ki+(iv )*n), 1 ) - call stdlib_qscal( n-ki+1, rec, work(ki+(iv+1)*n), 1 ) + call stdlib_${ri}$scal( n-ki+1, rec, work(ki+(iv )*n), 1 ) + call stdlib_${ri}$scal( n-ki+1, rec, work(ki+(iv+1)*n), 1 ) vmax = one vcrit = bignum end if - work( j +(iv )*n ) = work( j+(iv)*n ) -stdlib_qdot( j-ki-2, t( ki+2, & + work( j +(iv )*n ) = work( j+(iv)*n ) -stdlib_${ri}$dot( j-ki-2, t( ki+2, & j ), 1,work( ki+2+(iv)*n ), 1 ) - work( j +(iv+1)*n ) = work( j+(iv+1)*n ) -stdlib_qdot( j-ki-2, t( ki+2,& + work( j +(iv+1)*n ) = work( j+(iv+1)*n ) -stdlib_${ri}$dot( j-ki-2, t( ki+2,& j ), 1,work( ki+2+(iv+1)*n ), 1 ) - work( j+1+(iv )*n ) = work( j+1+(iv)*n ) -stdlib_qdot( j-ki-2, t( ki+2,& + work( j+1+(iv )*n ) = work( j+1+(iv)*n ) -stdlib_${ri}$dot( j-ki-2, t( ki+2,& j+1 ), 1,work( ki+2+(iv)*n ), 1 ) - work( j+1+(iv+1)*n ) = work( j+1+(iv+1)*n ) -stdlib_qdot( j-ki-2, t( ki+& + work( j+1+(iv+1)*n ) = work( j+1+(iv+1)*n ) -stdlib_${ri}$dot( j-ki-2, t( ki+& 2, j+1 ), 1,work( ki+2+(iv+1)*n ), 1 ) ! solve 2-by-2 complex linear equation ! [ (t(j,j) t(j,j+1) )**t - (wr-i*wi)*i ]*x = scale*b ! [ (t(j+1,j) t(j+1,j+1)) ] - call stdlib_qlaln2( .true., 2, 2, smin, one, t( j, j ),ldt, one, one, & + call stdlib_${ri}$laln2( .true., 2, 2, smin, one, t( j, j ),ldt, one, one, & work( j+iv*n ), n, wr,-wi, x, 2, scale, xnorm, ierr ) ! scale if necessary if( scale/=one ) then - call stdlib_qscal( n-ki+1, scale, work(ki+(iv )*n), 1) - call stdlib_qscal( n-ki+1, scale, work(ki+(iv+1)*n), 1) + call stdlib_${ri}$scal( n-ki+1, scale, work(ki+(iv )*n), 1) + call stdlib_${ri}$scal( n-ki+1, scale, work(ki+(iv+1)*n), 1) end if work( j +(iv )*n ) = x( 1, 1 ) work( j +(iv+1)*n ) = x( 1, 2 ) @@ -82938,17 +82939,17 @@ module stdlib_linalg_lapack_q if( .not.over ) then ! ------------------------------ ! no back-transform: copy x to vl and normalize. - call stdlib_qcopy( n-ki+1, work( ki + (iv )*n ), 1,vl( ki, is ), 1 ) + call stdlib_${ri}$copy( n-ki+1, work( ki + (iv )*n ), 1,vl( ki, is ), 1 ) - call stdlib_qcopy( n-ki+1, work( ki + (iv+1)*n ), 1,vl( ki, is+1 ), 1 ) + call stdlib_${ri}$copy( n-ki+1, work( ki + (iv+1)*n ), 1,vl( ki, is+1 ), 1 ) emax = zero do k = ki, n emax = max( emax, abs( vl( k, is ) )+abs( vl( k, is+1 ) ) ) end do remax = one / emax - call stdlib_qscal( n-ki+1, remax, vl( ki, is ), 1 ) - call stdlib_qscal( n-ki+1, remax, vl( ki, is+1 ), 1 ) + call stdlib_${ri}$scal( n-ki+1, remax, vl( ki, is ), 1 ) + call stdlib_${ri}$scal( n-ki+1, remax, vl( ki, is+1 ), 1 ) do k = 1, ki - 1 vl( k, is ) = zero vl( k, is+1 ) = zero @@ -82957,21 +82958,21 @@ module stdlib_linalg_lapack_q ! ------------------------------ ! version 1: back-transform each vector with gemv, q*x. if( ki=nb-1) .or. (ki2==n) ) then - call stdlib_qgemm( 'N', 'N', n, iv, n-ki2+iv, one,vl( 1, ki2-iv+1 ), ldvl,& + call stdlib_${ri}$gemm( 'N', 'N', n, iv, n-ki2+iv, one,vl( 1, ki2-iv+1 ), ldvl,& work( ki2-iv+1 + (1)*n ), n,zero,work( 1 + (nb+1)*n ), n ) ! normalize vectors do k = 1, iv if( iscomplex(k)==0) then ! real eigenvector - ii = stdlib_iqamax( n, work( 1 + (nb+k)*n ), 1 ) + ii = stdlib_i${ri}$amax( n, work( 1 + (nb+k)*n ), 1 ) remax = one / abs( work( ii + (nb+k)*n ) ) else if( iscomplex(k)==1) then ! first eigenvector of conjugate pair @@ -83020,9 +83021,9 @@ module stdlib_linalg_lapack_q ! second eigenvector of conjugate pair ! reuse same remax as previous k end if - call stdlib_qscal( n, remax, work( 1 + (nb+k)*n ), 1 ) + call stdlib_${ri}$scal( n, remax, work( 1 + (nb+k)*n ), 1 ) end do - call stdlib_qlacpy( 'F', n, iv,work( 1 + (nb+1)*n ), n,vl( 1, ki2-iv+1 ), & + call stdlib_${ri}$lacpy( 'F', n, iv,work( 1 + (nb+1)*n ), n,vl( 1, ki2-iv+1 ), & ldvl ) iv = 1 else @@ -83034,10 +83035,10 @@ module stdlib_linalg_lapack_q end do loop_260 end if return - end subroutine stdlib_qtrevc3 + end subroutine stdlib_${ri}$trevc3 - subroutine stdlib_qtrexc( compq, n, t, ldt, q, ldq, ifst, ilst, work,info ) + subroutine stdlib_${ri}$trexc( compq, n, t, ldt, q, ldq, ifst, ilst, work,info ) !! DTREXC: reorders the real Schur factorization of a real matrix !! A = Q*T*Q**T, so that the diagonal block of T with row index IFST is !! moved to row ILST. @@ -83057,8 +83058,8 @@ module stdlib_linalg_lapack_q integer(ilp), intent(out) :: info integer(ilp), intent(in) :: ldq, ldt, n ! Array Arguments - real(qp), intent(inout) :: q(ldq,*), t(ldt,*) - real(qp), intent(out) :: work(*) + real(${rk}$), intent(inout) :: q(ldq,*), t(ldt,*) + real(${rk}$), intent(out) :: work(*) ! ===================================================================== ! Local Scalars @@ -83121,7 +83122,7 @@ module stdlib_linalg_lapack_q if( here+nbf+1<=n ) then if( t( here+nbf+1, here+nbf )/=zero )nbnext = 2 end if - call stdlib_qlaexc( wantq, n, t, ldt, q, ldq, here, nbf, nbnext,work, info ) + call stdlib_${ri}$laexc( wantq, n, t, ldt, q, ldq, here, nbf, nbnext,work, info ) if( info/=0 ) then ilst = here @@ -83139,7 +83140,7 @@ module stdlib_linalg_lapack_q if( here+3<=n ) then if( t( here+3, here+2 )/=zero )nbnext = 2 end if - call stdlib_qlaexc( wantq, n, t, ldt, q, ldq, here+1, 1, nbnext,work, info ) + call stdlib_${ri}$laexc( wantq, n, t, ldt, q, ldq, here+1, 1, nbnext,work, info ) if( info/=0 ) then ilst = here @@ -83147,7 +83148,7 @@ module stdlib_linalg_lapack_q end if if( nbnext==1 ) then ! swap two 1 by 1 blocks, no problems possible - call stdlib_qlaexc( wantq, n, t, ldt, q, ldq, here, 1, nbnext,work, info ) + call stdlib_${ri}$laexc( wantq, n, t, ldt, q, ldq, here, 1, nbnext,work, info ) here = here + 1 else @@ -83155,7 +83156,7 @@ module stdlib_linalg_lapack_q if( t( here+2, here+1 )==zero )nbnext = 1 if( nbnext==2 ) then ! 2 by 2 block did not split - call stdlib_qlaexc( wantq, n, t, ldt, q, ldq, here, 1,nbnext, work, info ) + call stdlib_${ri}$laexc( wantq, n, t, ldt, q, ldq, here, 1,nbnext, work, info ) if( info/=0 ) then ilst = here @@ -83164,9 +83165,9 @@ module stdlib_linalg_lapack_q here = here + 2 else ! 2 by 2 block did split - call stdlib_qlaexc( wantq, n, t, ldt, q, ldq, here, 1, 1,work, info ) + call stdlib_${ri}$laexc( wantq, n, t, ldt, q, ldq, here, 1, 1,work, info ) - call stdlib_qlaexc( wantq, n, t, ldt, q, ldq, here+1, 1, 1,work, info ) + call stdlib_${ri}$laexc( wantq, n, t, ldt, q, ldq, here+1, 1, 1,work, info ) here = here + 2 end if @@ -83183,7 +83184,7 @@ module stdlib_linalg_lapack_q if( here>=3 ) then if( t( here-1, here-2 )/=zero )nbnext = 2 end if - call stdlib_qlaexc( wantq, n, t, ldt, q, ldq, here-nbnext, nbnext,nbf, work, & + call stdlib_${ri}$laexc( wantq, n, t, ldt, q, ldq, here-nbnext, nbnext,nbf, work, & info ) if( info/=0 ) then ilst = here @@ -83201,7 +83202,7 @@ module stdlib_linalg_lapack_q if( here>=3 ) then if( t( here-1, here-2 )/=zero )nbnext = 2 end if - call stdlib_qlaexc( wantq, n, t, ldt, q, ldq, here-nbnext, nbnext,1, work, info ) + call stdlib_${ri}$laexc( wantq, n, t, ldt, q, ldq, here-nbnext, nbnext,1, work, info ) if( info/=0 ) then ilst = here @@ -83209,7 +83210,7 @@ module stdlib_linalg_lapack_q end if if( nbnext==1 ) then ! swap two 1 by 1 blocks, no problems possible - call stdlib_qlaexc( wantq, n, t, ldt, q, ldq, here, nbnext, 1,work, info ) + call stdlib_${ri}$laexc( wantq, n, t, ldt, q, ldq, here, nbnext, 1,work, info ) here = here - 1 else @@ -83217,7 +83218,7 @@ module stdlib_linalg_lapack_q if( t( here, here-1 )==zero )nbnext = 1 if( nbnext==2 ) then ! 2 by 2 block did not split - call stdlib_qlaexc( wantq, n, t, ldt, q, ldq, here-1, 2, 1,work, info ) + call stdlib_${ri}$laexc( wantq, n, t, ldt, q, ldq, here-1, 2, 1,work, info ) if( info/=0 ) then ilst = here @@ -83226,9 +83227,9 @@ module stdlib_linalg_lapack_q here = here - 2 else ! 2 by 2 block did split - call stdlib_qlaexc( wantq, n, t, ldt, q, ldq, here, 1, 1,work, info ) + call stdlib_${ri}$laexc( wantq, n, t, ldt, q, ldq, here, 1, 1,work, info ) - call stdlib_qlaexc( wantq, n, t, ldt, q, ldq, here-1, 1, 1,work, info ) + call stdlib_${ri}$laexc( wantq, n, t, ldt, q, ldq, here-1, 1, 1,work, info ) here = here - 2 end if @@ -83238,10 +83239,10 @@ module stdlib_linalg_lapack_q end if ilst = here return - end subroutine stdlib_qtrexc + end subroutine stdlib_${ri}$trexc - pure subroutine stdlib_qtrrfs( uplo, trans, diag, n, nrhs, a, lda, b, ldb, x,ldx, ferr, berr,& + pure subroutine stdlib_${ri}$trrfs( uplo, trans, diag, n, nrhs, a, lda, b, ldb, x,ldx, ferr, berr,& !! DTRRFS: provides error bounds and backward error estimates for the !! solution to a system of linear equations with a triangular !! coefficient matrix. @@ -83258,8 +83259,8 @@ module stdlib_linalg_lapack_q integer(ilp), intent(in) :: lda, ldb, ldx, n, nrhs ! Array Arguments integer(ilp), intent(out) :: iwork(*) - real(qp), intent(in) :: a(lda,*), b(ldb,*), x(ldx,*) - real(qp), intent(out) :: berr(*), ferr(*), work(*) + real(${rk}$), intent(in) :: a(lda,*), b(ldb,*), x(ldx,*) + real(${rk}$), intent(out) :: berr(*), ferr(*), work(*) ! ===================================================================== @@ -83267,7 +83268,7 @@ module stdlib_linalg_lapack_q logical(lk) :: notran, nounit, upper character :: transt integer(ilp) :: i, j, k, kase, nz - real(qp) :: eps, lstres, s, safe1, safe2, safmin, xk + real(${rk}$) :: eps, lstres, s, safe1, safe2, safmin, xk ! Local Arrays integer(ilp) :: isave(3) ! Intrinsic Functions @@ -83315,17 +83316,17 @@ module stdlib_linalg_lapack_q end if ! nz = maximum number of nonzero elements in each row of a, plus 1 nz = n + 1 - eps = stdlib_qlamch( 'EPSILON' ) - safmin = stdlib_qlamch( 'SAFE MINIMUM' ) + eps = stdlib_${ri}$lamch( 'EPSILON' ) + safmin = stdlib_${ri}$lamch( 'SAFE MINIMUM' ) safe1 = nz*safmin safe2 = safe1 / eps ! do for each right hand side loop_250: do j = 1, nrhs ! compute residual r = b - op(a) * x, ! where op(a) = a or a**t, depending on trans. - call stdlib_qcopy( n, x( 1, j ), 1, work( n+1 ), 1 ) - call stdlib_qtrmv( uplo, trans, diag, n, a, lda, work( n+1 ), 1 ) - call stdlib_qaxpy( n, -one, b( 1, j ), 1, work( n+1 ), 1 ) + call stdlib_${ri}$copy( n, x( 1, j ), 1, work( n+1 ), 1 ) + call stdlib_${ri}$trmv( uplo, trans, diag, n, a, lda, work( n+1 ), 1 ) + call stdlib_${ri}$axpy( n, -one, b( 1, j ), 1, work( n+1 ), 1 ) ! compute componentwise relative backward error from formula ! max(i) ( abs(r(i)) / ( abs(op(a))*abs(x) + abs(b) )(i) ) ! where abs(z) is the componentwise absolute value of the matrix @@ -83435,7 +83436,7 @@ module stdlib_linalg_lapack_q ! the i-th component of abs(r)+nz*eps*(abs(op(a))*abs(x)+abs(b)) ! is incremented by safe1 if the i-th component of ! abs(op(a))*abs(x) + abs(b) is less than safe2. - ! use stdlib_qlacn2 to estimate the infinity-norm of the matrix + ! use stdlib_${ri}$lacn2 to estimate the infinity-norm of the matrix ! inv(op(a)) * diag(w), ! where w = abs(r) + nz*eps*( abs(op(a))*abs(x)+abs(b) ))) do i = 1, n @@ -83447,12 +83448,12 @@ module stdlib_linalg_lapack_q end do kase = 0 210 continue - call stdlib_qlacn2( n, work( 2*n+1 ), work( n+1 ), iwork, ferr( j ),kase, isave ) + call stdlib_${ri}$lacn2( n, work( 2*n+1 ), work( n+1 ), iwork, ferr( j ),kase, isave ) if( kase/=0 ) then if( kase==1 ) then ! multiply by diag(w)*inv(op(a)**t). - call stdlib_qtrsv( uplo, transt, diag, n, a, lda, work( n+1 ),1 ) + call stdlib_${ri}$trsv( uplo, transt, diag, n, a, lda, work( n+1 ),1 ) do i = 1, n work( n+i ) = work( i )*work( n+i ) end do @@ -83461,7 +83462,7 @@ module stdlib_linalg_lapack_q do i = 1, n work( n+i ) = work( i )*work( n+i ) end do - call stdlib_qtrsv( uplo, trans, diag, n, a, lda, work( n+1 ),1 ) + call stdlib_${ri}$trsv( uplo, trans, diag, n, a, lda, work( n+1 ),1 ) end if go to 210 end if @@ -83473,10 +83474,10 @@ module stdlib_linalg_lapack_q if( lstres/=zero )ferr( j ) = ferr( j ) / lstres end do loop_250 return - end subroutine stdlib_qtrrfs + end subroutine stdlib_${ri}$trrfs - subroutine stdlib_qtrsen( job, compq, select, n, t, ldt, q, ldq, wr, wi,m, s, sep, work, & + subroutine stdlib_${ri}$trsen( job, compq, select, n, t, ldt, q, ldq, wr, wi,m, s, sep, work, & !! DTRSEN: reorders the real Schur factorization of a real matrix !! A = Q*T*Q**T, so that a selected cluster of eigenvalues appears in !! the leading diagonal blocks of the upper quasi-triangular matrix T, @@ -83496,18 +83497,18 @@ module stdlib_linalg_lapack_q character, intent(in) :: compq, job integer(ilp), intent(out) :: info, m integer(ilp), intent(in) :: ldq, ldt, liwork, lwork, n - real(qp), intent(out) :: s, sep + real(${rk}$), intent(out) :: s, sep ! Array Arguments logical(lk), intent(in) :: select(*) integer(ilp), intent(out) :: iwork(*) - real(qp), intent(inout) :: q(ldq,*), t(ldt,*) - real(qp), intent(out) :: wi(*), work(*), wr(*) + real(${rk}$), intent(inout) :: q(ldq,*), t(ldt,*) + real(${rk}$), intent(out) :: wi(*), work(*), wr(*) ! ===================================================================== ! Local Scalars logical(lk) :: lquery, pair, swap, wantbh, wantq, wants, wantsp integer(ilp) :: ierr, k, kase, kk, ks, liwmin, lwmin, n1, n2, nn - real(qp) :: est, rnorm, scale + real(${rk}$) :: est, rnorm, scale ! Local Arrays integer(ilp) :: isave(3) ! Intrinsic Functions @@ -83583,7 +83584,7 @@ module stdlib_linalg_lapack_q ! quick return if possible. if( m==n .or. m==0 ) then if( wants )s = one - if( wantsp )sep = stdlib_qlange( '1', n, n, t, ldt, work ) + if( wantsp )sep = stdlib_${ri}$lange( '1', n, n, t, ldt, work ) go to 40 end if ! collect the selected blocks at the top-left corner of t. @@ -83605,7 +83606,7 @@ module stdlib_linalg_lapack_q ! swap the k-th block to position ks. ierr = 0 kk = k - if( k/=ks )call stdlib_qtrexc( compq, n, t, ldt, q, ldq, kk, ks, work,ierr ) + if( k/=ks )call stdlib_${ri}$trexc( compq, n, t, ldt, q, ldq, kk, ks, work,ierr ) if( ierr==1 .or. ierr==2 ) then ! blocks too close to swap: exit. @@ -83621,12 +83622,12 @@ module stdlib_linalg_lapack_q if( wants ) then ! solve sylvester equation for r: ! t11*r - r*t22 = scale*t12 - call stdlib_qlacpy( 'F', n1, n2, t( 1, n1+1 ), ldt, work, n1 ) - call stdlib_qtrsyl( 'N', 'N', -1, n1, n2, t, ldt, t( n1+1, n1+1 ),ldt, work, n1, & + call stdlib_${ri}$lacpy( 'F', n1, n2, t( 1, n1+1 ), ldt, work, n1 ) + call stdlib_${ri}$trsyl( 'N', 'N', -1, n1, n2, t, ldt, t( n1+1, n1+1 ),ldt, work, n1, & scale, ierr ) ! estimate the reciprocal of the condition number of the cluster ! of eigenvalues. - rnorm = stdlib_qlange( 'F', n1, n2, work, n1, work ) + rnorm = stdlib_${ri}$lange( 'F', n1, n2, work, n1, work ) if( rnorm==zero ) then s = one else @@ -83638,15 +83639,15 @@ module stdlib_linalg_lapack_q est = zero kase = 0 30 continue - call stdlib_qlacn2( nn, work( nn+1 ), work, iwork, est, kase, isave ) + call stdlib_${ri}$lacn2( nn, work( nn+1 ), work, iwork, est, kase, isave ) if( kase/=0 ) then if( kase==1 ) then ! solve t11*r - r*t22 = scale*x. - call stdlib_qtrsyl( 'N', 'N', -1, n1, n2, t, ldt,t( n1+1, n1+1 ), ldt, work, & + call stdlib_${ri}$trsyl( 'N', 'N', -1, n1, n2, t, ldt,t( n1+1, n1+1 ), ldt, work, & n1, scale,ierr ) else ! solve t11**t*r - r*t22**t = scale*x. - call stdlib_qtrsyl( 'T', 'T', -1, n1, n2, t, ldt,t( n1+1, n1+1 ), ldt, work, & + call stdlib_${ri}$trsyl( 'T', 'T', -1, n1, n2, t, ldt,t( n1+1, n1+1 ), ldt, work, & n1, scale,ierr ) end if go to 30 @@ -83668,10 +83669,10 @@ module stdlib_linalg_lapack_q work( 1 ) = lwmin iwork( 1 ) = liwmin return - end subroutine stdlib_qtrsen + end subroutine stdlib_${ri}$trsen - subroutine stdlib_qtrsna( job, howmny, select, n, t, ldt, vl, ldvl, vr,ldvr, s, sep, mm, m, & + subroutine stdlib_${ri}$trsna( job, howmny, select, n, t, ldt, vl, ldvl, vr,ldvr, s, sep, mm, m, & !! DTRSNA: estimates reciprocal condition numbers for specified !! eigenvalues and/or right eigenvectors of a real upper !! quasi-triangular matrix T (or of any matrix Q*T*Q**T with Q @@ -83691,18 +83692,18 @@ module stdlib_linalg_lapack_q ! Array Arguments logical(lk), intent(in) :: select(*) integer(ilp), intent(out) :: iwork(*) - real(qp), intent(out) :: s(*), sep(*), work(ldwork,*) - real(qp), intent(in) :: t(ldt,*), vl(ldvl,*), vr(ldvr,*) + real(${rk}$), intent(out) :: s(*), sep(*), work(ldwork,*) + real(${rk}$), intent(in) :: t(ldt,*), vl(ldvl,*), vr(ldvr,*) ! ===================================================================== ! Local Scalars logical(lk) :: pair, somcon, wantbh, wants, wantsp integer(ilp) :: i, ierr, ifst, ilst, j, k, kase, ks, n2, nn - real(qp) :: bignum, cond, cs, delta, dumm, eps, est, lnrm, mu, prod, prod1, prod2, & + real(${rk}$) :: bignum, cond, cs, delta, dumm, eps, est, lnrm, mu, prod, prod1, prod2, & rnrm, scale, smlnum, sn ! Local Arrays integer(ilp) :: isave(3) - real(qp) :: dummy(1) + real(${rk}$) :: dummy(1) ! Intrinsic Functions intrinsic :: abs,max,sqrt ! Executable Statements @@ -83770,10 +83771,10 @@ module stdlib_linalg_lapack_q return end if ! get machine constants - eps = stdlib_qlamch( 'P' ) - smlnum = stdlib_qlamch( 'S' ) / eps + eps = stdlib_${ri}$lamch( 'P' ) + smlnum = stdlib_${ri}$lamch( 'S' ) / eps bignum = one / smlnum - call stdlib_qlabad( smlnum, bignum ) + call stdlib_${ri}$labad( smlnum, bignum ) ks = 0 pair = .false. loop_60: do k = 1, n @@ -83799,21 +83800,21 @@ module stdlib_linalg_lapack_q ! eigenvalue. if( .not.pair ) then ! real eigenvalue. - prod = stdlib_qdot( n, vr( 1, ks ), 1, vl( 1, ks ), 1 ) - rnrm = stdlib_qnrm2( n, vr( 1, ks ), 1 ) - lnrm = stdlib_qnrm2( n, vl( 1, ks ), 1 ) + prod = stdlib_${ri}$dot( n, vr( 1, ks ), 1, vl( 1, ks ), 1 ) + rnrm = stdlib_${ri}$nrm2( n, vr( 1, ks ), 1 ) + lnrm = stdlib_${ri}$nrm2( n, vl( 1, ks ), 1 ) s( ks ) = abs( prod ) / ( rnrm*lnrm ) else ! complex eigenvalue. - prod1 = stdlib_qdot( n, vr( 1, ks ), 1, vl( 1, ks ), 1 ) - prod1 = prod1 + stdlib_qdot( n, vr( 1, ks+1 ), 1, vl( 1, ks+1 ),1 ) - prod2 = stdlib_qdot( n, vl( 1, ks ), 1, vr( 1, ks+1 ), 1 ) - prod2 = prod2 - stdlib_qdot( n, vl( 1, ks+1 ), 1, vr( 1, ks ),1 ) - rnrm = stdlib_qlapy2( stdlib_qnrm2( n, vr( 1, ks ), 1 ),stdlib_qnrm2( n, vr( & + prod1 = stdlib_${ri}$dot( n, vr( 1, ks ), 1, vl( 1, ks ), 1 ) + prod1 = prod1 + stdlib_${ri}$dot( n, vr( 1, ks+1 ), 1, vl( 1, ks+1 ),1 ) + prod2 = stdlib_${ri}$dot( n, vl( 1, ks ), 1, vr( 1, ks+1 ), 1 ) + prod2 = prod2 - stdlib_${ri}$dot( n, vl( 1, ks+1 ), 1, vr( 1, ks ),1 ) + rnrm = stdlib_${ri}$lapy2( stdlib_${ri}$nrm2( n, vr( 1, ks ), 1 ),stdlib_${ri}$nrm2( n, vr( & 1, ks+1 ), 1 ) ) - lnrm = stdlib_qlapy2( stdlib_qnrm2( n, vl( 1, ks ), 1 ),stdlib_qnrm2( n, vl( & + lnrm = stdlib_${ri}$lapy2( stdlib_${ri}$nrm2( n, vl( 1, ks ), 1 ),stdlib_${ri}$nrm2( n, vl( & 1, ks+1 ), 1 ) ) - cond = stdlib_qlapy2( prod1, prod2 ) / ( rnrm*lnrm ) + cond = stdlib_${ri}$lapy2( prod1, prod2 ) / ( rnrm*lnrm ) s( ks ) = cond s( ks+1 ) = cond end if @@ -83823,10 +83824,10 @@ module stdlib_linalg_lapack_q ! eigenvector. ! copy the matrix t to the array work and swap the diagonal ! block beginning at t(k,k) to the (1,1) position. - call stdlib_qlacpy( 'FULL', n, n, t, ldt, work, ldwork ) + call stdlib_${ri}$lacpy( 'FULL', n, n, t, ldt, work, ldwork ) ifst = k ilst = 1 - call stdlib_qtrexc( 'NO Q', n, work, ldwork, dummy, 1, ifst, ilst,work( 1, n+1 ),& + call stdlib_${ri}$trexc( 'NO Q', n, work, ldwork, dummy, 1, ifst, ilst,work( 1, n+1 ),& ierr ) if( ierr==1 .or. ierr==2 ) then ! could not swap because blocks not well separated @@ -83850,7 +83851,7 @@ module stdlib_linalg_lapack_q ! position of work is the complex eigenvalue lambda ! with negative imaginary part. mu = sqrt( abs( work( 1, 2 ) ) )*sqrt( abs( work( 2, 1 ) ) ) - delta = stdlib_qlapy2( mu, work( 2, 1 ) ) + delta = stdlib_${ri}$lapy2( mu, work( 2, 1 ) ) cs = mu / delta sn = -work( 2, 1 ) / delta ! form @@ -83878,29 +83879,29 @@ module stdlib_linalg_lapack_q est = zero kase = 0 50 continue - call stdlib_qlacn2( nn, work( 1, n+2 ), work( 1, n+4 ), iwork,est, kase, & + call stdlib_${ri}$lacn2( nn, work( 1, n+2 ), work( 1, n+4 ), iwork,est, kase, & isave ) if( kase/=0 ) then if( kase==1 ) then if( n2==1 ) then ! real eigenvalue: solve c**t*x = scale*c. - call stdlib_qlaqtr( .true., .true., n-1, work( 2, 2 ),ldwork, dummy, & + call stdlib_${ri}$laqtr( .true., .true., n-1, work( 2, 2 ),ldwork, dummy, & dumm, scale,work( 1, n+4 ), work( 1, n+6 ),ierr ) else ! complex eigenvalue: solve ! c**t*(p+iq) = scale*(c+id) in real arithmetic. - call stdlib_qlaqtr( .true., .false., n-1, work( 2, 2 ),ldwork, work( & + call stdlib_${ri}$laqtr( .true., .false., n-1, work( 2, 2 ),ldwork, work( & 1, n+1 ), mu, scale,work( 1, n+4 ), work( 1, n+6 ),ierr ) end if else if( n2==1 ) then ! real eigenvalue: solve c*x = scale*c. - call stdlib_qlaqtr( .false., .true., n-1, work( 2, 2 ),ldwork, dummy,& + call stdlib_${ri}$laqtr( .false., .true., n-1, work( 2, 2 ),ldwork, dummy,& dumm, scale,work( 1, n+4 ), work( 1, n+6 ),ierr ) else ! complex eigenvalue: solve ! c*(p+iq) = scale*(c+id) in real arithmetic. - call stdlib_qlaqtr( .false., .false., n-1,work( 2, 2 ), ldwork,work( & + call stdlib_${ri}$laqtr( .false., .false., n-1,work( 2, 2 ), ldwork,work( & 1, n+1 ), mu, scale,work( 1, n+4 ), work( 1, n+6 ),ierr ) end if end if @@ -83913,10 +83914,10 @@ module stdlib_linalg_lapack_q if( pair )ks = ks + 1 end do loop_60 return - end subroutine stdlib_qtrsna + end subroutine stdlib_${ri}$trsna - subroutine stdlib_qtrsyl( trana, tranb, isgn, m, n, a, lda, b, ldb, c,ldc, scale, info ) + subroutine stdlib_${ri}$trsyl( trana, tranb, isgn, m, n, a, lda, b, ldb, c,ldc, scale, info ) !! DTRSYL: solves the real Sylvester matrix equation: !! op(A)*X + X*op(B) = scale*C or !! op(A)*X - X*op(B) = scale*C, @@ -83936,19 +83937,19 @@ module stdlib_linalg_lapack_q character, intent(in) :: trana, tranb integer(ilp), intent(out) :: info integer(ilp), intent(in) :: isgn, lda, ldb, ldc, m, n - real(qp), intent(out) :: scale + real(${rk}$), intent(out) :: scale ! Array Arguments - real(qp), intent(in) :: a(lda,*), b(ldb,*) - real(qp), intent(inout) :: c(ldc,*) + real(${rk}$), intent(in) :: a(lda,*), b(ldb,*) + real(${rk}$), intent(inout) :: c(ldc,*) ! ===================================================================== ! Local Scalars logical(lk) :: notrna, notrnb integer(ilp) :: ierr, j, k, k1, k2, knext, l, l1, l2, lnext - real(qp) :: a11, bignum, da11, db, eps, scaloc, sgn, smin, smlnum, suml, sumr, & + real(${rk}$) :: a11, bignum, da11, db, eps, scaloc, sgn, smin, smlnum, suml, sumr, & xnorm ! Local Arrays - real(qp) :: dum(1), vec(2,2), x(2,2) + real(${rk}$) :: dum(1), vec(2,2), x(2,2) ! Intrinsic Functions intrinsic :: abs,real,max,min ! Executable Statements @@ -83983,13 +83984,13 @@ module stdlib_linalg_lapack_q scale = one if( m==0 .or. n==0 )return ! set constants to control overflow - eps = stdlib_qlamch( 'P' ) - smlnum = stdlib_qlamch( 'S' ) + eps = stdlib_${ri}$lamch( 'P' ) + smlnum = stdlib_${ri}$lamch( 'S' ) bignum = one / smlnum - call stdlib_qlabad( smlnum, bignum ) - smlnum = smlnum*real( m*n,KIND=qp) / eps + call stdlib_${ri}$labad( smlnum, bignum ) + smlnum = smlnum*real( m*n,KIND=${rk}$) / eps bignum = one / smlnum - smin = max( smlnum, eps*stdlib_qlange( 'M', m, m, a, lda, dum ),eps*stdlib_qlange( 'M',& + smin = max( smlnum, eps*stdlib_${ri}$lange( 'M', m, m, a, lda, dum ),eps*stdlib_${ri}$lange( 'M',& n, n, b, ldb, dum ) ) sgn = isgn if( notrna .and. notrnb ) then @@ -84040,9 +84041,9 @@ module stdlib_linalg_lapack_q end if end if if( l1==l2 .and. k1==k2 ) then - suml = stdlib_qdot( m-k1, a( k1, min( k1+1, m ) ), lda,c( min( k1+1, m ), & + suml = stdlib_${ri}$dot( m-k1, a( k1, min( k1+1, m ) ), lda,c( min( k1+1, m ), & l1 ), 1 ) - sumr = stdlib_qdot( l1-1, c( k1, 1 ), ldc, b( 1, l1 ), 1 ) + sumr = stdlib_${ri}$dot( l1-1, c( k1, 1 ), ldc, b( 1, l1 ), 1 ) vec( 1, 1 ) = c( k1, l1 ) - ( suml+sgn*sumr ) scaloc = one a11 = a( k1, k1 ) + sgn*b( l1, l1 ) @@ -84059,74 +84060,74 @@ module stdlib_linalg_lapack_q x( 1, 1 ) = ( vec( 1, 1 )*scaloc ) / a11 if( scaloc/=one ) then do j = 1, n - call stdlib_qscal( m, scaloc, c( 1, j ), 1 ) + call stdlib_${ri}$scal( m, scaloc, c( 1, j ), 1 ) end do scale = scale*scaloc end if c( k1, l1 ) = x( 1, 1 ) else if( l1==l2 .and. k1/=k2 ) then - suml = stdlib_qdot( m-k2, a( k1, min( k2+1, m ) ), lda,c( min( k2+1, m ), & + suml = stdlib_${ri}$dot( m-k2, a( k1, min( k2+1, m ) ), lda,c( min( k2+1, m ), & l1 ), 1 ) - sumr = stdlib_qdot( l1-1, c( k1, 1 ), ldc, b( 1, l1 ), 1 ) + sumr = stdlib_${ri}$dot( l1-1, c( k1, 1 ), ldc, b( 1, l1 ), 1 ) vec( 1, 1 ) = c( k1, l1 ) - ( suml+sgn*sumr ) - suml = stdlib_qdot( m-k2, a( k2, min( k2+1, m ) ), lda,c( min( k2+1, m ), & + suml = stdlib_${ri}$dot( m-k2, a( k2, min( k2+1, m ) ), lda,c( min( k2+1, m ), & l1 ), 1 ) - sumr = stdlib_qdot( l1-1, c( k2, 1 ), ldc, b( 1, l1 ), 1 ) + sumr = stdlib_${ri}$dot( l1-1, c( k2, 1 ), ldc, b( 1, l1 ), 1 ) vec( 2, 1 ) = c( k2, l1 ) - ( suml+sgn*sumr ) - call stdlib_qlaln2( .false., 2, 1, smin, one, a( k1, k1 ),lda, one, one, & + call stdlib_${ri}$laln2( .false., 2, 1, smin, one, a( k1, k1 ),lda, one, one, & vec, 2, -sgn*b( l1, l1 ),zero, x, 2, scaloc, xnorm, ierr ) if( ierr/=0 )info = 1 if( scaloc/=one ) then do j = 1, n - call stdlib_qscal( m, scaloc, c( 1, j ), 1 ) + call stdlib_${ri}$scal( m, scaloc, c( 1, j ), 1 ) end do scale = scale*scaloc end if c( k1, l1 ) = x( 1, 1 ) c( k2, l1 ) = x( 2, 1 ) else if( l1/=l2 .and. k1==k2 ) then - suml = stdlib_qdot( m-k1, a( k1, min( k1+1, m ) ), lda,c( min( k1+1, m ), & + suml = stdlib_${ri}$dot( m-k1, a( k1, min( k1+1, m ) ), lda,c( min( k1+1, m ), & l1 ), 1 ) - sumr = stdlib_qdot( l1-1, c( k1, 1 ), ldc, b( 1, l1 ), 1 ) + sumr = stdlib_${ri}$dot( l1-1, c( k1, 1 ), ldc, b( 1, l1 ), 1 ) vec( 1, 1 ) = sgn*( c( k1, l1 )-( suml+sgn*sumr ) ) - suml = stdlib_qdot( m-k1, a( k1, min( k1+1, m ) ), lda,c( min( k1+1, m ), & + suml = stdlib_${ri}$dot( m-k1, a( k1, min( k1+1, m ) ), lda,c( min( k1+1, m ), & l2 ), 1 ) - sumr = stdlib_qdot( l1-1, c( k1, 1 ), ldc, b( 1, l2 ), 1 ) + sumr = stdlib_${ri}$dot( l1-1, c( k1, 1 ), ldc, b( 1, l2 ), 1 ) vec( 2, 1 ) = sgn*( c( k1, l2 )-( suml+sgn*sumr ) ) - call stdlib_qlaln2( .true., 2, 1, smin, one, b( l1, l1 ),ldb, one, one, & + call stdlib_${ri}$laln2( .true., 2, 1, smin, one, b( l1, l1 ),ldb, one, one, & vec, 2, -sgn*a( k1, k1 ),zero, x, 2, scaloc, xnorm, ierr ) if( ierr/=0 )info = 1 if( scaloc/=one ) then do j = 1, n - call stdlib_qscal( m, scaloc, c( 1, j ), 1 ) + call stdlib_${ri}$scal( m, scaloc, c( 1, j ), 1 ) end do scale = scale*scaloc end if c( k1, l1 ) = x( 1, 1 ) c( k1, l2 ) = x( 2, 1 ) else if( l1/=l2 .and. k1/=k2 ) then - suml = stdlib_qdot( m-k2, a( k1, min( k2+1, m ) ), lda,c( min( k2+1, m ), & + suml = stdlib_${ri}$dot( m-k2, a( k1, min( k2+1, m ) ), lda,c( min( k2+1, m ), & l1 ), 1 ) - sumr = stdlib_qdot( l1-1, c( k1, 1 ), ldc, b( 1, l1 ), 1 ) + sumr = stdlib_${ri}$dot( l1-1, c( k1, 1 ), ldc, b( 1, l1 ), 1 ) vec( 1, 1 ) = c( k1, l1 ) - ( suml+sgn*sumr ) - suml = stdlib_qdot( m-k2, a( k1, min( k2+1, m ) ), lda,c( min( k2+1, m ), & + suml = stdlib_${ri}$dot( m-k2, a( k1, min( k2+1, m ) ), lda,c( min( k2+1, m ), & l2 ), 1 ) - sumr = stdlib_qdot( l1-1, c( k1, 1 ), ldc, b( 1, l2 ), 1 ) + sumr = stdlib_${ri}$dot( l1-1, c( k1, 1 ), ldc, b( 1, l2 ), 1 ) vec( 1, 2 ) = c( k1, l2 ) - ( suml+sgn*sumr ) - suml = stdlib_qdot( m-k2, a( k2, min( k2+1, m ) ), lda,c( min( k2+1, m ), & + suml = stdlib_${ri}$dot( m-k2, a( k2, min( k2+1, m ) ), lda,c( min( k2+1, m ), & l1 ), 1 ) - sumr = stdlib_qdot( l1-1, c( k2, 1 ), ldc, b( 1, l1 ), 1 ) + sumr = stdlib_${ri}$dot( l1-1, c( k2, 1 ), ldc, b( 1, l1 ), 1 ) vec( 2, 1 ) = c( k2, l1 ) - ( suml+sgn*sumr ) - suml = stdlib_qdot( m-k2, a( k2, min( k2+1, m ) ), lda,c( min( k2+1, m ), & + suml = stdlib_${ri}$dot( m-k2, a( k2, min( k2+1, m ) ), lda,c( min( k2+1, m ), & l2 ), 1 ) - sumr = stdlib_qdot( l1-1, c( k2, 1 ), ldc, b( 1, l2 ), 1 ) + sumr = stdlib_${ri}$dot( l1-1, c( k2, 1 ), ldc, b( 1, l2 ), 1 ) vec( 2, 2 ) = c( k2, l2 ) - ( suml+sgn*sumr ) - call stdlib_qlasy2( .false., .false., isgn, 2, 2,a( k1, k1 ), lda, b( l1, & + call stdlib_${ri}$lasy2( .false., .false., isgn, 2, 2,a( k1, k1 ), lda, b( l1, & l1 ), ldb, vec,2, scaloc, x, 2, xnorm, ierr ) if( ierr/=0 )info = 1 if( scaloc/=one ) then do j = 1, n - call stdlib_qscal( m, scaloc, c( 1, j ), 1 ) + call stdlib_${ri}$scal( m, scaloc, c( 1, j ), 1 ) end do scale = scale*scaloc end if @@ -84185,8 +84186,8 @@ module stdlib_linalg_lapack_q end if end if if( l1==l2 .and. k1==k2 ) then - suml = stdlib_qdot( k1-1, a( 1, k1 ), 1, c( 1, l1 ), 1 ) - sumr = stdlib_qdot( l1-1, c( k1, 1 ), ldc, b( 1, l1 ), 1 ) + suml = stdlib_${ri}$dot( k1-1, a( 1, k1 ), 1, c( 1, l1 ), 1 ) + sumr = stdlib_${ri}$dot( l1-1, c( k1, 1 ), ldc, b( 1, l1 ), 1 ) vec( 1, 1 ) = c( k1, l1 ) - ( suml+sgn*sumr ) scaloc = one a11 = a( k1, k1 ) + sgn*b( l1, l1 ) @@ -84203,66 +84204,66 @@ module stdlib_linalg_lapack_q x( 1, 1 ) = ( vec( 1, 1 )*scaloc ) / a11 if( scaloc/=one ) then do j = 1, n - call stdlib_qscal( m, scaloc, c( 1, j ), 1 ) + call stdlib_${ri}$scal( m, scaloc, c( 1, j ), 1 ) end do scale = scale*scaloc end if c( k1, l1 ) = x( 1, 1 ) else if( l1==l2 .and. k1/=k2 ) then - suml = stdlib_qdot( k1-1, a( 1, k1 ), 1, c( 1, l1 ), 1 ) - sumr = stdlib_qdot( l1-1, c( k1, 1 ), ldc, b( 1, l1 ), 1 ) + suml = stdlib_${ri}$dot( k1-1, a( 1, k1 ), 1, c( 1, l1 ), 1 ) + sumr = stdlib_${ri}$dot( l1-1, c( k1, 1 ), ldc, b( 1, l1 ), 1 ) vec( 1, 1 ) = c( k1, l1 ) - ( suml+sgn*sumr ) - suml = stdlib_qdot( k1-1, a( 1, k2 ), 1, c( 1, l1 ), 1 ) - sumr = stdlib_qdot( l1-1, c( k2, 1 ), ldc, b( 1, l1 ), 1 ) + suml = stdlib_${ri}$dot( k1-1, a( 1, k2 ), 1, c( 1, l1 ), 1 ) + sumr = stdlib_${ri}$dot( l1-1, c( k2, 1 ), ldc, b( 1, l1 ), 1 ) vec( 2, 1 ) = c( k2, l1 ) - ( suml+sgn*sumr ) - call stdlib_qlaln2( .true., 2, 1, smin, one, a( k1, k1 ),lda, one, one, & + call stdlib_${ri}$laln2( .true., 2, 1, smin, one, a( k1, k1 ),lda, one, one, & vec, 2, -sgn*b( l1, l1 ),zero, x, 2, scaloc, xnorm, ierr ) if( ierr/=0 )info = 1 if( scaloc/=one ) then do j = 1, n - call stdlib_qscal( m, scaloc, c( 1, j ), 1 ) + call stdlib_${ri}$scal( m, scaloc, c( 1, j ), 1 ) end do scale = scale*scaloc end if c( k1, l1 ) = x( 1, 1 ) c( k2, l1 ) = x( 2, 1 ) else if( l1/=l2 .and. k1==k2 ) then - suml = stdlib_qdot( k1-1, a( 1, k1 ), 1, c( 1, l1 ), 1 ) - sumr = stdlib_qdot( l1-1, c( k1, 1 ), ldc, b( 1, l1 ), 1 ) + suml = stdlib_${ri}$dot( k1-1, a( 1, k1 ), 1, c( 1, l1 ), 1 ) + sumr = stdlib_${ri}$dot( l1-1, c( k1, 1 ), ldc, b( 1, l1 ), 1 ) vec( 1, 1 ) = sgn*( c( k1, l1 )-( suml+sgn*sumr ) ) - suml = stdlib_qdot( k1-1, a( 1, k1 ), 1, c( 1, l2 ), 1 ) - sumr = stdlib_qdot( l1-1, c( k1, 1 ), ldc, b( 1, l2 ), 1 ) + suml = stdlib_${ri}$dot( k1-1, a( 1, k1 ), 1, c( 1, l2 ), 1 ) + sumr = stdlib_${ri}$dot( l1-1, c( k1, 1 ), ldc, b( 1, l2 ), 1 ) vec( 2, 1 ) = sgn*( c( k1, l2 )-( suml+sgn*sumr ) ) - call stdlib_qlaln2( .true., 2, 1, smin, one, b( l1, l1 ),ldb, one, one, & + call stdlib_${ri}$laln2( .true., 2, 1, smin, one, b( l1, l1 ),ldb, one, one, & vec, 2, -sgn*a( k1, k1 ),zero, x, 2, scaloc, xnorm, ierr ) if( ierr/=0 )info = 1 if( scaloc/=one ) then do j = 1, n - call stdlib_qscal( m, scaloc, c( 1, j ), 1 ) + call stdlib_${ri}$scal( m, scaloc, c( 1, j ), 1 ) end do scale = scale*scaloc end if c( k1, l1 ) = x( 1, 1 ) c( k1, l2 ) = x( 2, 1 ) else if( l1/=l2 .and. k1/=k2 ) then - suml = stdlib_qdot( k1-1, a( 1, k1 ), 1, c( 1, l1 ), 1 ) - sumr = stdlib_qdot( l1-1, c( k1, 1 ), ldc, b( 1, l1 ), 1 ) + suml = stdlib_${ri}$dot( k1-1, a( 1, k1 ), 1, c( 1, l1 ), 1 ) + sumr = stdlib_${ri}$dot( l1-1, c( k1, 1 ), ldc, b( 1, l1 ), 1 ) vec( 1, 1 ) = c( k1, l1 ) - ( suml+sgn*sumr ) - suml = stdlib_qdot( k1-1, a( 1, k1 ), 1, c( 1, l2 ), 1 ) - sumr = stdlib_qdot( l1-1, c( k1, 1 ), ldc, b( 1, l2 ), 1 ) + suml = stdlib_${ri}$dot( k1-1, a( 1, k1 ), 1, c( 1, l2 ), 1 ) + sumr = stdlib_${ri}$dot( l1-1, c( k1, 1 ), ldc, b( 1, l2 ), 1 ) vec( 1, 2 ) = c( k1, l2 ) - ( suml+sgn*sumr ) - suml = stdlib_qdot( k1-1, a( 1, k2 ), 1, c( 1, l1 ), 1 ) - sumr = stdlib_qdot( l1-1, c( k2, 1 ), ldc, b( 1, l1 ), 1 ) + suml = stdlib_${ri}$dot( k1-1, a( 1, k2 ), 1, c( 1, l1 ), 1 ) + sumr = stdlib_${ri}$dot( l1-1, c( k2, 1 ), ldc, b( 1, l1 ), 1 ) vec( 2, 1 ) = c( k2, l1 ) - ( suml+sgn*sumr ) - suml = stdlib_qdot( k1-1, a( 1, k2 ), 1, c( 1, l2 ), 1 ) - sumr = stdlib_qdot( l1-1, c( k2, 1 ), ldc, b( 1, l2 ), 1 ) + suml = stdlib_${ri}$dot( k1-1, a( 1, k2 ), 1, c( 1, l2 ), 1 ) + sumr = stdlib_${ri}$dot( l1-1, c( k2, 1 ), ldc, b( 1, l2 ), 1 ) vec( 2, 2 ) = c( k2, l2 ) - ( suml+sgn*sumr ) - call stdlib_qlasy2( .true., .false., isgn, 2, 2, a( k1, k1 ),lda, b( l1, & + call stdlib_${ri}$lasy2( .true., .false., isgn, 2, 2, a( k1, k1 ),lda, b( l1, & l1 ), ldb, vec, 2, scaloc, x,2, xnorm, ierr ) if( ierr/=0 )info = 1 if( scaloc/=one ) then do j = 1, n - call stdlib_qscal( m, scaloc, c( 1, j ), 1 ) + call stdlib_${ri}$scal( m, scaloc, c( 1, j ), 1 ) end do scale = scale*scaloc end if @@ -84321,8 +84322,8 @@ module stdlib_linalg_lapack_q end if end if if( l1==l2 .and. k1==k2 ) then - suml = stdlib_qdot( k1-1, a( 1, k1 ), 1, c( 1, l1 ), 1 ) - sumr = stdlib_qdot( n-l1, c( k1, min( l1+1, n ) ), ldc,b( l1, min( l1+1, n & + suml = stdlib_${ri}$dot( k1-1, a( 1, k1 ), 1, c( 1, l1 ), 1 ) + sumr = stdlib_${ri}$dot( n-l1, c( k1, min( l1+1, n ) ), ldc,b( l1, min( l1+1, n & ) ), ldb ) vec( 1, 1 ) = c( k1, l1 ) - ( suml+sgn*sumr ) scaloc = one @@ -84340,74 +84341,74 @@ module stdlib_linalg_lapack_q x( 1, 1 ) = ( vec( 1, 1 )*scaloc ) / a11 if( scaloc/=one ) then do j = 1, n - call stdlib_qscal( m, scaloc, c( 1, j ), 1 ) + call stdlib_${ri}$scal( m, scaloc, c( 1, j ), 1 ) end do scale = scale*scaloc end if c( k1, l1 ) = x( 1, 1 ) else if( l1==l2 .and. k1/=k2 ) then - suml = stdlib_qdot( k1-1, a( 1, k1 ), 1, c( 1, l1 ), 1 ) - sumr = stdlib_qdot( n-l2, c( k1, min( l2+1, n ) ), ldc,b( l1, min( l2+1, n & + suml = stdlib_${ri}$dot( k1-1, a( 1, k1 ), 1, c( 1, l1 ), 1 ) + sumr = stdlib_${ri}$dot( n-l2, c( k1, min( l2+1, n ) ), ldc,b( l1, min( l2+1, n & ) ), ldb ) vec( 1, 1 ) = c( k1, l1 ) - ( suml+sgn*sumr ) - suml = stdlib_qdot( k1-1, a( 1, k2 ), 1, c( 1, l1 ), 1 ) - sumr = stdlib_qdot( n-l2, c( k2, min( l2+1, n ) ), ldc,b( l1, min( l2+1, n & + suml = stdlib_${ri}$dot( k1-1, a( 1, k2 ), 1, c( 1, l1 ), 1 ) + sumr = stdlib_${ri}$dot( n-l2, c( k2, min( l2+1, n ) ), ldc,b( l1, min( l2+1, n & ) ), ldb ) vec( 2, 1 ) = c( k2, l1 ) - ( suml+sgn*sumr ) - call stdlib_qlaln2( .true., 2, 1, smin, one, a( k1, k1 ),lda, one, one, & + call stdlib_${ri}$laln2( .true., 2, 1, smin, one, a( k1, k1 ),lda, one, one, & vec, 2, -sgn*b( l1, l1 ),zero, x, 2, scaloc, xnorm, ierr ) if( ierr/=0 )info = 1 if( scaloc/=one ) then do j = 1, n - call stdlib_qscal( m, scaloc, c( 1, j ), 1 ) + call stdlib_${ri}$scal( m, scaloc, c( 1, j ), 1 ) end do scale = scale*scaloc end if c( k1, l1 ) = x( 1, 1 ) c( k2, l1 ) = x( 2, 1 ) else if( l1/=l2 .and. k1==k2 ) then - suml = stdlib_qdot( k1-1, a( 1, k1 ), 1, c( 1, l1 ), 1 ) - sumr = stdlib_qdot( n-l2, c( k1, min( l2+1, n ) ), ldc,b( l1, min( l2+1, n & + suml = stdlib_${ri}$dot( k1-1, a( 1, k1 ), 1, c( 1, l1 ), 1 ) + sumr = stdlib_${ri}$dot( n-l2, c( k1, min( l2+1, n ) ), ldc,b( l1, min( l2+1, n & ) ), ldb ) vec( 1, 1 ) = sgn*( c( k1, l1 )-( suml+sgn*sumr ) ) - suml = stdlib_qdot( k1-1, a( 1, k1 ), 1, c( 1, l2 ), 1 ) - sumr = stdlib_qdot( n-l2, c( k1, min( l2+1, n ) ), ldc,b( l2, min( l2+1, n & + suml = stdlib_${ri}$dot( k1-1, a( 1, k1 ), 1, c( 1, l2 ), 1 ) + sumr = stdlib_${ri}$dot( n-l2, c( k1, min( l2+1, n ) ), ldc,b( l2, min( l2+1, n & ) ), ldb ) vec( 2, 1 ) = sgn*( c( k1, l2 )-( suml+sgn*sumr ) ) - call stdlib_qlaln2( .false., 2, 1, smin, one, b( l1, l1 ),ldb, one, one, & + call stdlib_${ri}$laln2( .false., 2, 1, smin, one, b( l1, l1 ),ldb, one, one, & vec, 2, -sgn*a( k1, k1 ),zero, x, 2, scaloc, xnorm, ierr ) if( ierr/=0 )info = 1 if( scaloc/=one ) then do j = 1, n - call stdlib_qscal( m, scaloc, c( 1, j ), 1 ) + call stdlib_${ri}$scal( m, scaloc, c( 1, j ), 1 ) end do scale = scale*scaloc end if c( k1, l1 ) = x( 1, 1 ) c( k1, l2 ) = x( 2, 1 ) else if( l1/=l2 .and. k1/=k2 ) then - suml = stdlib_qdot( k1-1, a( 1, k1 ), 1, c( 1, l1 ), 1 ) - sumr = stdlib_qdot( n-l2, c( k1, min( l2+1, n ) ), ldc,b( l1, min( l2+1, n & + suml = stdlib_${ri}$dot( k1-1, a( 1, k1 ), 1, c( 1, l1 ), 1 ) + sumr = stdlib_${ri}$dot( n-l2, c( k1, min( l2+1, n ) ), ldc,b( l1, min( l2+1, n & ) ), ldb ) vec( 1, 1 ) = c( k1, l1 ) - ( suml+sgn*sumr ) - suml = stdlib_qdot( k1-1, a( 1, k1 ), 1, c( 1, l2 ), 1 ) - sumr = stdlib_qdot( n-l2, c( k1, min( l2+1, n ) ), ldc,b( l2, min( l2+1, n & + suml = stdlib_${ri}$dot( k1-1, a( 1, k1 ), 1, c( 1, l2 ), 1 ) + sumr = stdlib_${ri}$dot( n-l2, c( k1, min( l2+1, n ) ), ldc,b( l2, min( l2+1, n & ) ), ldb ) vec( 1, 2 ) = c( k1, l2 ) - ( suml+sgn*sumr ) - suml = stdlib_qdot( k1-1, a( 1, k2 ), 1, c( 1, l1 ), 1 ) - sumr = stdlib_qdot( n-l2, c( k2, min( l2+1, n ) ), ldc,b( l1, min( l2+1, n & + suml = stdlib_${ri}$dot( k1-1, a( 1, k2 ), 1, c( 1, l1 ), 1 ) + sumr = stdlib_${ri}$dot( n-l2, c( k2, min( l2+1, n ) ), ldc,b( l1, min( l2+1, n & ) ), ldb ) vec( 2, 1 ) = c( k2, l1 ) - ( suml+sgn*sumr ) - suml = stdlib_qdot( k1-1, a( 1, k2 ), 1, c( 1, l2 ), 1 ) - sumr = stdlib_qdot( n-l2, c( k2, min( l2+1, n ) ), ldc,b( l2, min( l2+1, n & + suml = stdlib_${ri}$dot( k1-1, a( 1, k2 ), 1, c( 1, l2 ), 1 ) + sumr = stdlib_${ri}$dot( n-l2, c( k2, min( l2+1, n ) ), ldc,b( l2, min( l2+1, n & ) ), ldb ) vec( 2, 2 ) = c( k2, l2 ) - ( suml+sgn*sumr ) - call stdlib_qlasy2( .true., .true., isgn, 2, 2, a( k1, k1 ),lda, b( l1, l1 & + call stdlib_${ri}$lasy2( .true., .true., isgn, 2, 2, a( k1, k1 ),lda, b( l1, l1 & ), ldb, vec, 2, scaloc, x,2, xnorm, ierr ) if( ierr/=0 )info = 1 if( scaloc/=one ) then do j = 1, n - call stdlib_qscal( m, scaloc, c( 1, j ), 1 ) + call stdlib_${ri}$scal( m, scaloc, c( 1, j ), 1 ) end do scale = scale*scaloc end if @@ -84466,9 +84467,9 @@ module stdlib_linalg_lapack_q end if end if if( l1==l2 .and. k1==k2 ) then - suml = stdlib_qdot( m-k1, a( k1, min( k1+1, m ) ), lda,c( min( k1+1, m ), & + suml = stdlib_${ri}$dot( m-k1, a( k1, min( k1+1, m ) ), lda,c( min( k1+1, m ), & l1 ), 1 ) - sumr = stdlib_qdot( n-l1, c( k1, min( l1+1, n ) ), ldc,b( l1, min( l1+1, n & + sumr = stdlib_${ri}$dot( n-l1, c( k1, min( l1+1, n ) ), ldc,b( l1, min( l1+1, n & ) ), ldb ) vec( 1, 1 ) = c( k1, l1 ) - ( suml+sgn*sumr ) scaloc = one @@ -84486,82 +84487,82 @@ module stdlib_linalg_lapack_q x( 1, 1 ) = ( vec( 1, 1 )*scaloc ) / a11 if( scaloc/=one ) then do j = 1, n - call stdlib_qscal( m, scaloc, c( 1, j ), 1 ) + call stdlib_${ri}$scal( m, scaloc, c( 1, j ), 1 ) end do scale = scale*scaloc end if c( k1, l1 ) = x( 1, 1 ) else if( l1==l2 .and. k1/=k2 ) then - suml = stdlib_qdot( m-k2, a( k1, min( k2+1, m ) ), lda,c( min( k2+1, m ), & + suml = stdlib_${ri}$dot( m-k2, a( k1, min( k2+1, m ) ), lda,c( min( k2+1, m ), & l1 ), 1 ) - sumr = stdlib_qdot( n-l2, c( k1, min( l2+1, n ) ), ldc,b( l1, min( l2+1, n & + sumr = stdlib_${ri}$dot( n-l2, c( k1, min( l2+1, n ) ), ldc,b( l1, min( l2+1, n & ) ), ldb ) vec( 1, 1 ) = c( k1, l1 ) - ( suml+sgn*sumr ) - suml = stdlib_qdot( m-k2, a( k2, min( k2+1, m ) ), lda,c( min( k2+1, m ), & + suml = stdlib_${ri}$dot( m-k2, a( k2, min( k2+1, m ) ), lda,c( min( k2+1, m ), & l1 ), 1 ) - sumr = stdlib_qdot( n-l2, c( k2, min( l2+1, n ) ), ldc,b( l1, min( l2+1, n & + sumr = stdlib_${ri}$dot( n-l2, c( k2, min( l2+1, n ) ), ldc,b( l1, min( l2+1, n & ) ), ldb ) vec( 2, 1 ) = c( k2, l1 ) - ( suml+sgn*sumr ) - call stdlib_qlaln2( .false., 2, 1, smin, one, a( k1, k1 ),lda, one, one, & + call stdlib_${ri}$laln2( .false., 2, 1, smin, one, a( k1, k1 ),lda, one, one, & vec, 2, -sgn*b( l1, l1 ),zero, x, 2, scaloc, xnorm, ierr ) if( ierr/=0 )info = 1 if( scaloc/=one ) then do j = 1, n - call stdlib_qscal( m, scaloc, c( 1, j ), 1 ) + call stdlib_${ri}$scal( m, scaloc, c( 1, j ), 1 ) end do scale = scale*scaloc end if c( k1, l1 ) = x( 1, 1 ) c( k2, l1 ) = x( 2, 1 ) else if( l1/=l2 .and. k1==k2 ) then - suml = stdlib_qdot( m-k1, a( k1, min( k1+1, m ) ), lda,c( min( k1+1, m ), & + suml = stdlib_${ri}$dot( m-k1, a( k1, min( k1+1, m ) ), lda,c( min( k1+1, m ), & l1 ), 1 ) - sumr = stdlib_qdot( n-l2, c( k1, min( l2+1, n ) ), ldc,b( l1, min( l2+1, n & + sumr = stdlib_${ri}$dot( n-l2, c( k1, min( l2+1, n ) ), ldc,b( l1, min( l2+1, n & ) ), ldb ) vec( 1, 1 ) = sgn*( c( k1, l1 )-( suml+sgn*sumr ) ) - suml = stdlib_qdot( m-k1, a( k1, min( k1+1, m ) ), lda,c( min( k1+1, m ), & + suml = stdlib_${ri}$dot( m-k1, a( k1, min( k1+1, m ) ), lda,c( min( k1+1, m ), & l2 ), 1 ) - sumr = stdlib_qdot( n-l2, c( k1, min( l2+1, n ) ), ldc,b( l2, min( l2+1, n & + sumr = stdlib_${ri}$dot( n-l2, c( k1, min( l2+1, n ) ), ldc,b( l2, min( l2+1, n & ) ), ldb ) vec( 2, 1 ) = sgn*( c( k1, l2 )-( suml+sgn*sumr ) ) - call stdlib_qlaln2( .false., 2, 1, smin, one, b( l1, l1 ),ldb, one, one, & + call stdlib_${ri}$laln2( .false., 2, 1, smin, one, b( l1, l1 ),ldb, one, one, & vec, 2, -sgn*a( k1, k1 ),zero, x, 2, scaloc, xnorm, ierr ) if( ierr/=0 )info = 1 if( scaloc/=one ) then do j = 1, n - call stdlib_qscal( m, scaloc, c( 1, j ), 1 ) + call stdlib_${ri}$scal( m, scaloc, c( 1, j ), 1 ) end do scale = scale*scaloc end if c( k1, l1 ) = x( 1, 1 ) c( k1, l2 ) = x( 2, 1 ) else if( l1/=l2 .and. k1/=k2 ) then - suml = stdlib_qdot( m-k2, a( k1, min( k2+1, m ) ), lda,c( min( k2+1, m ), & + suml = stdlib_${ri}$dot( m-k2, a( k1, min( k2+1, m ) ), lda,c( min( k2+1, m ), & l1 ), 1 ) - sumr = stdlib_qdot( n-l2, c( k1, min( l2+1, n ) ), ldc,b( l1, min( l2+1, n & + sumr = stdlib_${ri}$dot( n-l2, c( k1, min( l2+1, n ) ), ldc,b( l1, min( l2+1, n & ) ), ldb ) vec( 1, 1 ) = c( k1, l1 ) - ( suml+sgn*sumr ) - suml = stdlib_qdot( m-k2, a( k1, min( k2+1, m ) ), lda,c( min( k2+1, m ), & + suml = stdlib_${ri}$dot( m-k2, a( k1, min( k2+1, m ) ), lda,c( min( k2+1, m ), & l2 ), 1 ) - sumr = stdlib_qdot( n-l2, c( k1, min( l2+1, n ) ), ldc,b( l2, min( l2+1, n & + sumr = stdlib_${ri}$dot( n-l2, c( k1, min( l2+1, n ) ), ldc,b( l2, min( l2+1, n & ) ), ldb ) vec( 1, 2 ) = c( k1, l2 ) - ( suml+sgn*sumr ) - suml = stdlib_qdot( m-k2, a( k2, min( k2+1, m ) ), lda,c( min( k2+1, m ), & + suml = stdlib_${ri}$dot( m-k2, a( k2, min( k2+1, m ) ), lda,c( min( k2+1, m ), & l1 ), 1 ) - sumr = stdlib_qdot( n-l2, c( k2, min( l2+1, n ) ), ldc,b( l1, min( l2+1, n & + sumr = stdlib_${ri}$dot( n-l2, c( k2, min( l2+1, n ) ), ldc,b( l1, min( l2+1, n & ) ), ldb ) vec( 2, 1 ) = c( k2, l1 ) - ( suml+sgn*sumr ) - suml = stdlib_qdot( m-k2, a( k2, min( k2+1, m ) ), lda,c( min( k2+1, m ), & + suml = stdlib_${ri}$dot( m-k2, a( k2, min( k2+1, m ) ), lda,c( min( k2+1, m ), & l2 ), 1 ) - sumr = stdlib_qdot( n-l2, c( k2, min( l2+1, n ) ), ldc,b( l2, min( l2+1, n & + sumr = stdlib_${ri}$dot( n-l2, c( k2, min( l2+1, n ) ), ldc,b( l2, min( l2+1, n & ) ), ldb ) vec( 2, 2 ) = c( k2, l2 ) - ( suml+sgn*sumr ) - call stdlib_qlasy2( .false., .true., isgn, 2, 2, a( k1, k1 ),lda, b( l1, & + call stdlib_${ri}$lasy2( .false., .true., isgn, 2, 2, a( k1, k1 ),lda, b( l1, & l1 ), ldb, vec, 2, scaloc, x,2, xnorm, ierr ) if( ierr/=0 )info = 1 if( scaloc/=one ) then do j = 1, n - call stdlib_qscal( m, scaloc, c( 1, j ), 1 ) + call stdlib_${ri}$scal( m, scaloc, c( 1, j ), 1 ) end do scale = scale*scaloc end if @@ -84574,10 +84575,10 @@ module stdlib_linalg_lapack_q end do loop_240 end if return - end subroutine stdlib_qtrsyl + end subroutine stdlib_${ri}$trsyl - pure subroutine stdlib_qtrti2( uplo, diag, n, a, lda, info ) + pure subroutine stdlib_${ri}$trti2( uplo, diag, n, a, lda, info ) !! DTRTI2: computes the inverse of a real upper or lower triangular !! matrix. !! This is the Level 2 BLAS version of the algorithm. @@ -84589,13 +84590,13 @@ module stdlib_linalg_lapack_q integer(ilp), intent(out) :: info integer(ilp), intent(in) :: lda, n ! Array Arguments - real(qp), intent(inout) :: a(lda,*) + real(${rk}$), intent(inout) :: a(lda,*) ! ===================================================================== ! Local Scalars logical(lk) :: nounit, upper integer(ilp) :: j - real(qp) :: ajj + real(${rk}$) :: ajj ! Intrinsic Functions intrinsic :: max ! Executable Statements @@ -84626,9 +84627,9 @@ module stdlib_linalg_lapack_q ajj = -one end if ! compute elements 1:j-1 of j-th column. - call stdlib_qtrmv( 'UPPER', 'NO TRANSPOSE', diag, j-1, a, lda,a( 1, j ), 1 ) + call stdlib_${ri}$trmv( 'UPPER', 'NO TRANSPOSE', diag, j-1, a, lda,a( 1, j ), 1 ) - call stdlib_qscal( j-1, ajj, a( 1, j ), 1 ) + call stdlib_${ri}$scal( j-1, ajj, a( 1, j ), 1 ) end do else ! compute inverse of lower triangular matrix. @@ -84641,17 +84642,17 @@ module stdlib_linalg_lapack_q end if if( j=n ) then ! use unblocked code - call stdlib_qtrti2( uplo, diag, n, a, lda, info ) + call stdlib_${ri}$trti2( uplo, diag, n, a, lda, info ) else ! use blocked code if( upper ) then @@ -84710,12 +84711,12 @@ module stdlib_linalg_lapack_q do j = 1, n, nb jb = min( nb, n-j+1 ) ! compute rows 1:j-1 of current block column - call stdlib_qtrmm( 'LEFT', 'UPPER', 'NO TRANSPOSE', diag, j-1,jb, one, a, lda,& + call stdlib_${ri}$trmm( 'LEFT', 'UPPER', 'NO TRANSPOSE', diag, j-1,jb, one, a, lda,& a( 1, j ), lda ) - call stdlib_qtrsm( 'RIGHT', 'UPPER', 'NO TRANSPOSE', diag, j-1,jb, -one, a( j,& + call stdlib_${ri}$trsm( 'RIGHT', 'UPPER', 'NO TRANSPOSE', diag, j-1,jb, -one, a( j,& j ), lda, a( 1, j ), lda ) ! compute inverse of current diagonal block - call stdlib_qtrti2( 'UPPER', diag, jb, a( j, j ), lda, info ) + call stdlib_${ri}$trti2( 'UPPER', diag, jb, a( j, j ), lda, info ) end do else ! compute inverse of lower triangular matrix @@ -84724,21 +84725,21 @@ module stdlib_linalg_lapack_q jb = min( nb, n-j+1 ) if( j+jb<=n ) then ! compute rows j+jb:n of current block column - call stdlib_qtrmm( 'LEFT', 'LOWER', 'NO TRANSPOSE', diag,n-j-jb+1, jb, one,& + call stdlib_${ri}$trmm( 'LEFT', 'LOWER', 'NO TRANSPOSE', diag,n-j-jb+1, jb, one,& a( j+jb, j+jb ), lda,a( j+jb, j ), lda ) - call stdlib_qtrsm( 'RIGHT', 'LOWER', 'NO TRANSPOSE', diag,n-j-jb+1, jb, -& + call stdlib_${ri}$trsm( 'RIGHT', 'LOWER', 'NO TRANSPOSE', diag,n-j-jb+1, jb, -& one, a( j, j ), lda,a( j+jb, j ), lda ) end if ! compute inverse of current diagonal block - call stdlib_qtrti2( 'LOWER', diag, jb, a( j, j ), lda, info ) + call stdlib_${ri}$trti2( 'LOWER', diag, jb, a( j, j ), lda, info ) end do end if end if return - end subroutine stdlib_qtrtri + end subroutine stdlib_${ri}$trtri - pure subroutine stdlib_qtrtrs( uplo, trans, diag, n, nrhs, a, lda, b, ldb,info ) + pure subroutine stdlib_${ri}$trtrs( uplo, trans, diag, n, nrhs, a, lda, b, ldb,info ) !! DTRTRS: solves a triangular system of the form !! A * X = B or A**T * X = B, !! where A is a triangular matrix of order N, and B is an N-by-NRHS @@ -84751,8 +84752,8 @@ module stdlib_linalg_lapack_q integer(ilp), intent(out) :: info integer(ilp), intent(in) :: lda, ldb, n, nrhs ! Array Arguments - real(qp), intent(in) :: a(lda,*) - real(qp), intent(inout) :: b(ldb,*) + real(${rk}$), intent(in) :: a(lda,*) + real(${rk}$), intent(inout) :: b(ldb,*) ! ===================================================================== ! Local Scalars @@ -84793,12 +84794,12 @@ module stdlib_linalg_lapack_q end if info = 0 ! solve a * x = b or a**t * x = b. - call stdlib_qtrsm( 'LEFT', uplo, trans, diag, n, nrhs, one, a, lda, b,ldb ) + call stdlib_${ri}$trsm( 'LEFT', uplo, trans, diag, n, nrhs, one, a, lda, b,ldb ) return - end subroutine stdlib_qtrtrs + end subroutine stdlib_${ri}$trtrs - pure subroutine stdlib_qtrttf( transr, uplo, n, a, lda, arf, info ) + pure subroutine stdlib_${ri}$trttf( transr, uplo, n, a, lda, arf, info ) !! DTRTTF: copies a triangular matrix A from standard full format (TR) !! to rectangular full packed format (TF) . ! -- lapack computational routine -- @@ -84809,8 +84810,8 @@ module stdlib_linalg_lapack_q integer(ilp), intent(out) :: info integer(ilp), intent(in) :: n, lda ! Array Arguments - real(qp), intent(in) :: a(0:lda-1,0:*) - real(qp), intent(out) :: arf(0:*) + real(${rk}$), intent(in) :: a(0:lda-1,0:*) + real(${rk}$), intent(out) :: arf(0:*) ! ===================================================================== ! Local Scalars logical(lk) :: lower, nisodd, normaltransr @@ -85023,10 +85024,10 @@ module stdlib_linalg_lapack_q end if end if return - end subroutine stdlib_qtrttf + end subroutine stdlib_${ri}$trttf - pure subroutine stdlib_qtrttp( uplo, n, a, lda, ap, info ) + pure subroutine stdlib_${ri}$trttp( uplo, n, a, lda, ap, info ) !! DTRTTP: copies a triangular matrix A from full format (TR) to standard !! packed format (TP). ! -- lapack computational routine -- @@ -85037,8 +85038,8 @@ module stdlib_linalg_lapack_q integer(ilp), intent(out) :: info integer(ilp), intent(in) :: n, lda ! Array Arguments - real(qp), intent(in) :: a(lda,*) - real(qp), intent(out) :: ap(*) + real(${rk}$), intent(in) :: a(lda,*) + real(${rk}$), intent(out) :: ap(*) ! ===================================================================== ! Parameters ! Local Scalars @@ -85077,10 +85078,10 @@ module stdlib_linalg_lapack_q end do end if return - end subroutine stdlib_qtrttp + end subroutine stdlib_${ri}$trttp - pure subroutine stdlib_qtzrzf( m, n, a, lda, tau, work, lwork, info ) + pure subroutine stdlib_${ri}$tzrzf( m, n, a, lda, tau, work, lwork, info ) !! DTZRZF: reduces the M-by-N ( M<=N ) real upper trapezoidal matrix A !! to upper triangular form by means of orthogonal transformations. !! The upper trapezoidal matrix A is factored as @@ -85094,8 +85095,8 @@ module stdlib_linalg_lapack_q integer(ilp), intent(out) :: info integer(ilp), intent(in) :: lda, lwork, m, n ! Array Arguments - real(qp), intent(inout) :: a(lda,*) - real(qp), intent(out) :: tau(*), work(*) + real(${rk}$), intent(inout) :: a(lda,*) + real(${rk}$), intent(out) :: tau(*), work(*) ! ===================================================================== ! Local Scalars @@ -85173,14 +85174,14 @@ module stdlib_linalg_lapack_q ib = min( m-i+1, nb ) ! compute the tz factorization of the current block ! a(i:i+ib-1,i:n) - call stdlib_qlatrz( ib, n-i+1, n-m, a( i, i ), lda, tau( i ),work ) + call stdlib_${ri}$latrz( ib, n-i+1, n-m, a( i, i ), lda, tau( i ),work ) if( i>1 ) then ! form the triangular factor of the block reflector ! h = h(i+ib-1) . . . h(i+1) h(i) - call stdlib_qlarzt( 'BACKWARD', 'ROWWISE', n-m, ib, a( i, m1 ),lda, tau( i ), & + call stdlib_${ri}$larzt( 'BACKWARD', 'ROWWISE', n-m, ib, a( i, m1 ),lda, tau( i ), & work, ldwork ) ! apply h to a(1:i-1,i:n) from the right - call stdlib_qlarzb( 'RIGHT', 'NO TRANSPOSE', 'BACKWARD','ROWWISE', i-1, n-i+1,& + call stdlib_${ri}$larzb( 'RIGHT', 'NO TRANSPOSE', 'BACKWARD','ROWWISE', i-1, n-i+1,& ib, n-m, a( i, m1 ),lda, work, ldwork, a( 1, i ), lda,work( ib+1 ), ldwork ) end if @@ -85190,13 +85191,13 @@ module stdlib_linalg_lapack_q mu = m end if ! use unblocked code to factor the last or only block - if( mu>0 )call stdlib_qlatrz( mu, n, n-m, a, lda, tau, work ) + if( mu>0 )call stdlib_${ri}$latrz( mu, n, n-m, a, lda, tau, work ) work( 1 ) = lwkopt return - end subroutine stdlib_qtzrzf + end subroutine stdlib_${ri}$tzrzf - pure real(qp) function stdlib_qzsum1( n, cx, incx ) + pure real(${rk}$) function stdlib_${ri}$zsum1( n, cx, incx ) !! DZSUM1: takes the sum of the absolute values of a complex !! vector and returns a quad precision result. !! Based on DZASUM from the Level 1 BLAS. @@ -85207,15 +85208,15 @@ module stdlib_linalg_lapack_q ! Scalar Arguments integer(ilp), intent(in) :: incx, n ! Array Arguments - complex(qp), intent(in) :: cx(*) + complex(${rk}$), intent(in) :: cx(*) ! ===================================================================== ! Local Scalars integer(ilp) :: i, nincx - real(qp) :: stemp + real(${rk}$) :: stemp ! Intrinsic Functions intrinsic :: abs ! Executable Statements - stdlib_qzsum1 = zero + stdlib_${ri}$zsum1 = zero stemp = zero if( n<=0 )return if( incx==1 )go to 20 @@ -85225,7 +85226,7 @@ module stdlib_linalg_lapack_q ! next line modified. stemp = stemp + abs( cx( i ) ) end do - stdlib_qzsum1 = stemp + stdlib_${ri}$zsum1 = stemp return ! code for increment equal to 1 20 continue @@ -85233,13 +85234,12 @@ module stdlib_linalg_lapack_q ! next line modified. stemp = stemp + abs( cx( i ) ) end do - stdlib_qzsum1 = stemp + stdlib_${ri}$zsum1 = stemp return - end function stdlib_qzsum1 + end function stdlib_${ri}$zsum1 - - pure subroutine stdlib_qlag2q( m, n, sa, ldsa, a, lda, info ) - !! DLAG2Q: converts a SINGLE PRECISION matrix, SA, to a DOUBLE + pure subroutine stdlib_dlag2${ri}$( m, n, sa, ldsa, a, lda, info ) + !! DLAG2Q converts a DOUBLE PRECISION matrix, SA, to an EXTENDED !! PRECISION matrix, A. !! Note that while it is possible to overflow while converting !! from double to single, it is not possible to overflow when @@ -85252,8 +85252,8 @@ module stdlib_linalg_lapack_q integer(ilp), intent(out) :: info integer(ilp), intent(in) :: lda, ldsa, m, n ! Array Arguments - real(qp), intent(in) :: sa(ldsa,*) - real(qp), intent(out) :: a(lda,*) + real(dp), intent(in) :: sa(ldsa,*) + real(${rk}$), intent(out) :: a(lda,*) ! ===================================================================== ! Local Scalars integer(ilp) :: i, j @@ -85265,9 +85265,9 @@ module stdlib_linalg_lapack_q end do end do return - end subroutine stdlib_qlag2q - + end subroutine stdlib_dlag2${ri}$ +end module stdlib_linalg_lapack_${ri}$ -end module stdlib_linalg_lapack_q #:endif +#:endfor diff --git a/src/stdlib_linalg_lapack_w.fypp b/src/stdlib_linalg_lapack_w.fypp index 8c2323529..324923ade 100644 --- a/src/stdlib_linalg_lapack_w.fypp +++ b/src/stdlib_linalg_lapack_w.fypp @@ -1,513 +1,515 @@ #:include "common.fypp" -#:if WITH_QP -module stdlib_linalg_lapack_w +#:set RC_KINDS_TYPES = REAL_KINDS_TYPES + CMPLX_KINDS_TYPES +#:for ck,ct,ci in CMPLX_KINDS_TYPES +#:if not ck in ["sp","dp"] +module stdlib_linalg_lapack_${ci}$ use stdlib_linalg_constants use stdlib_linalg_blas use stdlib_linalg_lapack_aux - use stdlib_linalg_lapack_s - use stdlib_linalg_lapack_c - use stdlib_linalg_lapack_d - use stdlib_linalg_lapack_z - use stdlib_linalg_lapack_q + #:for rk,rt,ri in RC_KINDS_TYPES + #:if not ri in ["y","w"] + use stdlib_linalg_lapack_${ri}$ + #:endif + #:endfor implicit none(type,external) private - public :: sp,dp,qp,lk,ilp - public :: stdlib_wlag2w - public :: stdlib_wbbcsd - public :: stdlib_wbdsqr - public :: stdlib_wcgesv - public :: stdlib_wcposv - public :: stdlib_wdrscl - public :: stdlib_wgbbrd - public :: stdlib_wgbcon - public :: stdlib_wgbequ - public :: stdlib_wgbequb - public :: stdlib_wgbrfs - public :: stdlib_wgbsv - public :: stdlib_wgbsvx - public :: stdlib_wgbtf2 - public :: stdlib_wgbtrf - public :: stdlib_wgbtrs - public :: stdlib_wgebak - public :: stdlib_wgebal - public :: stdlib_wgebd2 - public :: stdlib_wgebrd - public :: stdlib_wgecon - public :: stdlib_wgeequ - public :: stdlib_wgeequb - public :: stdlib_wgees - public :: stdlib_wgeesx - public :: stdlib_wgeev - public :: stdlib_wgeevx - public :: stdlib_wgehd2 - public :: stdlib_wgehrd - public :: stdlib_wgejsv - public :: stdlib_wgelq - public :: stdlib_wgelq2 - public :: stdlib_wgelqf - public :: stdlib_wgelqt - public :: stdlib_wgelqt3 - public :: stdlib_wgels - public :: stdlib_wgelsd - public :: stdlib_wgelss - public :: stdlib_wgelsy - public :: stdlib_wgemlq - public :: stdlib_wgemlqt - public :: stdlib_wgemqr - public :: stdlib_wgemqrt - public :: stdlib_wgeql2 - public :: stdlib_wgeqlf - public :: stdlib_wgeqp3 - public :: stdlib_wgeqr - public :: stdlib_wgeqr2 - public :: stdlib_wgeqr2p - public :: stdlib_wgeqrf - public :: stdlib_wgeqrfp - public :: stdlib_wgeqrt - public :: stdlib_wgeqrt2 - public :: stdlib_wgeqrt3 - public :: stdlib_wgerfs - public :: stdlib_wgerq2 - public :: stdlib_wgerqf - public :: stdlib_wgesc2 - public :: stdlib_wgesdd - public :: stdlib_wgesv - public :: stdlib_wgesvd - public :: stdlib_wgesvdq - public :: stdlib_wgesvj - public :: stdlib_wgesvx - public :: stdlib_wgetc2 - public :: stdlib_wgetf2 - public :: stdlib_wgetrf - public :: stdlib_wgetrf2 - public :: stdlib_wgetri - public :: stdlib_wgetrs - public :: stdlib_wgetsls - public :: stdlib_wgetsqrhrt - public :: stdlib_wggbak - public :: stdlib_wggbal - public :: stdlib_wgges - public :: stdlib_wgges3 - public :: stdlib_wggesx - public :: stdlib_wggev - public :: stdlib_wggev3 - public :: stdlib_wggevx - public :: stdlib_wggglm - public :: stdlib_wgghd3 - public :: stdlib_wgghrd - public :: stdlib_wgglse - public :: stdlib_wggqrf - public :: stdlib_wggrqf - public :: stdlib_wgsvj0 - public :: stdlib_wgsvj1 - public :: stdlib_wgtcon - public :: stdlib_wgtrfs - public :: stdlib_wgtsv - public :: stdlib_wgtsvx - public :: stdlib_wgttrf - public :: stdlib_wgttrs - public :: stdlib_wgtts2 - public :: stdlib_whb2st_kernels - public :: stdlib_whbev - public :: stdlib_whbevd - public :: stdlib_whbevx - public :: stdlib_whbgst - public :: stdlib_whbgv - public :: stdlib_whbgvd - public :: stdlib_whbgvx - public :: stdlib_whbtrd - public :: stdlib_whecon - public :: stdlib_whecon_rook - public :: stdlib_wheequb - public :: stdlib_wheev - public :: stdlib_wheevd - public :: stdlib_wheevr - public :: stdlib_wheevx - public :: stdlib_whegs2 - public :: stdlib_whegst - public :: stdlib_whegv - public :: stdlib_whegvd - public :: stdlib_whegvx - public :: stdlib_wherfs - public :: stdlib_whesv - public :: stdlib_whesv_aa - public :: stdlib_whesv_rk - public :: stdlib_whesv_rook - public :: stdlib_whesvx - public :: stdlib_wheswapr - public :: stdlib_whetd2 - public :: stdlib_whetf2 - public :: stdlib_whetf2_rk - public :: stdlib_whetf2_rook - public :: stdlib_whetrd - public :: stdlib_whetrd_hb2st - public :: stdlib_whetrd_he2hb - public :: stdlib_whetrf - public :: stdlib_whetrf_aa - public :: stdlib_whetrf_rk - public :: stdlib_whetrf_rook - public :: stdlib_whetri - public :: stdlib_whetri_rook - public :: stdlib_whetrs - public :: stdlib_whetrs2 - public :: stdlib_whetrs_3 - public :: stdlib_whetrs_aa - public :: stdlib_whetrs_rook - public :: stdlib_whfrk - public :: stdlib_whgeqz - public :: stdlib_whpcon - public :: stdlib_whpev - public :: stdlib_whpevd - public :: stdlib_whpevx - public :: stdlib_whpgst - public :: stdlib_whpgv - public :: stdlib_whpgvd - public :: stdlib_whpgvx - public :: stdlib_whprfs - public :: stdlib_whpsv - public :: stdlib_whpsvx - public :: stdlib_whptrd - public :: stdlib_whptrf - public :: stdlib_whptri - public :: stdlib_whptrs - public :: stdlib_whsein - public :: stdlib_whseqr - public :: stdlib_wla_gbamv - public :: stdlib_wla_gbrcond_c - public :: stdlib_wla_gbrpvgrw - public :: stdlib_wla_geamv - public :: stdlib_wla_gercond_c - public :: stdlib_wla_gerpvgrw - public :: stdlib_wla_heamv - public :: stdlib_wla_hercond_c - public :: stdlib_wla_herpvgrw - public :: stdlib_wla_lin_berr - public :: stdlib_wla_porcond_c - public :: stdlib_wla_porpvgrw - public :: stdlib_wla_syamv - public :: stdlib_wla_syrcond_c - public :: stdlib_wla_syrpvgrw - public :: stdlib_wla_wwaddw - public :: stdlib_wlabrd - public :: stdlib_wlacgv - public :: stdlib_wlacn2 - public :: stdlib_wlacon - public :: stdlib_wlacp2 - public :: stdlib_wlacpy - public :: stdlib_wlacrm - public :: stdlib_wlacrt - public :: stdlib_wladiv - public :: stdlib_wlaed0 - public :: stdlib_wlaed7 - public :: stdlib_wlaed8 - public :: stdlib_wlaein - public :: stdlib_wlaesy - public :: stdlib_wlaev2 - public :: stdlib_wlag2c - public :: stdlib_wlags2 - public :: stdlib_wlagtm - public :: stdlib_wlahef - public :: stdlib_wlahef_aa - public :: stdlib_wlahef_rk - public :: stdlib_wlahef_rook - public :: stdlib_wlahqr - public :: stdlib_wlahr2 - public :: stdlib_wlaic1 - public :: stdlib_wlals0 - public :: stdlib_wlalsa - public :: stdlib_wlalsd - public :: stdlib_wlamswlq - public :: stdlib_wlamtsqr - public :: stdlib_wlangb - public :: stdlib_wlange - public :: stdlib_wlangt - public :: stdlib_wlanhb - public :: stdlib_wlanhe - public :: stdlib_wlanhf - public :: stdlib_wlanhp - public :: stdlib_wlanhs - public :: stdlib_wlanht - public :: stdlib_wlansb - public :: stdlib_wlansp - public :: stdlib_wlansy - public :: stdlib_wlantb - public :: stdlib_wlantp - public :: stdlib_wlantr - public :: stdlib_wlapll - public :: stdlib_wlapmr - public :: stdlib_wlapmt - public :: stdlib_wlaqgb - public :: stdlib_wlaqge - public :: stdlib_wlaqhb - public :: stdlib_wlaqhe - public :: stdlib_wlaqhp - public :: stdlib_wlaqp2 - public :: stdlib_wlaqps - public :: stdlib_wlaqr0 - public :: stdlib_wlaqr1 - public :: stdlib_wlaqr2 - public :: stdlib_wlaqr3 - public :: stdlib_wlaqr4 - public :: stdlib_wlaqr5 - public :: stdlib_wlaqsb - public :: stdlib_wlaqsp - public :: stdlib_wlaqsy - public :: stdlib_wlaqz0 - public :: stdlib_wlaqz1 - public :: stdlib_wlaqz2 - public :: stdlib_wlaqz3 - public :: stdlib_wlar1v - public :: stdlib_wlar2v - public :: stdlib_wlarcm - public :: stdlib_wlarf - public :: stdlib_wlarfb - public :: stdlib_wlarfb_gett - public :: stdlib_wlarfg - public :: stdlib_wlarfgp - public :: stdlib_wlarft - public :: stdlib_wlarfx - public :: stdlib_wlarfy - public :: stdlib_wlargv - public :: stdlib_wlarnv - public :: stdlib_wlarrv - public :: stdlib_wlartg - public :: stdlib_wlartv - public :: stdlib_wlarz - public :: stdlib_wlarzb - public :: stdlib_wlarzt - public :: stdlib_wlascl - public :: stdlib_wlaset - public :: stdlib_wlasr - public :: stdlib_wlassq - public :: stdlib_wlaswlq - public :: stdlib_wlaswp - public :: stdlib_wlasyf - public :: stdlib_wlasyf_aa - public :: stdlib_wlasyf_rk - public :: stdlib_wlasyf_rook - public :: stdlib_wlat2c - public :: stdlib_wlatbs - public :: stdlib_wlatdf - public :: stdlib_wlatps - public :: stdlib_wlatrd - public :: stdlib_wlatrs - public :: stdlib_wlatrz - public :: stdlib_wlatsqr - public :: stdlib_wlaunhr_col_getrfnp - public :: stdlib_wlaunhr_col_getrfnp2 - public :: stdlib_wlauu2 - public :: stdlib_wlauum - public :: stdlib_wpbcon - public :: stdlib_wpbequ - public :: stdlib_wpbrfs - public :: stdlib_wpbstf - public :: stdlib_wpbsv - public :: stdlib_wpbsvx - public :: stdlib_wpbtf2 - public :: stdlib_wpbtrf - public :: stdlib_wpbtrs - public :: stdlib_wpftrf - public :: stdlib_wpftri - public :: stdlib_wpftrs - public :: stdlib_wpocon - public :: stdlib_wpoequ - public :: stdlib_wpoequb - public :: stdlib_wporfs - public :: stdlib_wposv - public :: stdlib_wposvx - public :: stdlib_wpotf2 - public :: stdlib_wpotrf - public :: stdlib_wpotrf2 - public :: stdlib_wpotri - public :: stdlib_wpotrs - public :: stdlib_wppcon - public :: stdlib_wppequ - public :: stdlib_wpprfs - public :: stdlib_wppsv - public :: stdlib_wppsvx - public :: stdlib_wpptrf - public :: stdlib_wpptri - public :: stdlib_wpptrs - public :: stdlib_wpstf2 - public :: stdlib_wpstrf - public :: stdlib_wptcon - public :: stdlib_wpteqr - public :: stdlib_wptrfs - public :: stdlib_wptsv - public :: stdlib_wptsvx - public :: stdlib_wpttrf - public :: stdlib_wpttrs - public :: stdlib_wptts2 - public :: stdlib_wrot - public :: stdlib_wspcon - public :: stdlib_wspmv - public :: stdlib_wspr - public :: stdlib_wsprfs - public :: stdlib_wspsv - public :: stdlib_wspsvx - public :: stdlib_wsptrf - public :: stdlib_wsptri - public :: stdlib_wsptrs - public :: stdlib_wstedc - public :: stdlib_wstegr - public :: stdlib_wstein - public :: stdlib_wstemr - public :: stdlib_wsteqr - public :: stdlib_wsycon - public :: stdlib_wsycon_rook - public :: stdlib_wsyconv - public :: stdlib_wsyconvf - public :: stdlib_wsyconvf_rook - public :: stdlib_wsyequb - public :: stdlib_wsymv - public :: stdlib_wsyr - public :: stdlib_wsyrfs - public :: stdlib_wsysv - public :: stdlib_wsysv_aa - public :: stdlib_wsysv_rk - public :: stdlib_wsysv_rook - public :: stdlib_wsysvx - public :: stdlib_wsyswapr - public :: stdlib_wsytf2 - public :: stdlib_wsytf2_rk - public :: stdlib_wsytf2_rook - public :: stdlib_wsytrf - public :: stdlib_wsytrf_aa - public :: stdlib_wsytrf_rk - public :: stdlib_wsytrf_rook - public :: stdlib_wsytri - public :: stdlib_wsytri_rook - public :: stdlib_wsytrs - public :: stdlib_wsytrs2 - public :: stdlib_wsytrs_3 - public :: stdlib_wsytrs_aa - public :: stdlib_wsytrs_rook - public :: stdlib_wtbcon - public :: stdlib_wtbrfs - public :: stdlib_wtbtrs - public :: stdlib_wtfsm - public :: stdlib_wtftri - public :: stdlib_wtfttp - public :: stdlib_wtfttr - public :: stdlib_wtgevc - public :: stdlib_wtgex2 - public :: stdlib_wtgexc - public :: stdlib_wtgsen - public :: stdlib_wtgsja - public :: stdlib_wtgsna - public :: stdlib_wtgsy2 - public :: stdlib_wtgsyl - public :: stdlib_wtpcon - public :: stdlib_wtplqt - public :: stdlib_wtplqt2 - public :: stdlib_wtpmlqt - public :: stdlib_wtpmqrt - public :: stdlib_wtpqrt - public :: stdlib_wtpqrt2 - public :: stdlib_wtprfb - public :: stdlib_wtprfs - public :: stdlib_wtptri - public :: stdlib_wtptrs - public :: stdlib_wtpttf - public :: stdlib_wtpttr - public :: stdlib_wtrcon - public :: stdlib_wtrevc - public :: stdlib_wtrevc3 - public :: stdlib_wtrexc - public :: stdlib_wtrrfs - public :: stdlib_wtrsen - public :: stdlib_wtrsna - public :: stdlib_wtrsyl - public :: stdlib_wtrti2 - public :: stdlib_wtrtri - public :: stdlib_wtrtrs - public :: stdlib_wtrttf - public :: stdlib_wtrttp - public :: stdlib_wtzrzf - public :: stdlib_wunbdb - public :: stdlib_wunbdb1 - public :: stdlib_wunbdb2 - public :: stdlib_wunbdb3 - public :: stdlib_wunbdb4 - public :: stdlib_wunbdb5 - public :: stdlib_wunbdb6 - public :: stdlib_wuncsd - public :: stdlib_wuncsd2by1 - public :: stdlib_wung2l - public :: stdlib_wung2r - public :: stdlib_wungbr - public :: stdlib_wunghr - public :: stdlib_wungl2 - public :: stdlib_wunglq - public :: stdlib_wungql - public :: stdlib_wungqr - public :: stdlib_wungr2 - public :: stdlib_wungrq - public :: stdlib_wungtr - public :: stdlib_wungtsqr - public :: stdlib_wungtsqr_row - public :: stdlib_wunhr_col - public :: stdlib_wunm22 - public :: stdlib_wunm2l - public :: stdlib_wunm2r - public :: stdlib_wunmbr - public :: stdlib_wunmhr - public :: stdlib_wunml2 - public :: stdlib_wunmlq - public :: stdlib_wunmql - public :: stdlib_wunmqr - public :: stdlib_wunmr2 - public :: stdlib_wunmr3 - public :: stdlib_wunmrq - public :: stdlib_wunmrz - public :: stdlib_wunmtr - public :: stdlib_wupgtr - public :: stdlib_wupmtr + public :: sp,dp,${ck}$,lk,ilp + public :: stdlib_${ci}$lag2w + public :: stdlib_${ci}$bbcsd + public :: stdlib_${ci}$bdsqr + public :: stdlib_${ci}$cgesv + public :: stdlib_${ci}$cposv + public :: stdlib_${ci}$drscl + public :: stdlib_${ci}$gbbrd + public :: stdlib_${ci}$gbcon + public :: stdlib_${ci}$gbequ + public :: stdlib_${ci}$gbequb + public :: stdlib_${ci}$gbrfs + public :: stdlib_${ci}$gbsv + public :: stdlib_${ci}$gbsvx + public :: stdlib_${ci}$gbtf2 + public :: stdlib_${ci}$gbtrf + public :: stdlib_${ci}$gbtrs + public :: stdlib_${ci}$gebak + public :: stdlib_${ci}$gebal + public :: stdlib_${ci}$gebd2 + public :: stdlib_${ci}$gebrd + public :: stdlib_${ci}$gecon + public :: stdlib_${ci}$geequ + public :: stdlib_${ci}$geequb + public :: stdlib_${ci}$gees + public :: stdlib_${ci}$geesx + public :: stdlib_${ci}$geev + public :: stdlib_${ci}$geevx + public :: stdlib_${ci}$gehd2 + public :: stdlib_${ci}$gehrd + public :: stdlib_${ci}$gejsv + public :: stdlib_${ci}$gelq + public :: stdlib_${ci}$gelq2 + public :: stdlib_${ci}$gelqf + public :: stdlib_${ci}$gelqt + public :: stdlib_${ci}$gelqt3 + public :: stdlib_${ci}$gels + public :: stdlib_${ci}$gelsd + public :: stdlib_${ci}$gelss + public :: stdlib_${ci}$gelsy + public :: stdlib_${ci}$gemlq + public :: stdlib_${ci}$gemlqt + public :: stdlib_${ci}$gemqr + public :: stdlib_${ci}$gemqrt + public :: stdlib_${ci}$geql2 + public :: stdlib_${ci}$geqlf + public :: stdlib_${ci}$geqp3 + public :: stdlib_${ci}$geqr + public :: stdlib_${ci}$geqr2 + public :: stdlib_${ci}$geqr2p + public :: stdlib_${ci}$geqrf + public :: stdlib_${ci}$geqrfp + public :: stdlib_${ci}$geqrt + public :: stdlib_${ci}$geqrt2 + public :: stdlib_${ci}$geqrt3 + public :: stdlib_${ci}$gerfs + public :: stdlib_${ci}$gerq2 + public :: stdlib_${ci}$gerqf + public :: stdlib_${ci}$gesc2 + public :: stdlib_${ci}$gesdd + public :: stdlib_${ci}$gesv + public :: stdlib_${ci}$gesvd + public :: stdlib_${ci}$gesvdq + public :: stdlib_${ci}$gesvj + public :: stdlib_${ci}$gesvx + public :: stdlib_${ci}$getc2 + public :: stdlib_${ci}$getf2 + public :: stdlib_${ci}$getrf + public :: stdlib_${ci}$getrf2 + public :: stdlib_${ci}$getri + public :: stdlib_${ci}$getrs + public :: stdlib_${ci}$getsls + public :: stdlib_${ci}$getsqrhrt + public :: stdlib_${ci}$ggbak + public :: stdlib_${ci}$ggbal + public :: stdlib_${ci}$gges + public :: stdlib_${ci}$gges3 + public :: stdlib_${ci}$ggesx + public :: stdlib_${ci}$ggev + public :: stdlib_${ci}$ggev3 + public :: stdlib_${ci}$ggevx + public :: stdlib_${ci}$ggglm + public :: stdlib_${ci}$gghd3 + public :: stdlib_${ci}$gghrd + public :: stdlib_${ci}$gglse + public :: stdlib_${ci}$ggqrf + public :: stdlib_${ci}$ggrqf + public :: stdlib_${ci}$gsvj0 + public :: stdlib_${ci}$gsvj1 + public :: stdlib_${ci}$gtcon + public :: stdlib_${ci}$gtrfs + public :: stdlib_${ci}$gtsv + public :: stdlib_${ci}$gtsvx + public :: stdlib_${ci}$gttrf + public :: stdlib_${ci}$gttrs + public :: stdlib_${ci}$gtts2 + public :: stdlib_${ci}$hb2st_kernels + public :: stdlib_${ci}$hbev + public :: stdlib_${ci}$hbevd + public :: stdlib_${ci}$hbevx + public :: stdlib_${ci}$hbgst + public :: stdlib_${ci}$hbgv + public :: stdlib_${ci}$hbgvd + public :: stdlib_${ci}$hbgvx + public :: stdlib_${ci}$hbtrd + public :: stdlib_${ci}$hecon + public :: stdlib_${ci}$hecon_rook + public :: stdlib_${ci}$heequb + public :: stdlib_${ci}$heev + public :: stdlib_${ci}$heevd + public :: stdlib_${ci}$heevr + public :: stdlib_${ci}$heevx + public :: stdlib_${ci}$hegs2 + public :: stdlib_${ci}$hegst + public :: stdlib_${ci}$hegv + public :: stdlib_${ci}$hegvd + public :: stdlib_${ci}$hegvx + public :: stdlib_${ci}$herfs + public :: stdlib_${ci}$hesv + public :: stdlib_${ci}$hesv_aa + public :: stdlib_${ci}$hesv_rk + public :: stdlib_${ci}$hesv_rook + public :: stdlib_${ci}$hesvx + public :: stdlib_${ci}$heswapr + public :: stdlib_${ci}$hetd2 + public :: stdlib_${ci}$hetf2 + public :: stdlib_${ci}$hetf2_rk + public :: stdlib_${ci}$hetf2_rook + public :: stdlib_${ci}$hetrd + public :: stdlib_${ci}$hetrd_hb2st + public :: stdlib_${ci}$hetrd_he2hb + public :: stdlib_${ci}$hetrf + public :: stdlib_${ci}$hetrf_aa + public :: stdlib_${ci}$hetrf_rk + public :: stdlib_${ci}$hetrf_rook + public :: stdlib_${ci}$hetri + public :: stdlib_${ci}$hetri_rook + public :: stdlib_${ci}$hetrs + public :: stdlib_${ci}$hetrs2 + public :: stdlib_${ci}$hetrs_3 + public :: stdlib_${ci}$hetrs_aa + public :: stdlib_${ci}$hetrs_rook + public :: stdlib_${ci}$hfrk + public :: stdlib_${ci}$hgeqz + public :: stdlib_${ci}$hpcon + public :: stdlib_${ci}$hpev + public :: stdlib_${ci}$hpevd + public :: stdlib_${ci}$hpevx + public :: stdlib_${ci}$hpgst + public :: stdlib_${ci}$hpgv + public :: stdlib_${ci}$hpgvd + public :: stdlib_${ci}$hpgvx + public :: stdlib_${ci}$hprfs + public :: stdlib_${ci}$hpsv + public :: stdlib_${ci}$hpsvx + public :: stdlib_${ci}$hptrd + public :: stdlib_${ci}$hptrf + public :: stdlib_${ci}$hptri + public :: stdlib_${ci}$hptrs + public :: stdlib_${ci}$hsein + public :: stdlib_${ci}$hseqr + public :: stdlib_${ci}$la_gbamv + public :: stdlib_${ci}$la_gbrcond_c + public :: stdlib_${ci}$la_gbrpvgrw + public :: stdlib_${ci}$la_geamv + public :: stdlib_${ci}$la_gercond_c + public :: stdlib_${ci}$la_gerpvgrw + public :: stdlib_${ci}$la_heamv + public :: stdlib_${ci}$la_hercond_c + public :: stdlib_${ci}$la_herpvgrw + public :: stdlib_${ci}$la_lin_berr + public :: stdlib_${ci}$la_porcond_c + public :: stdlib_${ci}$la_porpvgrw + public :: stdlib_${ci}$la_syamv + public :: stdlib_${ci}$la_syrcond_c + public :: stdlib_${ci}$la_syrpvgrw + public :: stdlib_${ci}$la_wwaddw + public :: stdlib_${ci}$labrd + public :: stdlib_${ci}$lacgv + public :: stdlib_${ci}$lacn2 + public :: stdlib_${ci}$lacon + public :: stdlib_${ci}$lacp2 + public :: stdlib_${ci}$lacpy + public :: stdlib_${ci}$lacrm + public :: stdlib_${ci}$lacrt + public :: stdlib_${ci}$ladiv + public :: stdlib_${ci}$laed0 + public :: stdlib_${ci}$laed7 + public :: stdlib_${ci}$laed8 + public :: stdlib_${ci}$laein + public :: stdlib_${ci}$laesy + public :: stdlib_${ci}$laev2 + public :: stdlib_${ci}$lag2c + public :: stdlib_${ci}$lags2 + public :: stdlib_${ci}$lagtm + public :: stdlib_${ci}$lahef + public :: stdlib_${ci}$lahef_aa + public :: stdlib_${ci}$lahef_rk + public :: stdlib_${ci}$lahef_rook + public :: stdlib_${ci}$lahqr + public :: stdlib_${ci}$lahr2 + public :: stdlib_${ci}$laic1 + public :: stdlib_${ci}$lals0 + public :: stdlib_${ci}$lalsa + public :: stdlib_${ci}$lalsd + public :: stdlib_${ci}$lamswlq + public :: stdlib_${ci}$lamtsqr + public :: stdlib_${ci}$langb + public :: stdlib_${ci}$lange + public :: stdlib_${ci}$langt + public :: stdlib_${ci}$lanhb + public :: stdlib_${ci}$lanhe + public :: stdlib_${ci}$lanhf + public :: stdlib_${ci}$lanhp + public :: stdlib_${ci}$lanhs + public :: stdlib_${ci}$lanht + public :: stdlib_${ci}$lansb + public :: stdlib_${ci}$lansp + public :: stdlib_${ci}$lansy + public :: stdlib_${ci}$lantb + public :: stdlib_${ci}$lantp + public :: stdlib_${ci}$lantr + public :: stdlib_${ci}$lapll + public :: stdlib_${ci}$lapmr + public :: stdlib_${ci}$lapmt + public :: stdlib_${ci}$laqgb + public :: stdlib_${ci}$laqge + public :: stdlib_${ci}$laqhb + public :: stdlib_${ci}$laqhe + public :: stdlib_${ci}$laqhp + public :: stdlib_${ci}$laqp2 + public :: stdlib_${ci}$laqps + public :: stdlib_${ci}$laqr0 + public :: stdlib_${ci}$laqr1 + public :: stdlib_${ci}$laqr2 + public :: stdlib_${ci}$laqr3 + public :: stdlib_${ci}$laqr4 + public :: stdlib_${ci}$laqr5 + public :: stdlib_${ci}$laqsb + public :: stdlib_${ci}$laqsp + public :: stdlib_${ci}$laqsy + public :: stdlib_${ci}$laqz0 + public :: stdlib_${ci}$laqz1 + public :: stdlib_${ci}$laqz2 + public :: stdlib_${ci}$laqz3 + public :: stdlib_${ci}$lar1v + public :: stdlib_${ci}$lar2v + public :: stdlib_${ci}$larcm + public :: stdlib_${ci}$larf + public :: stdlib_${ci}$larfb + public :: stdlib_${ci}$larfb_gett + public :: stdlib_${ci}$larfg + public :: stdlib_${ci}$larfgp + public :: stdlib_${ci}$larft + public :: stdlib_${ci}$larfx + public :: stdlib_${ci}$larfy + public :: stdlib_${ci}$largv + public :: stdlib_${ci}$larnv + public :: stdlib_${ci}$larrv + public :: stdlib_${ci}$lartg + public :: stdlib_${ci}$lartv + public :: stdlib_${ci}$larz + public :: stdlib_${ci}$larzb + public :: stdlib_${ci}$larzt + public :: stdlib_${ci}$lascl + public :: stdlib_${ci}$laset + public :: stdlib_${ci}$lasr + public :: stdlib_${ci}$lassq + public :: stdlib_${ci}$laswlq + public :: stdlib_${ci}$laswp + public :: stdlib_${ci}$lasyf + public :: stdlib_${ci}$lasyf_aa + public :: stdlib_${ci}$lasyf_rk + public :: stdlib_${ci}$lasyf_rook + public :: stdlib_${ci}$lat2c + public :: stdlib_${ci}$latbs + public :: stdlib_${ci}$latdf + public :: stdlib_${ci}$latps + public :: stdlib_${ci}$latrd + public :: stdlib_${ci}$latrs + public :: stdlib_${ci}$latrz + public :: stdlib_${ci}$latsqr + public :: stdlib_${ci}$launhr_col_getrfnp + public :: stdlib_${ci}$launhr_col_getrfnp2 + public :: stdlib_${ci}$lauu2 + public :: stdlib_${ci}$lauum + public :: stdlib_${ci}$pbcon + public :: stdlib_${ci}$pbequ + public :: stdlib_${ci}$pbrfs + public :: stdlib_${ci}$pbstf + public :: stdlib_${ci}$pbsv + public :: stdlib_${ci}$pbsvx + public :: stdlib_${ci}$pbtf2 + public :: stdlib_${ci}$pbtrf + public :: stdlib_${ci}$pbtrs + public :: stdlib_${ci}$pftrf + public :: stdlib_${ci}$pftri + public :: stdlib_${ci}$pftrs + public :: stdlib_${ci}$pocon + public :: stdlib_${ci}$poequ + public :: stdlib_${ci}$poequb + public :: stdlib_${ci}$porfs + public :: stdlib_${ci}$posv + public :: stdlib_${ci}$posvx + public :: stdlib_${ci}$potf2 + public :: stdlib_${ci}$potrf + public :: stdlib_${ci}$potrf2 + public :: stdlib_${ci}$potri + public :: stdlib_${ci}$potrs + public :: stdlib_${ci}$ppcon + public :: stdlib_${ci}$ppequ + public :: stdlib_${ci}$pprfs + public :: stdlib_${ci}$ppsv + public :: stdlib_${ci}$ppsvx + public :: stdlib_${ci}$pptrf + public :: stdlib_${ci}$pptri + public :: stdlib_${ci}$pptrs + public :: stdlib_${ci}$pstf2 + public :: stdlib_${ci}$pstrf + public :: stdlib_${ci}$ptcon + public :: stdlib_${ci}$pteqr + public :: stdlib_${ci}$ptrfs + public :: stdlib_${ci}$ptsv + public :: stdlib_${ci}$ptsvx + public :: stdlib_${ci}$pttrf + public :: stdlib_${ci}$pttrs + public :: stdlib_${ci}$ptts2 + public :: stdlib_${ci}$rot + public :: stdlib_${ci}$spcon + public :: stdlib_${ci}$spmv + public :: stdlib_${ci}$spr + public :: stdlib_${ci}$sprfs + public :: stdlib_${ci}$spsv + public :: stdlib_${ci}$spsvx + public :: stdlib_${ci}$sptrf + public :: stdlib_${ci}$sptri + public :: stdlib_${ci}$sptrs + public :: stdlib_${ci}$stedc + public :: stdlib_${ci}$stegr + public :: stdlib_${ci}$stein + public :: stdlib_${ci}$stemr + public :: stdlib_${ci}$steqr + public :: stdlib_${ci}$sycon + public :: stdlib_${ci}$sycon_rook + public :: stdlib_${ci}$syconv + public :: stdlib_${ci}$syconvf + public :: stdlib_${ci}$syconvf_rook + public :: stdlib_${ci}$syequb + public :: stdlib_${ci}$symv + public :: stdlib_${ci}$syr + public :: stdlib_${ci}$syrfs + public :: stdlib_${ci}$sysv + public :: stdlib_${ci}$sysv_aa + public :: stdlib_${ci}$sysv_rk + public :: stdlib_${ci}$sysv_rook + public :: stdlib_${ci}$sysvx + public :: stdlib_${ci}$syswapr + public :: stdlib_${ci}$sytf2 + public :: stdlib_${ci}$sytf2_rk + public :: stdlib_${ci}$sytf2_rook + public :: stdlib_${ci}$sytrf + public :: stdlib_${ci}$sytrf_aa + public :: stdlib_${ci}$sytrf_rk + public :: stdlib_${ci}$sytrf_rook + public :: stdlib_${ci}$sytri + public :: stdlib_${ci}$sytri_rook + public :: stdlib_${ci}$sytrs + public :: stdlib_${ci}$sytrs2 + public :: stdlib_${ci}$sytrs_3 + public :: stdlib_${ci}$sytrs_aa + public :: stdlib_${ci}$sytrs_rook + public :: stdlib_${ci}$tbcon + public :: stdlib_${ci}$tbrfs + public :: stdlib_${ci}$tbtrs + public :: stdlib_${ci}$tfsm + public :: stdlib_${ci}$tftri + public :: stdlib_${ci}$tfttp + public :: stdlib_${ci}$tfttr + public :: stdlib_${ci}$tgevc + public :: stdlib_${ci}$tgex2 + public :: stdlib_${ci}$tgexc + public :: stdlib_${ci}$tgsen + public :: stdlib_${ci}$tgsja + public :: stdlib_${ci}$tgsna + public :: stdlib_${ci}$tgsy2 + public :: stdlib_${ci}$tgsyl + public :: stdlib_${ci}$tpcon + public :: stdlib_${ci}$tplqt + public :: stdlib_${ci}$tplqt2 + public :: stdlib_${ci}$tpmlqt + public :: stdlib_${ci}$tpmqrt + public :: stdlib_${ci}$tpqrt + public :: stdlib_${ci}$tpqrt2 + public :: stdlib_${ci}$tprfb + public :: stdlib_${ci}$tprfs + public :: stdlib_${ci}$tptri + public :: stdlib_${ci}$tptrs + public :: stdlib_${ci}$tpttf + public :: stdlib_${ci}$tpttr + public :: stdlib_${ci}$trcon + public :: stdlib_${ci}$trevc + public :: stdlib_${ci}$trevc3 + public :: stdlib_${ci}$trexc + public :: stdlib_${ci}$trrfs + public :: stdlib_${ci}$trsen + public :: stdlib_${ci}$trsna + public :: stdlib_${ci}$trsyl + public :: stdlib_${ci}$trti2 + public :: stdlib_${ci}$trtri + public :: stdlib_${ci}$trtrs + public :: stdlib_${ci}$trttf + public :: stdlib_${ci}$trttp + public :: stdlib_${ci}$tzrzf + public :: stdlib_${ci}$unbdb + public :: stdlib_${ci}$unbdb1 + public :: stdlib_${ci}$unbdb2 + public :: stdlib_${ci}$unbdb3 + public :: stdlib_${ci}$unbdb4 + public :: stdlib_${ci}$unbdb5 + public :: stdlib_${ci}$unbdb6 + public :: stdlib_${ci}$uncsd + public :: stdlib_${ci}$uncsd2by1 + public :: stdlib_${ci}$ung2l + public :: stdlib_${ci}$ung2r + public :: stdlib_${ci}$ungbr + public :: stdlib_${ci}$unghr + public :: stdlib_${ci}$ungl2 + public :: stdlib_${ci}$unglq + public :: stdlib_${ci}$ungql + public :: stdlib_${ci}$ungqr + public :: stdlib_${ci}$ungr2 + public :: stdlib_${ci}$ungrq + public :: stdlib_${ci}$ungtr + public :: stdlib_${ci}$ungtsqr + public :: stdlib_${ci}$ungtsqr_row + public :: stdlib_${ci}$unhr_col + public :: stdlib_${ci}$unm22 + public :: stdlib_${ci}$unm2l + public :: stdlib_${ci}$unm2r + public :: stdlib_${ci}$unmbr + public :: stdlib_${ci}$unmhr + public :: stdlib_${ci}$unml2 + public :: stdlib_${ci}$unmlq + public :: stdlib_${ci}$unmql + public :: stdlib_${ci}$unmqr + public :: stdlib_${ci}$unmr2 + public :: stdlib_${ci}$unmr3 + public :: stdlib_${ci}$unmrq + public :: stdlib_${ci}$unmrz + public :: stdlib_${ci}$unmtr + public :: stdlib_${ci}$upgtr + public :: stdlib_${ci}$upmtr ! 128-bit real constants - real(qp), parameter, private :: negone = -1.00_qp - real(qp), parameter, private :: zero = 0.00_qp - real(qp), parameter, private :: half = 0.50_qp - real(qp), parameter, private :: one = 1.00_qp - real(qp), parameter, private :: two = 2.00_qp - real(qp), parameter, private :: three = 3.00_qp - real(qp), parameter, private :: four = 4.00_qp - real(qp), parameter, private :: eight = 8.00_qp - real(qp), parameter, private :: ten = 10.00_qp + real(${ck}$), parameter, private :: negone = -1.00_${ck}$ + real(${ck}$), parameter, private :: zero = 0.00_${ck}$ + real(${ck}$), parameter, private :: half = 0.50_${ck}$ + real(${ck}$), parameter, private :: one = 1.00_${ck}$ + real(${ck}$), parameter, private :: two = 2.00_${ck}$ + real(${ck}$), parameter, private :: three = 3.00_${ck}$ + real(${ck}$), parameter, private :: four = 4.00_${ck}$ + real(${ck}$), parameter, private :: eight = 8.00_${ck}$ + real(${ck}$), parameter, private :: ten = 10.00_${ck}$ ! 128-bit complex constants - complex(qp), parameter, private :: czero = ( 0.0_qp,0.0_qp) - complex(qp), parameter, private :: chalf = ( 0.5_qp,0.0_qp) - complex(qp), parameter, private :: cone = ( 1.0_qp,0.0_qp) - complex(qp), parameter, private :: cnegone = (-1.0_qp,0.0_qp) + complex(${ck}$), parameter, private :: czero = ( 0.0_${ck}$,0.0_${ck}$) + complex(${ck}$), parameter, private :: chalf = ( 0.5_${ck}$,0.0_${ck}$) + complex(${ck}$), parameter, private :: cone = ( 1.0_${ck}$,0.0_${ck}$) + complex(${ck}$), parameter, private :: cnegone = (-1.0_${ck}$,0.0_${ck}$) ! 128-bit scaling constants integer, parameter, private :: maxexp = maxexponent(zero) integer, parameter, private :: minexp = minexponent(zero) - real(qp), parameter, private :: rradix = real(radix(zero),qp) - real(qp), parameter, private :: ulp = epsilon(zero) - real(qp), parameter, private :: eps = ulp*half - real(qp), parameter, private :: safmin = rradix**max(minexp-1,1-maxexp) - real(qp), parameter, private :: safmax = one/safmin - real(qp), parameter, private :: smlnum = safmin/ulp - real(qp), parameter, private :: bignum = safmax*ulp - real(qp), parameter, private :: rtmin = sqrt(smlnum) - real(qp), parameter, private :: rtmax = sqrt(bignum) + real(${ck}$), parameter, private :: rradix = real(radix(zero),${ck}$) + real(${ck}$), parameter, private :: ulp = epsilon(zero) + real(${ck}$), parameter, private :: eps = ulp*half + real(${ck}$), parameter, private :: safmin = rradix**max(minexp-1,1-maxexp) + real(${ck}$), parameter, private :: safmax = one/safmin + real(${ck}$), parameter, private :: smlnum = safmin/ulp + real(${ck}$), parameter, private :: bignum = safmax*ulp + real(${ck}$), parameter, private :: rtmin = sqrt(smlnum) + real(${ck}$), parameter, private :: rtmax = sqrt(bignum) ! 128-bit Blue's scaling constants ! ssml>=1/s and sbig==1/S with s,S as defined in https://doi.org/10.1145/355769.355771 - real(qp), parameter, private :: tsml = rradix**ceiling((minexp-1)*half) - real(qp), parameter, private :: tbig = rradix**floor((maxexp-digits(zero)+1)*half) - real(qp), parameter, private :: ssml = rradix**(-floor((minexp-digits(zero))*half)) - real(qp), parameter, private :: sbig = rradix**(-ceiling((maxexp+digits(zero)-1)*half)) + real(${ck}$), parameter, private :: tsml = rradix**ceiling((minexp-1)*half) + real(${ck}$), parameter, private :: tbig = rradix**floor((maxexp-digits(zero)+1)*half) + real(${ck}$), parameter, private :: ssml = rradix**(-floor((minexp-digits(zero))*half)) + real(${ck}$), parameter, private :: sbig = rradix**(-ceiling((maxexp+digits(zero)-1)*half)) contains - pure subroutine stdlib_wlag2w( m, n, sa, ldsa, a, lda, info ) + pure subroutine stdlib_${ci}$lag2w( m, n, sa, ldsa, a, lda, info ) !! ZLAG2W: converts a COMPLEX matrix, SA, to a COMPLEX*16 matrix, A. !! Note that while it is possible to overflow while converting !! from double to single, it is not possible to overflow when @@ -520,8 +522,8 @@ module stdlib_linalg_lapack_w integer(ilp), intent(out) :: info integer(ilp), intent(in) :: lda, ldsa, m, n ! Array Arguments - complex(qp), intent(in) :: sa(ldsa,*) - complex(qp), intent(out) :: a(lda,*) + complex(dp), intent(in) :: sa(ldsa,*) + complex(${ck}$), intent(out) :: a(lda,*) ! ===================================================================== ! Local Scalars integer(ilp) :: i, j @@ -533,10 +535,10 @@ module stdlib_linalg_lapack_w end do end do return - end subroutine stdlib_wlag2w + end subroutine stdlib_${ci}$lag2w - pure subroutine stdlib_wbbcsd( jobu1, jobu2, jobv1t, jobv2t, trans, m, p, q,theta, phi, u1, & + pure subroutine stdlib_${ci}$bbcsd( jobu1, jobu2, jobv1t, jobv2t, trans, m, p, q,theta, phi, u1, & !! ZBBCSD: computes the CS decomposition of a unitary matrix in !! bidiagonal-block form, !! [ B11 | B12 0 0 ] @@ -568,17 +570,17 @@ module stdlib_linalg_lapack_w integer(ilp), intent(out) :: info integer(ilp), intent(in) :: ldu1, ldu2, ldv1t, ldv2t, lrwork, m, p, q ! Array Arguments - real(qp), intent(out) :: b11d(*), b11e(*), b12d(*), b12e(*), b21d(*), b21e(*), b22d(*),& + real(${ck}$), intent(out) :: b11d(*), b11e(*), b12d(*), b12e(*), b21d(*), b21e(*), b22d(*),& b22e(*), rwork(*) - real(qp), intent(inout) :: phi(*), theta(*) - complex(qp), intent(inout) :: u1(ldu1,*), u2(ldu2,*), v1t(ldv1t,*), v2t(ldv2t,*) + real(${ck}$), intent(inout) :: phi(*), theta(*) + complex(${ck}$), intent(inout) :: u1(ldu1,*), u2(ldu2,*), v1t(ldv1t,*), v2t(ldv2t,*) ! =================================================================== ! Parameters integer(ilp), parameter :: maxitr = 6 - real(qp), parameter :: hundred = 100.0_qp - real(qp), parameter :: meighth = -0.125_qp - real(qp), parameter :: piover2 = 1.57079632679489661923132169163975144210_qp + real(${ck}$), parameter :: hundred = 100.0_${ck}$ + real(${ck}$), parameter :: meighth = -0.125_${ck}$ + real(${ck}$), parameter :: piover2 = 1.57079632679489661923132169163975144210_${ck}$ @@ -588,7 +590,7 @@ module stdlib_linalg_lapack_w wantu2, wantv1t, wantv2t integer(ilp) :: i, imin, imax, iter, iu1cs, iu1sn, iu2cs, iu2sn, iv1tcs, iv1tsn, & iv2tcs, iv2tsn, j, lrworkmin, lrworkopt, maxit, mini - real(qp) :: b11bulge, b12bulge, b21bulge, b22bulge, dummy, eps, mu, nu, r, sigma11, & + real(${ck}$) :: b11bulge, b12bulge, b21bulge, b22bulge, dummy, eps, mu, nu, r, sigma11, & sigma21, temp, thetamax, thetamin, thresh, tol, tolmul, unfl, x1, x2, y1, y2 ! Intrinsic Functions intrinsic :: abs,atan2,cos,max,min,sin,sqrt @@ -648,8 +650,8 @@ module stdlib_linalg_lapack_w return end if ! get machine constants - eps = stdlib_qlamch( 'EPSILON' ) - unfl = stdlib_qlamch( 'SAFE MINIMUM' ) + eps = stdlib_${c2ri(ci)}$lamch( 'EPSILON' ) + unfl = stdlib_${c2ri(ci)}$lamch( 'SAFE MINIMUM' ) tolmul = max( ten, min( hundred, eps**meighth ) ) tol = tolmul*eps thresh = max( tol, maxitr*q*q*unfl ) @@ -731,9 +733,9 @@ module stdlib_linalg_lapack_w nu = zero else ! compute shifts for b11 and b21 and use the lesser - call stdlib_qlas2( b11d(imax-1), b11e(imax-1), b11d(imax), sigma11,dummy ) + call stdlib_${c2ri(ci)}$las2( b11d(imax-1), b11e(imax-1), b11d(imax), sigma11,dummy ) - call stdlib_qlas2( b21d(imax-1), b21e(imax-1), b21d(imax), sigma21,dummy ) + call stdlib_${c2ri(ci)}$las2( b21d(imax-1), b21e(imax-1), b21d(imax), sigma21,dummy ) if( sigma11 <= sigma21 ) then mu = sigma11 @@ -744,7 +746,7 @@ module stdlib_linalg_lapack_w end if else nu = sigma21 - mu = sqrt( 1.0_qp - nu**2 ) + mu = sqrt( 1.0_${ck}$ - nu**2 ) if( nu < thresh ) then mu = one nu = zero @@ -753,10 +755,10 @@ module stdlib_linalg_lapack_w end if ! rotate to produce bulges in b11 and b21 if( mu <= nu ) then - call stdlib_qlartgs( b11d(imin), b11e(imin), mu,rwork(iv1tcs+imin-1), rwork(& + call stdlib_${c2ri(ci)}$lartgs( b11d(imin), b11e(imin), mu,rwork(iv1tcs+imin-1), rwork(& iv1tsn+imin-1) ) else - call stdlib_qlartgs( b21d(imin), b21e(imin), nu,rwork(iv1tcs+imin-1), rwork(& + call stdlib_${c2ri(ci)}$lartgs( b21d(imin), b21e(imin), nu,rwork(iv1tcs+imin-1), rwork(& iv1tsn+imin-1) ) end if temp = rwork(iv1tcs+imin-1)*b11d(imin) +rwork(iv1tsn+imin-1)*b11e(imin) @@ -776,23 +778,23 @@ module stdlib_linalg_lapack_w b11bulge**2 ) ) ! chase the bulges in b11(imin+1,imin) and b21(imin+1,imin) if( b11d(imin)**2+b11bulge**2 > thresh**2 ) then - call stdlib_qlartgp( b11bulge, b11d(imin), rwork(iu1sn+imin-1),rwork(iu1cs+imin-& + call stdlib_${c2ri(ci)}$lartgp( b11bulge, b11d(imin), rwork(iu1sn+imin-1),rwork(iu1cs+imin-& 1), r ) else if( mu <= nu ) then - call stdlib_qlartgs( b11e( imin ), b11d( imin + 1 ), mu,rwork(iu1cs+imin-1), & + call stdlib_${c2ri(ci)}$lartgs( b11e( imin ), b11d( imin + 1 ), mu,rwork(iu1cs+imin-1), & rwork(iu1sn+imin-1) ) else - call stdlib_qlartgs( b12d( imin ), b12e( imin ), nu,rwork(iu1cs+imin-1), rwork(& + call stdlib_${c2ri(ci)}$lartgs( b12d( imin ), b12e( imin ), nu,rwork(iu1cs+imin-1), rwork(& iu1sn+imin-1) ) end if if( b21d(imin)**2+b21bulge**2 > thresh**2 ) then - call stdlib_qlartgp( b21bulge, b21d(imin), rwork(iu2sn+imin-1),rwork(iu2cs+imin-& + call stdlib_${c2ri(ci)}$lartgp( b21bulge, b21d(imin), rwork(iu2sn+imin-1),rwork(iu2cs+imin-& 1), r ) else if( nu < mu ) then - call stdlib_qlartgs( b21e( imin ), b21d( imin + 1 ), nu,rwork(iu2cs+imin-1), & + call stdlib_${c2ri(ci)}$lartgs( b21e( imin ), b21d( imin + 1 ), nu,rwork(iu2cs+imin-1), & rwork(iu2sn+imin-1) ) else - call stdlib_qlartgs( b22d(imin), b22e(imin), mu,rwork(iu2cs+imin-1), rwork(iu2sn+& + call stdlib_${c2ri(ci)}$lartgs( b22d(imin), b22e(imin), mu,rwork(iu2cs+imin-1), rwork(iu2sn+& imin-1) ) end if rwork(iu2cs+imin-1) = -rwork(iu2cs+imin-1) @@ -843,36 +845,36 @@ module stdlib_linalg_lapack_w ! b21(i-1,i+1), and b22(i-1,i). if necessary, restart bulge- ! chasing by applying the original shift again. if( .not. restart11 .and. .not. restart21 ) then - call stdlib_qlartgp( x2, x1, rwork(iv1tsn+i-1),rwork(iv1tcs+i-1), r ) + call stdlib_${c2ri(ci)}$lartgp( x2, x1, rwork(iv1tsn+i-1),rwork(iv1tcs+i-1), r ) else if( .not. restart11 .and. restart21 ) then - call stdlib_qlartgp( b11bulge, b11e(i-1), rwork(iv1tsn+i-1),rwork(iv1tcs+i-1),& + call stdlib_${c2ri(ci)}$lartgp( b11bulge, b11e(i-1), rwork(iv1tsn+i-1),rwork(iv1tcs+i-1),& r ) else if( restart11 .and. .not. restart21 ) then - call stdlib_qlartgp( b21bulge, b21e(i-1), rwork(iv1tsn+i-1),rwork(iv1tcs+i-1),& + call stdlib_${c2ri(ci)}$lartgp( b21bulge, b21e(i-1), rwork(iv1tsn+i-1),rwork(iv1tcs+i-1),& r ) else if( mu <= nu ) then - call stdlib_qlartgs( b11d(i), b11e(i), mu, rwork(iv1tcs+i-1),rwork(iv1tsn+i-1)& + call stdlib_${c2ri(ci)}$lartgs( b11d(i), b11e(i), mu, rwork(iv1tcs+i-1),rwork(iv1tsn+i-1)& ) else - call stdlib_qlartgs( b21d(i), b21e(i), nu, rwork(iv1tcs+i-1),rwork(iv1tsn+i-1)& + call stdlib_${c2ri(ci)}$lartgs( b21d(i), b21e(i), nu, rwork(iv1tcs+i-1),rwork(iv1tsn+i-1)& ) end if rwork(iv1tcs+i-1) = -rwork(iv1tcs+i-1) rwork(iv1tsn+i-1) = -rwork(iv1tsn+i-1) if( .not. restart12 .and. .not. restart22 ) then - call stdlib_qlartgp( y2, y1, rwork(iv2tsn+i-1-1),rwork(iv2tcs+i-1-1), r ) + call stdlib_${c2ri(ci)}$lartgp( y2, y1, rwork(iv2tsn+i-1-1),rwork(iv2tcs+i-1-1), r ) else if( .not. restart12 .and. restart22 ) then - call stdlib_qlartgp( b12bulge, b12d(i-1), rwork(iv2tsn+i-1-1),rwork(iv2tcs+i-& + call stdlib_${c2ri(ci)}$lartgp( b12bulge, b12d(i-1), rwork(iv2tsn+i-1-1),rwork(iv2tcs+i-& 1-1), r ) else if( restart12 .and. .not. restart22 ) then - call stdlib_qlartgp( b22bulge, b22d(i-1), rwork(iv2tsn+i-1-1),rwork(iv2tcs+i-& + call stdlib_${c2ri(ci)}$lartgp( b22bulge, b22d(i-1), rwork(iv2tsn+i-1-1),rwork(iv2tcs+i-& 1-1), r ) else if( nu < mu ) then - call stdlib_qlartgs( b12e(i-1), b12d(i), nu,rwork(iv2tcs+i-1-1), rwork(iv2tsn+& + call stdlib_${c2ri(ci)}$lartgs( b12e(i-1), b12d(i), nu,rwork(iv2tcs+i-1-1), rwork(iv2tsn+& i-1-1) ) else - call stdlib_qlartgs( b22e(i-1), b22d(i), mu,rwork(iv2tcs+i-1-1), rwork(iv2tsn+& + call stdlib_${c2ri(ci)}$lartgs( b22e(i-1), b22d(i), mu,rwork(iv2tcs+i-1-1), rwork(iv2tsn+& i-1-1) ) end if temp = rwork(iv1tcs+i-1)*b11d(i) + rwork(iv1tsn+i-1)*b11e(i) @@ -911,33 +913,33 @@ module stdlib_linalg_lapack_w ! b21(i+1,i), and b22(i+1,i-1). if necessary, restart bulge- ! chasing by applying the original shift again. if( .not. restart11 .and. .not. restart12 ) then - call stdlib_qlartgp( x2, x1, rwork(iu1sn+i-1), rwork(iu1cs+i-1),r ) + call stdlib_${c2ri(ci)}$lartgp( x2, x1, rwork(iu1sn+i-1), rwork(iu1cs+i-1),r ) else if( .not. restart11 .and. restart12 ) then - call stdlib_qlartgp( b11bulge, b11d(i), rwork(iu1sn+i-1),rwork(iu1cs+i-1), r ) + call stdlib_${c2ri(ci)}$lartgp( b11bulge, b11d(i), rwork(iu1sn+i-1),rwork(iu1cs+i-1), r ) else if( restart11 .and. .not. restart12 ) then - call stdlib_qlartgp( b12bulge, b12e(i-1), rwork(iu1sn+i-1),rwork(iu1cs+i-1), & + call stdlib_${c2ri(ci)}$lartgp( b12bulge, b12e(i-1), rwork(iu1sn+i-1),rwork(iu1cs+i-1), & r ) else if( mu <= nu ) then - call stdlib_qlartgs( b11e(i), b11d(i+1), mu, rwork(iu1cs+i-1),rwork(iu1sn+i-1)& + call stdlib_${c2ri(ci)}$lartgs( b11e(i), b11d(i+1), mu, rwork(iu1cs+i-1),rwork(iu1sn+i-1)& ) else - call stdlib_qlartgs( b12d(i), b12e(i), nu, rwork(iu1cs+i-1),rwork(iu1sn+i-1) ) + call stdlib_${c2ri(ci)}$lartgs( b12d(i), b12e(i), nu, rwork(iu1cs+i-1),rwork(iu1sn+i-1) ) end if if( .not. restart21 .and. .not. restart22 ) then - call stdlib_qlartgp( y2, y1, rwork(iu2sn+i-1), rwork(iu2cs+i-1),r ) + call stdlib_${c2ri(ci)}$lartgp( y2, y1, rwork(iu2sn+i-1), rwork(iu2cs+i-1),r ) else if( .not. restart21 .and. restart22 ) then - call stdlib_qlartgp( b21bulge, b21d(i), rwork(iu2sn+i-1),rwork(iu2cs+i-1), r ) + call stdlib_${c2ri(ci)}$lartgp( b21bulge, b21d(i), rwork(iu2sn+i-1),rwork(iu2cs+i-1), r ) else if( restart21 .and. .not. restart22 ) then - call stdlib_qlartgp( b22bulge, b22e(i-1), rwork(iu2sn+i-1),rwork(iu2cs+i-1), & + call stdlib_${c2ri(ci)}$lartgp( b22bulge, b22e(i-1), rwork(iu2sn+i-1),rwork(iu2cs+i-1), & r ) else if( nu < mu ) then - call stdlib_qlartgs( b21e(i), b21e(i+1), nu, rwork(iu2cs+i-1),rwork(iu2sn+i-1)& + call stdlib_${c2ri(ci)}$lartgs( b21e(i), b21e(i+1), nu, rwork(iu2cs+i-1),rwork(iu2sn+i-1)& ) else - call stdlib_qlartgs( b22d(i), b22e(i), mu, rwork(iu2cs+i-1),rwork(iu2sn+i-1) ) + call stdlib_${c2ri(ci)}$lartgs( b22d(i), b22e(i), mu, rwork(iu2cs+i-1),rwork(iu2sn+i-1) ) end if rwork(iu2cs+i-1) = -rwork(iu2cs+i-1) @@ -976,19 +978,19 @@ module stdlib_linalg_lapack_w restart12 = b12d(imax-1)**2 + b12bulge**2 <= thresh**2 restart22 = b22d(imax-1)**2 + b22bulge**2 <= thresh**2 if( .not. restart12 .and. .not. restart22 ) then - call stdlib_qlartgp( y2, y1, rwork(iv2tsn+imax-1-1),rwork(iv2tcs+imax-1-1), r ) + call stdlib_${c2ri(ci)}$lartgp( y2, y1, rwork(iv2tsn+imax-1-1),rwork(iv2tcs+imax-1-1), r ) else if( .not. restart12 .and. restart22 ) then - call stdlib_qlartgp( b12bulge, b12d(imax-1),rwork(iv2tsn+imax-1-1),rwork(iv2tcs+& + call stdlib_${c2ri(ci)}$lartgp( b12bulge, b12d(imax-1),rwork(iv2tsn+imax-1-1),rwork(iv2tcs+& imax-1-1), r ) else if( restart12 .and. .not. restart22 ) then - call stdlib_qlartgp( b22bulge, b22d(imax-1),rwork(iv2tsn+imax-1-1),rwork(iv2tcs+& + call stdlib_${c2ri(ci)}$lartgp( b22bulge, b22d(imax-1),rwork(iv2tsn+imax-1-1),rwork(iv2tcs+& imax-1-1), r ) else if( nu < mu ) then - call stdlib_qlartgs( b12e(imax-1), b12d(imax), nu,rwork(iv2tcs+imax-1-1),rwork(& + call stdlib_${c2ri(ci)}$lartgs( b12e(imax-1), b12d(imax), nu,rwork(iv2tcs+imax-1-1),rwork(& iv2tsn+imax-1-1) ) else - call stdlib_qlartgs( b22e(imax-1), b22d(imax), mu,rwork(iv2tcs+imax-1-1),rwork(& + call stdlib_${c2ri(ci)}$lartgs( b22e(imax-1), b22d(imax), mu,rwork(iv2tcs+imax-1-1),rwork(& iv2tsn+imax-1-1) ) end if temp = rwork(iv2tcs+imax-1-1)*b12e(imax-1) +rwork(iv2tsn+imax-1-1)*b12d(imax) @@ -1004,37 +1006,37 @@ module stdlib_linalg_lapack_w ! update singular vectors if( wantu1 ) then if( colmajor ) then - call stdlib_wlasr( 'R', 'V', 'F', p, imax-imin+1,rwork(iu1cs+imin-1), rwork(& + call stdlib_${ci}$lasr( 'R', 'V', 'F', p, imax-imin+1,rwork(iu1cs+imin-1), rwork(& iu1sn+imin-1),u1(1,imin), ldu1 ) else - call stdlib_wlasr( 'L', 'V', 'F', imax-imin+1, p,rwork(iu1cs+imin-1), rwork(& + call stdlib_${ci}$lasr( 'L', 'V', 'F', imax-imin+1, p,rwork(iu1cs+imin-1), rwork(& iu1sn+imin-1),u1(imin,1), ldu1 ) end if end if if( wantu2 ) then if( colmajor ) then - call stdlib_wlasr( 'R', 'V', 'F', m-p, imax-imin+1,rwork(iu2cs+imin-1), rwork(& + call stdlib_${ci}$lasr( 'R', 'V', 'F', m-p, imax-imin+1,rwork(iu2cs+imin-1), rwork(& iu2sn+imin-1),u2(1,imin), ldu2 ) else - call stdlib_wlasr( 'L', 'V', 'F', imax-imin+1, m-p,rwork(iu2cs+imin-1), rwork(& + call stdlib_${ci}$lasr( 'L', 'V', 'F', imax-imin+1, m-p,rwork(iu2cs+imin-1), rwork(& iu2sn+imin-1),u2(imin,1), ldu2 ) end if end if if( wantv1t ) then if( colmajor ) then - call stdlib_wlasr( 'L', 'V', 'F', imax-imin+1, q,rwork(iv1tcs+imin-1), rwork(& + call stdlib_${ci}$lasr( 'L', 'V', 'F', imax-imin+1, q,rwork(iv1tcs+imin-1), rwork(& iv1tsn+imin-1),v1t(imin,1), ldv1t ) else - call stdlib_wlasr( 'R', 'V', 'F', q, imax-imin+1,rwork(iv1tcs+imin-1), rwork(& + call stdlib_${ci}$lasr( 'R', 'V', 'F', q, imax-imin+1,rwork(iv1tcs+imin-1), rwork(& iv1tsn+imin-1),v1t(1,imin), ldv1t ) end if end if if( wantv2t ) then if( colmajor ) then - call stdlib_wlasr( 'L', 'V', 'F', imax-imin+1, m-q,rwork(iv2tcs+imin-1), & + call stdlib_${ci}$lasr( 'L', 'V', 'F', imax-imin+1, m-q,rwork(iv2tcs+imin-1), & rwork(iv2tsn+imin-1),v2t(imin,1), ldv2t ) else - call stdlib_wlasr( 'R', 'V', 'F', m-q, imax-imin+1,rwork(iv2tcs+imin-1), & + call stdlib_${ci}$lasr( 'R', 'V', 'F', m-q, imax-imin+1,rwork(iv2tcs+imin-1), & rwork(iv2tsn+imin-1),v2t(1,imin), ldv2t ) end if end if @@ -1044,9 +1046,9 @@ module stdlib_linalg_lapack_w b21d(imax) = -b21d(imax) if( wantv1t ) then if( colmajor ) then - call stdlib_wscal( q, cnegone, v1t(imax,1), ldv1t ) + call stdlib_${ci}$scal( q, cnegone, v1t(imax,1), ldv1t ) else - call stdlib_wscal( q, cnegone, v1t(1,imax), 1 ) + call stdlib_${ci}$scal( q, cnegone, v1t(1,imax), 1 ) end if end if end if @@ -1060,9 +1062,9 @@ module stdlib_linalg_lapack_w b12d(imax) = -b12d(imax) if( wantu1 ) then if( colmajor ) then - call stdlib_wscal( p, cnegone, u1(1,imax), 1 ) + call stdlib_${ci}$scal( p, cnegone, u1(1,imax), 1 ) else - call stdlib_wscal( p, cnegone, u1(imax,1), ldu1 ) + call stdlib_${ci}$scal( p, cnegone, u1(imax,1), ldu1 ) end if end if end if @@ -1070,9 +1072,9 @@ module stdlib_linalg_lapack_w b22d(imax) = -b22d(imax) if( wantu2 ) then if( colmajor ) then - call stdlib_wscal( m-p, cnegone, u2(1,imax), 1 ) + call stdlib_${ci}$scal( m-p, cnegone, u2(1,imax), 1 ) else - call stdlib_wscal( m-p, cnegone, u2(imax,1), ldu2 ) + call stdlib_${ci}$scal( m-p, cnegone, u2(imax,1), ldu2 ) end if end if end if @@ -1080,9 +1082,9 @@ module stdlib_linalg_lapack_w if( b12d(imax)+b22d(imax) < 0 ) then if( wantv2t ) then if( colmajor ) then - call stdlib_wscal( m-q, cnegone, v2t(imax,1), ldv2t ) + call stdlib_${ci}$scal( m-q, cnegone, v2t(imax,1), ldv2t ) else - call stdlib_wscal( m-q, cnegone, v2t(1,imax), 1 ) + call stdlib_${ci}$scal( m-q, cnegone, v2t(1,imax), 1 ) end if end if end if @@ -1131,25 +1133,25 @@ module stdlib_linalg_lapack_w theta(mini) = theta(i) theta(i) = thetamin if( colmajor ) then - if( wantu1 )call stdlib_wswap( p, u1(1,i), 1, u1(1,mini), 1 ) - if( wantu2 )call stdlib_wswap( m-p, u2(1,i), 1, u2(1,mini), 1 ) - if( wantv1t )call stdlib_wswap( q, v1t(i,1), ldv1t, v1t(mini,1), ldv1t ) + if( wantu1 )call stdlib_${ci}$swap( p, u1(1,i), 1, u1(1,mini), 1 ) + if( wantu2 )call stdlib_${ci}$swap( m-p, u2(1,i), 1, u2(1,mini), 1 ) + if( wantv1t )call stdlib_${ci}$swap( q, v1t(i,1), ldv1t, v1t(mini,1), ldv1t ) - if( wantv2t )call stdlib_wswap( m-q, v2t(i,1), ldv2t, v2t(mini,1),ldv2t ) + if( wantv2t )call stdlib_${ci}$swap( m-q, v2t(i,1), ldv2t, v2t(mini,1),ldv2t ) else - if( wantu1 )call stdlib_wswap( p, u1(i,1), ldu1, u1(mini,1), ldu1 ) - if( wantu2 )call stdlib_wswap( m-p, u2(i,1), ldu2, u2(mini,1), ldu2 ) - if( wantv1t )call stdlib_wswap( q, v1t(1,i), 1, v1t(1,mini), 1 ) - if( wantv2t )call stdlib_wswap( m-q, v2t(1,i), 1, v2t(1,mini), 1 ) + if( wantu1 )call stdlib_${ci}$swap( p, u1(i,1), ldu1, u1(mini,1), ldu1 ) + if( wantu2 )call stdlib_${ci}$swap( m-p, u2(i,1), ldu2, u2(mini,1), ldu2 ) + if( wantv1t )call stdlib_${ci}$swap( q, v1t(1,i), 1, v1t(1,mini), 1 ) + if( wantv2t )call stdlib_${ci}$swap( m-q, v2t(1,i), 1, v2t(1,mini), 1 ) end if end if end do return - end subroutine stdlib_wbbcsd + end subroutine stdlib_${ci}$bbcsd - pure subroutine stdlib_wbdsqr( uplo, n, ncvt, nru, ncc, d, e, vt, ldvt, u,ldu, c, ldc, rwork,& + pure subroutine stdlib_${ci}$bdsqr( uplo, n, ncvt, nru, ncc, d, e, vt, ldvt, u,ldu, c, ldc, rwork,& !! ZBDSQR: computes the singular values and, optionally, the right and/or !! left singular vectors from the singular value decomposition (SVD) of !! a real N-by-N (upper or lower) bidiagonal matrix B using the implicit @@ -1183,14 +1185,14 @@ module stdlib_linalg_lapack_w integer(ilp), intent(out) :: info integer(ilp), intent(in) :: ldc, ldu, ldvt, n, ncc, ncvt, nru ! Array Arguments - real(qp), intent(inout) :: d(*), e(*) - real(qp), intent(out) :: rwork(*) - complex(qp), intent(inout) :: c(ldc,*), u(ldu,*), vt(ldvt,*) + real(${ck}$), intent(inout) :: d(*), e(*) + real(${ck}$), intent(out) :: rwork(*) + complex(${ck}$), intent(inout) :: c(ldc,*), u(ldu,*), vt(ldvt,*) ! ===================================================================== ! Parameters - real(qp), parameter :: hndrth = 0.01_qp - real(qp), parameter :: hndrd = 100.0_qp - real(qp), parameter :: meigth = -0.125_qp + real(${ck}$), parameter :: hndrth = 0.01_${ck}$ + real(${ck}$), parameter :: hndrd = 100.0_${ck}$ + real(${ck}$), parameter :: meigth = -0.125_${ck}$ integer(ilp), parameter :: maxitr = 6 @@ -1204,7 +1206,7 @@ module stdlib_linalg_lapack_w logical(lk) :: lower, rotate integer(ilp) :: i, idir, isub, iter, j, ll, lll, m, maxit, nm1, nm12, nm13, oldll, & oldm - real(qp) :: abse, abss, cosl, cosr, cs, eps, f, g, h, mu, oldcs, oldsn, r, shift, & + real(${ck}$) :: abse, abss, cosl, cosr, cs, eps, f, g, h, mu, oldcs, oldsn, r, shift, & sigmn, sigmx, sinl, sinr, sll, smax, smin, sminl, sminoa, sn, thresh, tol, tolmul, & unfl ! Intrinsic Functions @@ -1240,7 +1242,7 @@ module stdlib_linalg_lapack_w rotate = ( ncvt>0 ) .or. ( nru>0 ) .or. ( ncc>0 ) ! if no singular vectors desired, use qd algorithm if( .not.rotate ) then - call stdlib_qlasq1( n, d, e, rwork, info ) + call stdlib_${c2ri(ci)}$lasq1( n, d, e, rwork, info ) ! if info equals 2, dqds didn't finish, try to finish if( info /= 2 ) return info = 0 @@ -1250,13 +1252,13 @@ module stdlib_linalg_lapack_w nm13 = nm12 + nm1 idir = 0 ! get machine constants - eps = stdlib_qlamch( 'EPSILON' ) - unfl = stdlib_qlamch( 'SAFE MINIMUM' ) + eps = stdlib_${c2ri(ci)}$lamch( 'EPSILON' ) + unfl = stdlib_${c2ri(ci)}$lamch( 'SAFE MINIMUM' ) ! if matrix lower bidiagonal, rotate to be upper bidiagonal ! by applying givens rotations on the left if( lower ) then do i = 1, n - 1 - call stdlib_qlartg( d( i ), e( i ), cs, sn, r ) + call stdlib_${c2ri(ci)}$lartg( d( i ), e( i ), cs, sn, r ) d( i ) = r e( i ) = sn*d( i+1 ) d( i+1 ) = cs*d( i+1 ) @@ -1264,9 +1266,9 @@ module stdlib_linalg_lapack_w rwork( nm1+i ) = sn end do ! update singular vectors if desired - if( nru>0 )call stdlib_wlasr( 'R', 'V', 'F', nru, n, rwork( 1 ), rwork( n ),u, ldu ) + if( nru>0 )call stdlib_${ci}$lasr( 'R', 'V', 'F', nru, n, rwork( 1 ), rwork( n ),u, ldu ) - if( ncc>0 )call stdlib_wlasr( 'L', 'V', 'F', n, ncc, rwork( 1 ), rwork( n ),c, ldc ) + if( ncc>0 )call stdlib_${ci}$lasr( 'L', 'V', 'F', n, ncc, rwork( 1 ), rwork( n ),c, ldc ) end if ! compute singular values to relative accuracy tol @@ -1294,7 +1296,7 @@ module stdlib_linalg_lapack_w if( sminoa==zero )go to 50 end do 50 continue - sminoa = sminoa / sqrt( real( n,KIND=qp) ) + sminoa = sminoa / sqrt( real( n,KIND=${ck}$) ) thresh = max( tol*sminoa, maxitr*n*n*unfl ) else ! absolute accuracy desired @@ -1342,17 +1344,17 @@ module stdlib_linalg_lapack_w ! e(ll) through e(m-1) are nonzero, e(ll-1) is zero if( ll==m-1 ) then ! 2 by 2 block, handle separately - call stdlib_qlasv2( d( m-1 ), e( m-1 ), d( m ), sigmn, sigmx, sinr,cosr, sinl, cosl & + call stdlib_${c2ri(ci)}$lasv2( d( m-1 ), e( m-1 ), d( m ), sigmn, sigmx, sinr,cosr, sinl, cosl & ) d( m-1 ) = sigmx e( m-1 ) = zero d( m ) = sigmn ! compute singular vectors, if desired - if( ncvt>0 )call stdlib_wdrot( ncvt, vt( m-1, 1 ), ldvt, vt( m, 1 ), ldvt,cosr, & + if( ncvt>0 )call stdlib_${ci}$drot( ncvt, vt( m-1, 1 ), ldvt, vt( m, 1 ), ldvt,cosr, & sinr ) - if( nru>0 )call stdlib_wdrot( nru, u( 1, m-1 ), 1, u( 1, m ), 1, cosl, sinl ) + if( nru>0 )call stdlib_${ci}$drot( nru, u( 1, m-1 ), 1, u( 1, m ), 1, cosl, sinl ) - if( ncc>0 )call stdlib_wdrot( ncc, c( m-1, 1 ), ldc, c( m, 1 ), ldc, cosl,sinl ) + if( ncc>0 )call stdlib_${ci}$drot( ncc, c( m-1, 1 ), ldc, c( m, 1 ), ldc, cosl,sinl ) m = m - 2 go to 60 @@ -1425,10 +1427,10 @@ module stdlib_linalg_lapack_w ! compute the shift from 2-by-2 block at end of matrix if( idir==1 ) then sll = abs( d( ll ) ) - call stdlib_qlas2( d( m-1 ), e( m-1 ), d( m ), shift, r ) + call stdlib_${c2ri(ci)}$las2( d( m-1 ), e( m-1 ), d( m ), shift, r ) else sll = abs( d( m ) ) - call stdlib_qlas2( d( ll ), e( ll ), d( ll+1 ), shift, r ) + call stdlib_${c2ri(ci)}$las2( d( ll ), e( ll ), d( ll+1 ), shift, r ) end if ! test if shift negligible, and if so set to zero if( sll>zero ) then @@ -1445,9 +1447,9 @@ module stdlib_linalg_lapack_w cs = one oldcs = one do i = ll, m - 1 - call stdlib_qlartg( d( i )*cs, e( i ), cs, sn, r ) + call stdlib_${c2ri(ci)}$lartg( d( i )*cs, e( i ), cs, sn, r ) if( i>ll )e( i-1 ) = oldsn*r - call stdlib_qlartg( oldcs*r, d( i+1 )*sn, oldcs, oldsn, d( i ) ) + call stdlib_${c2ri(ci)}$lartg( oldcs*r, d( i+1 )*sn, oldcs, oldsn, d( i ) ) rwork( i-ll+1 ) = cs rwork( i-ll+1+nm1 ) = sn rwork( i-ll+1+nm12 ) = oldcs @@ -1457,11 +1459,11 @@ module stdlib_linalg_lapack_w d( m ) = h*oldcs e( m-1 ) = h*oldsn ! update singular vectors - if( ncvt>0 )call stdlib_wlasr( 'L', 'V', 'F', m-ll+1, ncvt, rwork( 1 ),rwork( n )& + if( ncvt>0 )call stdlib_${ci}$lasr( 'L', 'V', 'F', m-ll+1, ncvt, rwork( 1 ),rwork( n )& , vt( ll, 1 ), ldvt ) - if( nru>0 )call stdlib_wlasr( 'R', 'V', 'F', nru, m-ll+1, rwork( nm12+1 ),rwork( & + if( nru>0 )call stdlib_${ci}$lasr( 'R', 'V', 'F', nru, m-ll+1, rwork( nm12+1 ),rwork( & nm13+1 ), u( 1, ll ), ldu ) - if( ncc>0 )call stdlib_wlasr( 'L', 'V', 'F', m-ll+1, ncc, rwork( nm12+1 ),rwork( & + if( ncc>0 )call stdlib_${ci}$lasr( 'L', 'V', 'F', m-ll+1, ncc, rwork( nm12+1 ),rwork( & nm13+1 ), c( ll, 1 ), ldc ) ! test convergence if( abs( e( m-1 ) )<=thresh )e( m-1 ) = zero @@ -1471,9 +1473,9 @@ module stdlib_linalg_lapack_w cs = one oldcs = one do i = m, ll + 1, -1 - call stdlib_qlartg( d( i )*cs, e( i-1 ), cs, sn, r ) + call stdlib_${c2ri(ci)}$lartg( d( i )*cs, e( i-1 ), cs, sn, r ) if( i0 )call stdlib_wlasr( 'L', 'V', 'B', m-ll+1, ncvt, rwork( nm12+1 ),& + if( ncvt>0 )call stdlib_${ci}$lasr( 'L', 'V', 'B', m-ll+1, ncvt, rwork( nm12+1 ),& rwork( nm13+1 ), vt( ll, 1 ), ldvt ) - if( nru>0 )call stdlib_wlasr( 'R', 'V', 'B', nru, m-ll+1, rwork( 1 ),rwork( n ), & + if( nru>0 )call stdlib_${ci}$lasr( 'R', 'V', 'B', nru, m-ll+1, rwork( 1 ),rwork( n ), & u( 1, ll ), ldu ) - if( ncc>0 )call stdlib_wlasr( 'L', 'V', 'B', m-ll+1, ncc, rwork( 1 ),rwork( n ), & + if( ncc>0 )call stdlib_${ci}$lasr( 'L', 'V', 'B', m-ll+1, ncc, rwork( 1 ),rwork( n ), & c( ll, 1 ), ldc ) ! test convergence if( abs( e( ll ) )<=thresh )e( ll ) = zero @@ -1500,13 +1502,13 @@ module stdlib_linalg_lapack_w f = ( abs( d( ll ) )-shift )*( sign( one, d( ll ) )+shift / d( ll ) ) g = e( ll ) do i = ll, m - 1 - call stdlib_qlartg( f, g, cosr, sinr, r ) + call stdlib_${c2ri(ci)}$lartg( f, g, cosr, sinr, r ) if( i>ll )e( i-1 ) = r f = cosr*d( i ) + sinr*e( i ) e( i ) = cosr*e( i ) - sinr*d( i ) g = sinr*d( i+1 ) d( i+1 ) = cosr*d( i+1 ) - call stdlib_qlartg( f, g, cosl, sinl, r ) + call stdlib_${c2ri(ci)}$lartg( f, g, cosl, sinl, r ) d( i ) = r f = cosl*e( i ) + sinl*d( i+1 ) d( i+1 ) = cosl*d( i+1 ) - sinl*e( i ) @@ -1521,11 +1523,11 @@ module stdlib_linalg_lapack_w end do e( m-1 ) = f ! update singular vectors - if( ncvt>0 )call stdlib_wlasr( 'L', 'V', 'F', m-ll+1, ncvt, rwork( 1 ),rwork( n )& + if( ncvt>0 )call stdlib_${ci}$lasr( 'L', 'V', 'F', m-ll+1, ncvt, rwork( 1 ),rwork( n )& , vt( ll, 1 ), ldvt ) - if( nru>0 )call stdlib_wlasr( 'R', 'V', 'F', nru, m-ll+1, rwork( nm12+1 ),rwork( & + if( nru>0 )call stdlib_${ci}$lasr( 'R', 'V', 'F', nru, m-ll+1, rwork( nm12+1 ),rwork( & nm13+1 ), u( 1, ll ), ldu ) - if( ncc>0 )call stdlib_wlasr( 'L', 'V', 'F', m-ll+1, ncc, rwork( nm12+1 ),rwork( & + if( ncc>0 )call stdlib_${ci}$lasr( 'L', 'V', 'F', m-ll+1, ncc, rwork( nm12+1 ),rwork( & nm13+1 ), c( ll, 1 ), ldc ) ! test convergence if( abs( e( m-1 ) )<=thresh )e( m-1 ) = zero @@ -1535,13 +1537,13 @@ module stdlib_linalg_lapack_w f = ( abs( d( m ) )-shift )*( sign( one, d( m ) )+shift /d( m ) ) g = e( m-1 ) do i = m, ll + 1, -1 - call stdlib_qlartg( f, g, cosr, sinr, r ) + call stdlib_${c2ri(ci)}$lartg( f, g, cosr, sinr, r ) if( i0 )call stdlib_wlasr( 'L', 'V', 'B', m-ll+1, ncvt, rwork( nm12+1 ),& + if( ncvt>0 )call stdlib_${ci}$lasr( 'L', 'V', 'B', m-ll+1, ncvt, rwork( nm12+1 ),& rwork( nm13+1 ), vt( ll, 1 ), ldvt ) - if( nru>0 )call stdlib_wlasr( 'R', 'V', 'B', nru, m-ll+1, rwork( 1 ),rwork( n ), & + if( nru>0 )call stdlib_${ci}$lasr( 'R', 'V', 'B', nru, m-ll+1, rwork( 1 ),rwork( n ), & u( 1, ll ), ldu ) - if( ncc>0 )call stdlib_wlasr( 'L', 'V', 'B', m-ll+1, ncc, rwork( 1 ),rwork( n ), & + if( ncc>0 )call stdlib_${ci}$lasr( 'L', 'V', 'B', m-ll+1, ncc, rwork( 1 ),rwork( n ), & c( ll, 1 ), ldc ) end if end if @@ -1574,7 +1576,7 @@ module stdlib_linalg_lapack_w if( d( i )0 )call stdlib_wdscal( ncvt, negone, vt( i, 1 ), ldvt ) + if( ncvt>0 )call stdlib_${ci}$dscal( ncvt, negone, vt( i, 1 ), ldvt ) end if end do ! sort the singular values into decreasing order (insertion sort on @@ -1593,10 +1595,10 @@ module stdlib_linalg_lapack_w ! swap singular values and vectors d( isub ) = d( n+1-i ) d( n+1-i ) = smin - if( ncvt>0 )call stdlib_wswap( ncvt, vt( isub, 1 ), ldvt, vt( n+1-i, 1 ),ldvt ) + if( ncvt>0 )call stdlib_${ci}$swap( ncvt, vt( isub, 1 ), ldvt, vt( n+1-i, 1 ),ldvt ) - if( nru>0 )call stdlib_wswap( nru, u( 1, isub ), 1, u( 1, n+1-i ), 1 ) - if( ncc>0 )call stdlib_wswap( ncc, c( isub, 1 ), ldc, c( n+1-i, 1 ), ldc ) + if( nru>0 )call stdlib_${ci}$swap( nru, u( 1, isub ), 1, u( 1, n+1-i ), 1 ) + if( ncc>0 )call stdlib_${ci}$swap( ncc, c( isub, 1 ), ldc, c( n+1-i, 1 ), ldc ) end if end do @@ -1609,10 +1611,10 @@ module stdlib_linalg_lapack_w end do 220 continue return - end subroutine stdlib_wbdsqr + end subroutine stdlib_${ci}$bdsqr - subroutine stdlib_wcgesv( n, nrhs, a, lda, ipiv, b, ldb, x, ldx, work,swork, rwork, iter, & + subroutine stdlib_${ci}$cgesv( n, nrhs, a, lda, ipiv, b, ldb, x, ldx, work,swork, rwork, iter, & !! ZCGESV: computes the solution to a complex system of linear equations !! A * X = B, !! where A is an N-by-N matrix and X and B are N-by-NRHS matrices. @@ -1649,30 +1651,30 @@ module stdlib_linalg_lapack_w integer(ilp), intent(in) :: lda, ldb, ldx, n, nrhs ! Array Arguments integer(ilp), intent(out) :: ipiv(*) - real(qp), intent(out) :: rwork(*) + real(${ck}$), intent(out) :: rwork(*) complex(dp), intent(out) :: swork(*) - complex(qp), intent(inout) :: a(lda,*) - complex(qp), intent(in) :: b(ldb,*) - complex(qp), intent(out) :: work(n,*), x(ldx,*) + complex(${ck}$), intent(inout) :: a(lda,*) + complex(${ck}$), intent(in) :: b(ldb,*) + complex(${ck}$), intent(out) :: work(n,*), x(ldx,*) ! ===================================================================== ! Parameters logical(lk), parameter :: doitref = .true. integer(ilp), parameter :: itermax = 30 - real(qp), parameter :: bwdmax = 1.0e+00_qp + real(${ck}$), parameter :: bwdmax = 1.0e+00_${ck}$ ! Local Scalars integer(ilp) :: i, iiter, ptsa, ptsx - real(qp) :: anrm, cte, eps, rnrm, xnrm - complex(qp) :: zdum + real(${ck}$) :: anrm, cte, eps, rnrm, xnrm + complex(${ck}$) :: zdum ! Intrinsic Functions intrinsic :: abs,real,max,sqrt ! Statement Functions - real(qp) :: cabs1 + real(${ck}$) :: cabs1 ! Statement Function Definitions - cabs1( zdum ) = abs( real( zdum,KIND=qp) ) + abs( aimag( zdum ) ) + cabs1( zdum ) = abs( real( zdum,KIND=${ck}$) ) + abs( aimag( zdum ) ) ! Executable Statements info = 0 iter = 0 @@ -1701,22 +1703,22 @@ module stdlib_linalg_lapack_w go to 40 end if ! compute some constants. - anrm = stdlib_wlange( 'I', n, n, a, lda, rwork ) - eps = stdlib_qlamch( 'EPSILON' ) - cte = anrm*eps*sqrt( real( n,KIND=qp) )*bwdmax + anrm = stdlib_${ci}$lange( 'I', n, n, a, lda, rwork ) + eps = stdlib_${c2ri(ci)}$lamch( 'EPSILON' ) + cte = anrm*eps*sqrt( real( n,KIND=${ck}$) )*bwdmax ! set the indices ptsa, ptsx for referencing sa and sx in swork. ptsa = 1 ptsx = ptsa + n*n ! convert b from quad precision to double precision and store the ! result in sx. - call stdlib_wlag2c( n, nrhs, b, ldb, swork( ptsx ), n, info ) + call stdlib_${ci}$lag2c( n, nrhs, b, ldb, swork( ptsx ), n, info ) if( info/=0 ) then iter = -2 go to 40 end if ! convert a from quad precision to double precision and store the ! result in sa. - call stdlib_wlag2c( n, n, a, lda, swork( ptsa ), n, info ) + call stdlib_${ci}$lag2c( n, n, a, lda, swork( ptsa ), n, info ) if( info/=0 ) then iter = -2 go to 40 @@ -1731,16 +1733,16 @@ module stdlib_linalg_lapack_w call stdlib_zgetrs( 'NO TRANSPOSE', n, nrhs, swork( ptsa ), n, ipiv,swork( ptsx ), n, & info ) ! convert sx back to quad precision - call stdlib_zlag2w( n, nrhs, swork( ptsx ), n, x, ldx, info ) + call stdlib_${ci}$lag2w( n, nrhs, swork( ptsx ), n, x, ldx, info ) ! compute r = b - ax (r is work). - call stdlib_wlacpy( 'ALL', n, nrhs, b, ldb, work, n ) - call stdlib_wgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', n, nrhs, n, cnegone, a,lda, x, ldx, & + call stdlib_${ci}$lacpy( 'ALL', n, nrhs, b, ldb, work, n ) + call stdlib_${ci}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', n, nrhs, n, cnegone, a,lda, x, ldx, & cone, work, n ) ! check whether the nrhs normwise backward errors satisfy the ! stopping criterion. if yes, set iter=0 and return. do i = 1, nrhs - xnrm = cabs1( x( stdlib_iwamax( n, x( 1, i ), 1 ), i ) ) - rnrm = cabs1( work( stdlib_iwamax( n, work( 1, i ), 1 ), i ) ) + xnrm = cabs1( x( stdlib_i${ci}$amax( n, x( 1, i ), 1 ), i ) ) + rnrm = cabs1( work( stdlib_i${ci}$amax( n, work( 1, i ), 1 ), i ) ) if( rnrm>xnrm*cte )go to 10 end do ! if we are here, the nrhs normwise backward errors satisfy the @@ -1751,7 +1753,7 @@ module stdlib_linalg_lapack_w loop_30: do iiter = 1, itermax ! convert r (in work) from quad precision to double precision ! and store the result in sx. - call stdlib_wlag2c( n, nrhs, work, n, swork( ptsx ), n, info ) + call stdlib_${ci}$lag2c( n, nrhs, work, n, swork( ptsx ), n, info ) if( info/=0 ) then iter = -2 go to 40 @@ -1761,19 +1763,19 @@ module stdlib_linalg_lapack_w n, info ) ! convert sx back to quad precision and update the current ! iterate. - call stdlib_zlag2w( n, nrhs, swork( ptsx ), n, work, n, info ) + call stdlib_${ci}$lag2w( n, nrhs, swork( ptsx ), n, work, n, info ) do i = 1, nrhs - call stdlib_waxpy( n, cone, work( 1, i ), 1, x( 1, i ), 1 ) + call stdlib_${ci}$axpy( n, cone, work( 1, i ), 1, x( 1, i ), 1 ) end do ! compute r = b - ax (r is work). - call stdlib_wlacpy( 'ALL', n, nrhs, b, ldb, work, n ) - call stdlib_wgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', n, nrhs, n, cnegone,a, lda, x, & + call stdlib_${ci}$lacpy( 'ALL', n, nrhs, b, ldb, work, n ) + call stdlib_${ci}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', n, nrhs, n, cnegone,a, lda, x, & ldx, cone, work, n ) ! check whether the nrhs normwise backward errors satisfy the ! stopping criterion. if yes, set iter=iiter>0 and return. do i = 1, nrhs - xnrm = cabs1( x( stdlib_iwamax( n, x( 1, i ), 1 ), i ) ) - rnrm = cabs1( work( stdlib_iwamax( n, work( 1, i ), 1 ), i ) ) + xnrm = cabs1( x( stdlib_i${ci}$amax( n, x( 1, i ), 1 ), i ) ) + rnrm = cabs1( work( stdlib_i${ci}$amax( n, work( 1, i ), 1 ), i ) ) if( rnrm>xnrm*cte )go to 20 end do ! if we are here, the nrhs normwise backward errors satisfy the @@ -1790,15 +1792,15 @@ module stdlib_linalg_lapack_w 40 continue ! single-precision iterative refinement failed to converge to a ! satisfactory solution, so we resort to quad precision. - call stdlib_wgetrf( n, n, a, lda, ipiv, info ) + call stdlib_${ci}$getrf( n, n, a, lda, ipiv, info ) if( info/=0 )return - call stdlib_wlacpy( 'ALL', n, nrhs, b, ldb, x, ldx ) - call stdlib_wgetrs( 'NO TRANSPOSE', n, nrhs, a, lda, ipiv, x, ldx,info ) + call stdlib_${ci}$lacpy( 'ALL', n, nrhs, b, ldb, x, ldx ) + call stdlib_${ci}$getrs( 'NO TRANSPOSE', n, nrhs, a, lda, ipiv, x, ldx,info ) return - end subroutine stdlib_wcgesv + end subroutine stdlib_${ci}$cgesv - subroutine stdlib_wcposv( uplo, n, nrhs, a, lda, b, ldb, x, ldx, work,swork, rwork, iter, & + subroutine stdlib_${ci}$cposv( uplo, n, nrhs, a, lda, b, ldb, x, ldx, work,swork, rwork, iter, & !! ZCPOSV: computes the solution to a complex system of linear equations !! A * X = B, !! where A is an N-by-N Hermitian positive definite matrix and X and B @@ -1836,30 +1838,30 @@ module stdlib_linalg_lapack_w integer(ilp), intent(out) :: info, iter integer(ilp), intent(in) :: lda, ldb, ldx, n, nrhs ! Array Arguments - real(qp), intent(out) :: rwork(*) + real(${ck}$), intent(out) :: rwork(*) complex(dp), intent(out) :: swork(*) - complex(qp), intent(inout) :: a(lda,*) - complex(qp), intent(in) :: b(ldb,*) - complex(qp), intent(out) :: work(n,*), x(ldx,*) + complex(${ck}$), intent(inout) :: a(lda,*) + complex(${ck}$), intent(in) :: b(ldb,*) + complex(${ck}$), intent(out) :: work(n,*), x(ldx,*) ! ===================================================================== ! Parameters logical(lk), parameter :: doitref = .true. integer(ilp), parameter :: itermax = 30 - real(qp), parameter :: bwdmax = 1.0e+00_qp + real(${ck}$), parameter :: bwdmax = 1.0e+00_${ck}$ ! Local Scalars integer(ilp) :: i, iiter, ptsa, ptsx - real(qp) :: anrm, cte, eps, rnrm, xnrm - complex(qp) :: zdum + real(${ck}$) :: anrm, cte, eps, rnrm, xnrm + complex(${ck}$) :: zdum ! Intrinsic Functions intrinsic :: abs,real,max,sqrt ! Statement Functions - real(qp) :: cabs1 + real(${ck}$) :: cabs1 ! Statement Function Definitions - cabs1( zdum ) = abs( real( zdum,KIND=qp) ) + abs( aimag( zdum ) ) + cabs1( zdum ) = abs( real( zdum,KIND=${ck}$) ) + abs( aimag( zdum ) ) ! Executable Statements info = 0 iter = 0 @@ -1890,22 +1892,22 @@ module stdlib_linalg_lapack_w go to 40 end if ! compute some constants. - anrm = stdlib_wlanhe( 'I', uplo, n, a, lda, rwork ) - eps = stdlib_qlamch( 'EPSILON' ) - cte = anrm*eps*sqrt( real( n,KIND=qp) )*bwdmax + anrm = stdlib_${ci}$lanhe( 'I', uplo, n, a, lda, rwork ) + eps = stdlib_${c2ri(ci)}$lamch( 'EPSILON' ) + cte = anrm*eps*sqrt( real( n,KIND=${ck}$) )*bwdmax ! set the indices ptsa, ptsx for referencing sa and sx in swork. ptsa = 1 ptsx = ptsa + n*n ! convert b from quad precision to double precision and store the ! result in sx. - call stdlib_wlag2c( n, nrhs, b, ldb, swork( ptsx ), n, info ) + call stdlib_${ci}$lag2c( n, nrhs, b, ldb, swork( ptsx ), n, info ) if( info/=0 ) then iter = -2 go to 40 end if ! convert a from quad precision to double precision and store the ! result in sa. - call stdlib_wlat2c( uplo, n, a, lda, swork( ptsa ), n, info ) + call stdlib_${ci}$lat2c( uplo, n, a, lda, swork( ptsa ), n, info ) if( info/=0 ) then iter = -2 go to 40 @@ -1919,16 +1921,16 @@ module stdlib_linalg_lapack_w ! solve the system sa*sx = sb. call stdlib_zpotrs( uplo, n, nrhs, swork( ptsa ), n, swork( ptsx ), n,info ) ! convert sx back to complex*16 - call stdlib_zlag2w( n, nrhs, swork( ptsx ), n, x, ldx, info ) + call stdlib_${ci}$lag2w( n, nrhs, swork( ptsx ), n, x, ldx, info ) ! compute r = b - ax (r is work). - call stdlib_wlacpy( 'ALL', n, nrhs, b, ldb, work, n ) - call stdlib_whemm( 'LEFT', uplo, n, nrhs, cnegone, a, lda, x, ldx, cone,work, n ) + call stdlib_${ci}$lacpy( 'ALL', n, nrhs, b, ldb, work, n ) + call stdlib_${ci}$hemm( 'LEFT', uplo, n, nrhs, cnegone, a, lda, x, ldx, cone,work, n ) ! check whether the nrhs normwise backward errors satisfy the ! stopping criterion. if yes, set iter=0 and return. do i = 1, nrhs - xnrm = cabs1( x( stdlib_iwamax( n, x( 1, i ), 1 ), i ) ) - rnrm = cabs1( work( stdlib_iwamax( n, work( 1, i ), 1 ), i ) ) + xnrm = cabs1( x( stdlib_i${ci}$amax( n, x( 1, i ), 1 ), i ) ) + rnrm = cabs1( work( stdlib_i${ci}$amax( n, work( 1, i ), 1 ), i ) ) if( rnrm>xnrm*cte )go to 10 end do ! if we are here, the nrhs normwise backward errors satisfy the @@ -1939,7 +1941,7 @@ module stdlib_linalg_lapack_w loop_30: do iiter = 1, itermax ! convert r (in work) from quad precision to double precision ! and store the result in sx. - call stdlib_wlag2c( n, nrhs, work, n, swork( ptsx ), n, info ) + call stdlib_${ci}$lag2c( n, nrhs, work, n, swork( ptsx ), n, info ) if( info/=0 ) then iter = -2 go to 40 @@ -1948,19 +1950,19 @@ module stdlib_linalg_lapack_w call stdlib_zpotrs( uplo, n, nrhs, swork( ptsa ), n, swork( ptsx ), n,info ) ! convert sx back to quad precision and update the current ! iterate. - call stdlib_zlag2w( n, nrhs, swork( ptsx ), n, work, n, info ) + call stdlib_${ci}$lag2w( n, nrhs, swork( ptsx ), n, work, n, info ) do i = 1, nrhs - call stdlib_waxpy( n, cone, work( 1, i ), 1, x( 1, i ), 1 ) + call stdlib_${ci}$axpy( n, cone, work( 1, i ), 1, x( 1, i ), 1 ) end do ! compute r = b - ax (r is work). - call stdlib_wlacpy( 'ALL', n, nrhs, b, ldb, work, n ) - call stdlib_whemm( 'L', uplo, n, nrhs, cnegone, a, lda, x, ldx, cone,work, n ) + call stdlib_${ci}$lacpy( 'ALL', n, nrhs, b, ldb, work, n ) + call stdlib_${ci}$hemm( 'L', uplo, n, nrhs, cnegone, a, lda, x, ldx, cone,work, n ) ! check whether the nrhs normwise backward errors satisfy the ! stopping criterion. if yes, set iter=iiter>0 and return. do i = 1, nrhs - xnrm = cabs1( x( stdlib_iwamax( n, x( 1, i ), 1 ), i ) ) - rnrm = cabs1( work( stdlib_iwamax( n, work( 1, i ), 1 ), i ) ) + xnrm = cabs1( x( stdlib_i${ci}$amax( n, x( 1, i ), 1 ), i ) ) + rnrm = cabs1( work( stdlib_i${ci}$amax( n, work( 1, i ), 1 ), i ) ) if( rnrm>xnrm*cte )go to 20 end do ! if we are here, the nrhs normwise backward errors satisfy the @@ -1977,15 +1979,15 @@ module stdlib_linalg_lapack_w 40 continue ! single-precision iterative refinement failed to converge to a ! satisfactory solution, so we resort to quad precision. - call stdlib_wpotrf( uplo, n, a, lda, info ) + call stdlib_${ci}$potrf( uplo, n, a, lda, info ) if( info/=0 )return - call stdlib_wlacpy( 'ALL', n, nrhs, b, ldb, x, ldx ) - call stdlib_wpotrs( uplo, n, nrhs, a, lda, x, ldx, info ) + call stdlib_${ci}$lacpy( 'ALL', n, nrhs, b, ldb, x, ldx ) + call stdlib_${ci}$potrs( uplo, n, nrhs, a, lda, x, ldx, info ) return - end subroutine stdlib_wcposv + end subroutine stdlib_${ci}$cposv - pure subroutine stdlib_wdrscl( n, sa, sx, incx ) + pure subroutine stdlib_${ci}$drscl( n, sa, sx, incx ) !! ZDRSCL: multiplies an n-element complex vector x by the real scalar !! 1/a. This is done without overflow or underflow as long as !! the final result x/a does not overflow or underflow. @@ -1994,23 +1996,23 @@ module stdlib_linalg_lapack_w ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments integer(ilp), intent(in) :: incx, n - real(qp), intent(in) :: sa + real(${ck}$), intent(in) :: sa ! Array Arguments - complex(qp), intent(inout) :: sx(*) + complex(${ck}$), intent(inout) :: sx(*) ! ===================================================================== ! Local Scalars logical(lk) :: done - real(qp) :: bignum, cden, cden1, cnum, cnum1, mul, smlnum + real(${ck}$) :: bignum, cden, cden1, cnum, cnum1, mul, smlnum ! Intrinsic Functions intrinsic :: abs ! Executable Statements ! quick return if possible if( n<=0 )return ! get machine parameters - smlnum = stdlib_qlamch( 'S' ) + smlnum = stdlib_${c2ri(ci)}$lamch( 'S' ) bignum = one / smlnum - call stdlib_qlabad( smlnum, bignum ) + call stdlib_${c2ri(ci)}$labad( smlnum, bignum ) ! initialize the denominator to sa and the numerator to 1. cden = sa cnum = one @@ -2033,13 +2035,13 @@ module stdlib_linalg_lapack_w done = .true. end if ! scale the vector x by mul - call stdlib_wdscal( n, mul, sx, incx ) + call stdlib_${ci}$dscal( n, mul, sx, incx ) if( .not.done )go to 10 return - end subroutine stdlib_wdrscl + end subroutine stdlib_${ci}$drscl - pure subroutine stdlib_wgbbrd( vect, m, n, ncc, kl, ku, ab, ldab, d, e, q,ldq, pt, ldpt, c, & + pure subroutine stdlib_${ci}$gbbrd( vect, m, n, ncc, kl, ku, ab, ldab, d, e, q,ldq, pt, ldpt, c, & !! ZGBBRD: reduces a complex general m-by-n band matrix A to real upper !! bidiagonal form B by a unitary transformation: Q**H * A * P = B. !! The routine computes B, and optionally forms Q or P**H, or computes @@ -2053,9 +2055,9 @@ module stdlib_linalg_lapack_w integer(ilp), intent(out) :: info integer(ilp), intent(in) :: kl, ku, ldab, ldc, ldpt, ldq, m, n, ncc ! Array Arguments - real(qp), intent(out) :: d(*), e(*), rwork(*) - complex(qp), intent(inout) :: ab(ldab,*), c(ldc,*) - complex(qp), intent(out) :: pt(ldpt,*), q(ldq,*), work(*) + real(${ck}$), intent(out) :: d(*), e(*), rwork(*) + complex(${ck}$), intent(inout) :: ab(ldab,*), c(ldc,*) + complex(${ck}$), intent(out) :: pt(ldpt,*), q(ldq,*), work(*) ! ===================================================================== @@ -2063,8 +2065,8 @@ module stdlib_linalg_lapack_w logical(lk) :: wantb, wantc, wantpt, wantq integer(ilp) :: i, inca, j, j1, j2, kb, kb1, kk, klm, klu1, kun, l, minmn, ml, ml0, mu,& mu0, nr, nrt - real(qp) :: abst, rc - complex(qp) :: ra, rb, rs, t + real(${ck}$) :: abst, rc + complex(${ck}$) :: ra, rb, rs, t ! Intrinsic Functions intrinsic :: abs,conjg,max,min ! Executable Statements @@ -2101,8 +2103,8 @@ module stdlib_linalg_lapack_w return end if ! initialize q and p**h to the unit matrix, if needed - if( wantq )call stdlib_wlaset( 'FULL', m, m, czero, cone, q, ldq ) - if( wantpt )call stdlib_wlaset( 'FULL', n, n, czero, cone, pt, ldpt ) + if( wantq )call stdlib_${ci}$laset( 'FULL', m, m, czero, cone, q, ldq ) + if( wantpt )call stdlib_${ci}$laset( 'FULL', n, n, czero, cone, pt, ldpt ) ! quick return if possible. if( m==0 .or. n==0 )return minmn = min( m, n ) @@ -2138,7 +2140,7 @@ module stdlib_linalg_lapack_w j2 = j2 + kb ! generate plane rotations to annihilate nonzero elements ! which have been created below the band - if( nr>0 )call stdlib_wlargv( nr, ab( klu1, j1-klm-1 ), inca,work( j1 ), kb1, & + if( nr>0 )call stdlib_${ci}$largv( nr, ab( klu1, j1-klm-1 ), inca,work( j1 ), kb1, & rwork( j1 ), kb1 ) ! apply plane rotations from the left do l = 1, kb @@ -2147,17 +2149,17 @@ module stdlib_linalg_lapack_w else nrt = nr end if - if( nrt>0 )call stdlib_wlartv( nrt, ab( klu1-l, j1-klm+l-1 ), inca,ab( & + if( nrt>0 )call stdlib_${ci}$lartv( nrt, ab( klu1-l, j1-klm+l-1 ), inca,ab( & klu1-l+1, j1-klm+l-1 ), inca,rwork( j1 ), work( j1 ), kb1 ) end do if( ml>ml0 ) then if( ml<=m-i+1 ) then ! generate plane rotation to annihilate a(i+ml-1,i) ! within the band, and apply rotation from the left - call stdlib_wlartg( ab( ku+ml-1, i ), ab( ku+ml, i ),rwork( i+ml-1 ), & + call stdlib_${ci}$lartg( ab( ku+ml-1, i ), ab( ku+ml, i ),rwork( i+ml-1 ), & work( i+ml-1 ), ra ) ab( ku+ml-1, i ) = ra - if( i0 )call stdlib_wlargv( nr, ab( 1, j1+kun-1 ), inca,work( j1+kun ), kb1,& + if( nr>0 )call stdlib_${ci}$largv( nr, ab( 1, j1+kun-1 ), inca,work( j1+kun ), kb1,& rwork( j1+kun ),kb1 ) ! apply plane rotations from the right do l = 1, kb @@ -2199,17 +2201,17 @@ module stdlib_linalg_lapack_w else nrt = nr end if - if( nrt>0 )call stdlib_wlartv( nrt, ab( l+1, j1+kun-1 ), inca,ab( l, j1+& + if( nrt>0 )call stdlib_${ci}$lartv( nrt, ab( l+1, j1+kun-1 ), inca,ab( l, j1+& kun ), inca,rwork( j1+kun ), work( j1+kun ), kb1 ) end do if( ml==ml0 .and. mu>mu0 ) then if( mu<=n-i+1 ) then ! generate plane rotation to annihilate a(i,i+mu-1) ! within the band, and apply rotation from the right - call stdlib_wlartg( ab( ku-mu+3, i+mu-2 ),ab( ku-mu+2, i+mu-1 ),rwork( & + call stdlib_${ci}$lartg( ab( ku-mu+3, i+mu-2 ),ab( ku-mu+2, i+mu-1 ),rwork( & i+mu-1 ), work( i+mu-1 ), ra ) ab( ku-mu+3, i+mu-2 ) = ra - call stdlib_wrot( min( kl+mu-2, m-i ),ab( ku-mu+4, i+mu-2 ), 1,ab( ku-& + call stdlib_${ci}$rot( min( kl+mu-2, m-i ),ab( ku-mu+4, i+mu-2 ), 1,ab( ku-& mu+3, i+mu-1 ), 1,rwork( i+mu-1 ), work( i+mu-1 ) ) end if nr = nr + 1 @@ -2218,7 +2220,7 @@ module stdlib_linalg_lapack_w if( wantpt ) then ! accumulate product of plane rotations in p**h do j = j1, j2, kb1 - call stdlib_wrot( n, pt( j+kun-1, 1 ), ldpt,pt( j+kun, 1 ), ldpt, rwork(& + call stdlib_${ci}$rot( n, pt( j+kun-1, 1 ), ldpt,pt( j+kun, 1 ), ldpt, rwork(& j+kun ),conjg( work( j+kun ) ) ) end do end if @@ -2247,15 +2249,15 @@ module stdlib_linalg_lapack_w ! plane rotations from the left, overwriting superdiagonal ! elements on subdiagonal elements do i = 1, min( m-1, n ) - call stdlib_wlartg( ab( 1, i ), ab( 2, i ), rc, rs, ra ) + call stdlib_${ci}$lartg( ab( 1, i ), ab( 2, i ), rc, rs, ra ) ab( 1, i ) = ra if( i1 ) then rb = -conjg( rs )*ab( ku, i ) ab( ku, i ) = rc*ab( ku, i ) end if - if( wantpt )call stdlib_wrot( n, pt( i, 1 ), ldpt, pt( m+1, 1 ), ldpt,rc, & + if( wantpt )call stdlib_${ci}$rot( n, pt( i, 1 ), ldpt, pt( m+1, 1 ), ldpt,rc, & conjg( rs ) ) end do end if @@ -2288,8 +2290,8 @@ module stdlib_linalg_lapack_w else t = cone end if - if( wantq )call stdlib_wscal( m, t, q( 1, i ), 1 ) - if( wantc )call stdlib_wscal( ncc, conjg( t ), c( i, 1 ), ldc ) + if( wantq )call stdlib_${ci}$scal( m, t, q( 1, i ), 1 ) + if( wantc )call stdlib_${ci}$scal( ncc, conjg( t ), c( i, 1 ), ldc ) if( i0 kase = 0 10 continue - call stdlib_wlacn2( n, work( n+1 ), work, ainvnm, kase, isave ) + call stdlib_${ci}$lacn2( n, work( n+1 ), work, ainvnm, kase, isave ) if( kase/=0 ) then if( kase==kase1 ) then ! multiply by inv(l). @@ -2409,21 +2411,21 @@ module stdlib_linalg_lapack_w work( jp ) = work( j ) work( j ) = t end if - call stdlib_waxpy( lm, -t, ab( kd+1, j ), 1, work( j+1 ), 1 ) + call stdlib_${ci}$axpy( lm, -t, ab( kd+1, j ), 1, work( j+1 ), 1 ) end do end if ! multiply by inv(u). - call stdlib_wlatbs( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', normin, n,kl+ku, ab, & + call stdlib_${ci}$latbs( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', normin, n,kl+ku, ab, & ldab, work, scale, rwork, info ) else ! multiply by inv(u**h). - call stdlib_wlatbs( 'UPPER', 'CONJUGATE TRANSPOSE', 'NON-UNIT',normin, n, kl+ku, & + call stdlib_${ci}$latbs( 'UPPER', 'CONJUGATE TRANSPOSE', 'NON-UNIT',normin, n, kl+ku, & ab, ldab, work, scale, rwork,info ) ! multiply by inv(l**h). if( lnoti ) then do j = n - 1, 1, -1 lm = min( kl, n-j ) - work( j ) = work( j ) - stdlib_wdotc( lm, ab( kd+1, j ), 1,work( j+1 ), 1 ) + work( j ) = work( j ) - stdlib_${ci}$dotc( lm, ab( kd+1, j ), 1,work( j+1 ), 1 ) jp = ipiv( j ) if( jp/=j ) then @@ -2437,9 +2439,9 @@ module stdlib_linalg_lapack_w ! divide x by 1/scale if doing so will not cause overflow. normin = 'Y' if( scale/=one ) then - ix = stdlib_iwamax( n, work, 1 ) + ix = stdlib_i${ci}$amax( n, work, 1 ) if( scaleeps .and. two*berr( j )<=lstres .and.count<=itmax ) then ! update solution and try again. - call stdlib_wgbtrs( trans, n, kl, ku, 1, afb, ldafb, ipiv, work, n,info ) - call stdlib_waxpy( n, cone, work, 1, x( 1, j ), 1 ) + call stdlib_${ci}$gbtrs( trans, n, kl, ku, 1, afb, ldafb, ipiv, work, n,info ) + call stdlib_${ci}$axpy( n, cone, work, 1, x( 1, j ), 1 ) lstres = berr( j ) count = count + 1 go to 20 @@ -2899,7 +2901,7 @@ module stdlib_linalg_lapack_w ! the i-th component of abs(r)+nz*eps*(abs(op(a))*abs(x)+abs(b)) ! is incremented by safe1 if the i-th component of ! abs(op(a))*abs(x) + abs(b) is less than safe2. - ! use stdlib_wlacn2 to estimate the infinity-norm of the matrix + ! use stdlib_${ci}$lacn2 to estimate the infinity-norm of the matrix ! inv(op(a)) * diag(w), ! where w = abs(r) + nz*eps*( abs(op(a))*abs(x)+abs(b) ))) do i = 1, n @@ -2911,11 +2913,11 @@ module stdlib_linalg_lapack_w end do kase = 0 100 continue - call stdlib_wlacn2( n, work( n+1 ), work, ferr( j ), kase, isave ) + call stdlib_${ci}$lacn2( n, work( n+1 ), work, ferr( j ), kase, isave ) if( kase/=0 ) then if( kase==1 ) then ! multiply by diag(w)*inv(op(a)**h). - call stdlib_wgbtrs( transt, n, kl, ku, 1, afb, ldafb, ipiv,work, n, info ) + call stdlib_${ci}$gbtrs( transt, n, kl, ku, 1, afb, ldafb, ipiv,work, n, info ) do i = 1, n work( i ) = rwork( i )*work( i ) @@ -2925,7 +2927,7 @@ module stdlib_linalg_lapack_w do i = 1, n work( i ) = rwork( i )*work( i ) end do - call stdlib_wgbtrs( transn, n, kl, ku, 1, afb, ldafb, ipiv,work, n, info ) + call stdlib_${ci}$gbtrs( transn, n, kl, ku, 1, afb, ldafb, ipiv,work, n, info ) end if go to 100 @@ -2938,10 +2940,10 @@ module stdlib_linalg_lapack_w if( lstres/=zero )ferr( j ) = ferr( j ) / lstres end do loop_140 return - end subroutine stdlib_wgbrfs + end subroutine stdlib_${ci}$gbrfs - pure subroutine stdlib_wgbsv( n, kl, ku, nrhs, ab, ldab, ipiv, b, ldb, info ) + pure subroutine stdlib_${ci}$gbsv( n, kl, ku, nrhs, ab, ldab, ipiv, b, ldb, info ) !! ZGBSV: computes the solution to a complex system of linear equations !! A * X = B, where A is a band matrix of order N with KL subdiagonals !! and KU superdiagonals, and X and B are N-by-NRHS matrices. @@ -2958,7 +2960,7 @@ module stdlib_linalg_lapack_w integer(ilp), intent(in) :: kl, ku, ldab, ldb, n, nrhs ! Array Arguments integer(ilp), intent(out) :: ipiv(*) - complex(qp), intent(inout) :: ab(ldab,*), b(ldb,*) + complex(${ck}$), intent(inout) :: ab(ldab,*), b(ldb,*) ! ===================================================================== ! Intrinsic Functions intrinsic :: max @@ -2983,17 +2985,17 @@ module stdlib_linalg_lapack_w return end if ! compute the lu factorization of the band matrix a. - call stdlib_wgbtrf( n, n, kl, ku, ab, ldab, ipiv, info ) + call stdlib_${ci}$gbtrf( n, n, kl, ku, ab, ldab, ipiv, info ) if( info==0 ) then ! solve the system a*x = b, overwriting b with x. - call stdlib_wgbtrs( 'NO TRANSPOSE', n, kl, ku, nrhs, ab, ldab, ipiv,b, ldb, info ) + call stdlib_${ci}$gbtrs( 'NO TRANSPOSE', n, kl, ku, nrhs, ab, ldab, ipiv,b, ldb, info ) end if return - end subroutine stdlib_wgbsv + end subroutine stdlib_${ci}$gbsv - subroutine stdlib_wgbsvx( fact, trans, n, kl, ku, nrhs, ab, ldab, afb,ldafb, ipiv, equed, r, & + subroutine stdlib_${ci}$gbsvx( fact, trans, n, kl, ku, nrhs, ab, ldab, afb,ldafb, ipiv, equed, r, & !! ZGBSVX: uses the LU factorization to compute the solution to a complex !! system of linear equations A * X = B, A**T * X = B, or A**H * X = B, !! where A is a band matrix of order N with KL subdiagonals and KU @@ -3009,13 +3011,13 @@ module stdlib_linalg_lapack_w character, intent(in) :: fact, trans integer(ilp), intent(out) :: info integer(ilp), intent(in) :: kl, ku, ldab, ldafb, ldb, ldx, n, nrhs - real(qp), intent(out) :: rcond + real(${ck}$), intent(out) :: rcond ! Array Arguments integer(ilp), intent(inout) :: ipiv(*) - real(qp), intent(out) :: berr(*), ferr(*), rwork(*) - real(qp), intent(inout) :: c(*), r(*) - complex(qp), intent(inout) :: ab(ldab,*), afb(ldafb,*), b(ldb,*) - complex(qp), intent(out) :: work(*), x(ldx,*) + real(${ck}$), intent(out) :: berr(*), ferr(*), rwork(*) + real(${ck}$), intent(inout) :: c(*), r(*) + complex(${ck}$), intent(inout) :: ab(ldab,*), afb(ldafb,*), b(ldb,*) + complex(${ck}$), intent(out) :: work(*), x(ldx,*) ! ===================================================================== ! moved setting of info = n+1 so info does not subsequently get ! overwritten. sven, 17 mar 05. @@ -3025,7 +3027,7 @@ module stdlib_linalg_lapack_w logical(lk) :: colequ, equil, nofact, notran, rowequ character :: norm integer(ilp) :: i, infequ, j, j1, j2 - real(qp) :: amax, anorm, bignum, colcnd, rcmax, rcmin, rowcnd, rpvgrw, smlnum + real(${ck}$) :: amax, anorm, bignum, colcnd, rcmax, rcmin, rowcnd, rpvgrw, smlnum ! Intrinsic Functions intrinsic :: abs,max,min ! Executable Statements @@ -3040,7 +3042,7 @@ module stdlib_linalg_lapack_w else rowequ = stdlib_lsame( equed, 'R' ) .or. stdlib_lsame( equed, 'B' ) colequ = stdlib_lsame( equed, 'C' ) .or. stdlib_lsame( equed, 'B' ) - smlnum = stdlib_qlamch( 'SAFE MINIMUM' ) + smlnum = stdlib_${c2ri(ci)}$lamch( 'SAFE MINIMUM' ) bignum = one / smlnum end if ! test the input parameters. @@ -3109,11 +3111,11 @@ module stdlib_linalg_lapack_w end if if( equil ) then ! compute row and column scalings to equilibrate the matrix a. - call stdlib_wgbequ( n, n, kl, ku, ab, ldab, r, c, rowcnd, colcnd,amax, infequ ) + call stdlib_${ci}$gbequ( n, n, kl, ku, ab, ldab, r, c, rowcnd, colcnd,amax, infequ ) if( infequ==0 ) then ! equilibrate the matrix. - call stdlib_wlaqgb( n, n, kl, ku, ab, ldab, r, c, rowcnd, colcnd,amax, equed ) + call stdlib_${ci}$laqgb( n, n, kl, ku, ab, ldab, r, c, rowcnd, colcnd,amax, equed ) rowequ = stdlib_lsame( equed, 'R' ) .or. stdlib_lsame( equed, 'B' ) colequ = stdlib_lsame( equed, 'C' ) .or. stdlib_lsame( equed, 'B' ) @@ -3140,10 +3142,10 @@ module stdlib_linalg_lapack_w do j = 1, n j1 = max( j-ku, 1 ) j2 = min( j+kl, n ) - call stdlib_wcopy( j2-j1+1, ab( ku+1-j+j1, j ), 1,afb( kl+ku+1-j+j1, j ), 1 ) + call stdlib_${ci}$copy( j2-j1+1, ab( ku+1-j+j1, j ), 1,afb( kl+ku+1-j+j1, j ), 1 ) end do - call stdlib_wgbtrf( n, n, kl, ku, afb, ldafb, ipiv, info ) + call stdlib_${ci}$gbtrf( n, n, kl, ku, afb, ldafb, ipiv, info ) ! return if info is non-zero. if( info>0 ) then ! compute the reciprocal pivot growth factor of the @@ -3154,7 +3156,7 @@ module stdlib_linalg_lapack_w anorm = max( anorm, abs( ab( i, j ) ) ) end do end do - rpvgrw = stdlib_wlantb( 'M', 'U', 'N', info, min( info-1, kl+ku ),afb( max( 1, & + rpvgrw = stdlib_${ci}$lantb( 'M', 'U', 'N', info, min( info-1, kl+ku ),afb( max( 1, & kl+ku+2-info ), 1 ), ldafb,rwork ) if( rpvgrw==zero ) then rpvgrw = one @@ -3173,22 +3175,22 @@ module stdlib_linalg_lapack_w else norm = 'I' end if - anorm = stdlib_wlangb( norm, n, kl, ku, ab, ldab, rwork ) - rpvgrw = stdlib_wlantb( 'M', 'U', 'N', n, kl+ku, afb, ldafb, rwork ) + anorm = stdlib_${ci}$langb( norm, n, kl, ku, ab, ldab, rwork ) + rpvgrw = stdlib_${ci}$lantb( 'M', 'U', 'N', n, kl+ku, afb, ldafb, rwork ) if( rpvgrw==zero ) then rpvgrw = one else - rpvgrw = stdlib_wlangb( 'M', n, kl, ku, ab, ldab, rwork ) / rpvgrw + rpvgrw = stdlib_${ci}$langb( 'M', n, kl, ku, ab, ldab, rwork ) / rpvgrw end if ! compute the reciprocal of the condition number of a. - call stdlib_wgbcon( norm, n, kl, ku, afb, ldafb, ipiv, anorm, rcond,work, rwork, info ) + call stdlib_${ci}$gbcon( norm, n, kl, ku, afb, ldafb, ipiv, anorm, rcond,work, rwork, info ) ! compute the solution matrix x. - call stdlib_wlacpy( 'FULL', n, nrhs, b, ldb, x, ldx ) - call stdlib_wgbtrs( trans, n, kl, ku, nrhs, afb, ldafb, ipiv, x, ldx,info ) + call stdlib_${ci}$lacpy( 'FULL', n, nrhs, b, ldb, x, ldx ) + call stdlib_${ci}$gbtrs( trans, n, kl, ku, nrhs, afb, ldafb, ipiv, x, ldx,info ) ! use iterative refinement to improve the computed solution and ! compute error bounds and backward error estimates for it. - call stdlib_wgbrfs( trans, n, kl, ku, nrhs, ab, ldab, afb, ldafb, ipiv,b, ldb, x, ldx, & + call stdlib_${ci}$gbrfs( trans, n, kl, ku, nrhs, ab, ldab, afb, ldafb, ipiv,b, ldb, x, ldx, & ferr, berr, work, rwork, info ) ! transform the solution matrix x to a solution of the original ! system. @@ -3214,13 +3216,13 @@ module stdlib_linalg_lapack_w end do end if ! set info = n+1 if the matrix is singular to working precision. - if( rcond0 ) then ! compute multipliers. - call stdlib_wscal( km, cone / ab( kv+1, j ), ab( kv+2, j ), 1 ) + call stdlib_${ci}$scal( km, cone / ab( kv+1, j ), ab( kv+2, j ), 1 ) ! update trailing submatrix within the band. - if( ju>j )call stdlib_wgeru( km, ju-j, -cone, ab( kv+2, j ), 1,ab( kv, j+1 ), & + if( ju>j )call stdlib_${ci}$geru( km, ju-j, -cone, ab( kv+2, j ), 1,ab( kv, j+1 ), & ldab-1, ab( kv+1, j+1 ),ldab-1 ) end if else @@ -3303,10 +3305,10 @@ module stdlib_linalg_lapack_w end if end do loop_40 return - end subroutine stdlib_wgbtf2 + end subroutine stdlib_${ci}$gbtf2 - pure subroutine stdlib_wgbtrf( m, n, kl, ku, ab, ldab, ipiv, info ) + pure subroutine stdlib_${ci}$gbtrf( m, n, kl, ku, ab, ldab, ipiv, info ) !! ZGBTRF: computes an LU factorization of a complex m-by-n band matrix A !! using partial pivoting with row interchanges. !! This is the blocked version of the algorithm, calling Level 3 BLAS. @@ -3318,7 +3320,7 @@ module stdlib_linalg_lapack_w integer(ilp), intent(in) :: kl, ku, ldab, m, n ! Array Arguments integer(ilp), intent(out) :: ipiv(*) - complex(qp), intent(inout) :: ab(ldab,*) + complex(${ck}$), intent(inout) :: ab(ldab,*) ! ===================================================================== ! Parameters integer(ilp), parameter :: nbmax = 64 @@ -3328,9 +3330,9 @@ module stdlib_linalg_lapack_w ! Local Scalars integer(ilp) :: i, i2, i3, ii, ip, j, j2, j3, jb, jj, jm, jp, ju, k2, km, kv, nb, & nw - complex(qp) :: temp + complex(${ck}$) :: temp ! Local Arrays - complex(qp) :: work13(ldwork,nbmax), work31(ldwork,nbmax) + complex(${ck}$) :: work13(ldwork,nbmax), work31(ldwork,nbmax) ! Intrinsic Functions intrinsic :: max,min ! Executable Statements @@ -3363,7 +3365,7 @@ module stdlib_linalg_lapack_w nb = min( nb, nbmax ) if( nb<=1 .or. nb>kl ) then ! use unblocked code - call stdlib_wgbtf2( m, n, kl, ku, ab, ldab, ipiv, info ) + call stdlib_${ci}$gbtf2( m, n, kl, ku, ab, ldab, ipiv, info ) else ! use blocked code ! czero the superdiagonal elements of the work array work13 @@ -3413,31 +3415,31 @@ module stdlib_linalg_lapack_w ! find pivot and test for singularity. km is the number of ! subdiagonal elements in the current column. km = min( kl, m-jj ) - jp = stdlib_iwamax( km+1, ab( kv+1, jj ), 1 ) + jp = stdlib_i${ci}$amax( km+1, ab( kv+1, jj ), 1 ) ipiv( jj ) = jp + jj - j if( ab( kv+jp, jj )/=czero ) then ju = max( ju, min( jj+ku+jp-1, n ) ) if( jp/=1 ) then ! apply interchange to columns j to j+jb-1 if( jp+jj-1jj )call stdlib_wgeru( km, jm-jj, -cone, ab( kv+2, jj ), 1,ab( kv, & + if( jm>jj )call stdlib_${ci}$geru( km, jm-jj, -cone, ab( kv+2, jj ), 1,ab( kv, & jj+1 ), ldab-1,ab( kv+1, jj+1 ), ldab-1 ) else ! if pivot is czero, set info to the index of the pivot @@ -3446,16 +3448,16 @@ module stdlib_linalg_lapack_w end if ! copy current column of a31 into the work array work31 nw = min( jj-j+1, i3 ) - if( nw>0 )call stdlib_wcopy( nw, ab( kv+kl+1-jj+j, jj ), 1,work31( 1, jj-j+1 )& + if( nw>0 )call stdlib_${ci}$copy( nw, ab( kv+kl+1-jj+j, jj ), 1,work31( 1, jj-j+1 )& , 1 ) end do loop_80 if( j+jb<=n ) then ! apply the row interchanges to the other blocks. j2 = min( ju-j+1, kv ) - jb j3 = max( 0, ju-j-kv+1 ) - ! use stdlib_wlaswp to apply the row interchanges to a12, a22, and + ! use stdlib_${ci}$laswp to apply the row interchanges to a12, a22, and ! a32. - call stdlib_wlaswp( j2, ab( kv+1-jb, j+jb ), ldab-1, 1, jb,ipiv( j ), 1 ) + call stdlib_${ci}$laswp( j2, ab( kv+1-jb, j+jb ), ldab-1, 1, jb,ipiv( j ), 1 ) ! adjust the pivot indices. do i = j, j + jb - 1 @@ -3478,17 +3480,17 @@ module stdlib_linalg_lapack_w ! update the relevant part of the trailing submatrix if( j2>0 ) then ! update a12 - call stdlib_wtrsm( 'LEFT', 'LOWER', 'NO TRANSPOSE', 'UNIT',jb, j2, cone, & + call stdlib_${ci}$trsm( 'LEFT', 'LOWER', 'NO TRANSPOSE', 'UNIT',jb, j2, cone, & ab( kv+1, j ), ldab-1,ab( kv+1-jb, j+jb ), ldab-1 ) if( i2>0 ) then ! update a22 - call stdlib_wgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', i2, j2,jb, -cone, ab(& + call stdlib_${ci}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', i2, j2,jb, -cone, ab(& kv+1+jb, j ), ldab-1,ab( kv+1-jb, j+jb ), ldab-1, cone,ab( kv+1, j+jb )& , ldab-1 ) end if if( i3>0 ) then ! update a32 - call stdlib_wgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', i3, j2,jb, -cone, & + call stdlib_${ci}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', i3, j2,jb, -cone, & work31, ldwork,ab( kv+1-jb, j+jb ), ldab-1, cone,ab( kv+kl+1-jb, j+jb ),& ldab-1 ) end if @@ -3502,17 +3504,17 @@ module stdlib_linalg_lapack_w end do end do ! update a13 in the work array - call stdlib_wtrsm( 'LEFT', 'LOWER', 'NO TRANSPOSE', 'UNIT',jb, j3, cone, & + call stdlib_${ci}$trsm( 'LEFT', 'LOWER', 'NO TRANSPOSE', 'UNIT',jb, j3, cone, & ab( kv+1, j ), ldab-1,work13, ldwork ) if( i2>0 ) then ! update a23 - call stdlib_wgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', i2, j3,jb, -cone, ab(& + call stdlib_${ci}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', i2, j3,jb, -cone, ab(& kv+1+jb, j ), ldab-1,work13, ldwork, cone, ab( 1+jb, j+kv ),ldab-1 ) end if if( i3>0 ) then ! update a33 - call stdlib_wgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', i3, j3,jb, -cone, & + call stdlib_${ci}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', i3, j3,jb, -cone, & work31, ldwork, work13,ldwork, cone, ab( 1+kl, j+kv ), ldab-1 ) end if ! copy the lower triangle of a13 back into place @@ -3537,26 +3539,26 @@ module stdlib_linalg_lapack_w ! apply interchange to columns j to jj-1 if( jp+jj-10 )call stdlib_wcopy( nw, work31( 1, jj-j+1 ), 1,ab( kv+kl+1-jj+j, jj )& + if( nw>0 )call stdlib_${ci}$copy( nw, work31( 1, jj-j+1 ), 1,ab( kv+kl+1-jj+j, jj )& , 1 ) end do end do loop_180 end if return - end subroutine stdlib_wgbtrf + end subroutine stdlib_${ci}$gbtrf - pure subroutine stdlib_wgbtrs( trans, n, kl, ku, nrhs, ab, ldab, ipiv, b, ldb,info ) + pure subroutine stdlib_${ci}$gbtrs( trans, n, kl, ku, nrhs, ab, ldab, ipiv, b, ldb,info ) !! ZGBTRS: solves a system of linear equations !! A * X = B, A**T * X = B, or A**H * X = B !! with a general band matrix A using the LU factorization computed @@ -3570,8 +3572,8 @@ module stdlib_linalg_lapack_w integer(ilp), intent(in) :: kl, ku, ldab, ldb, n, nrhs ! Array Arguments integer(ilp), intent(in) :: ipiv(*) - complex(qp), intent(in) :: ab(ldab,*) - complex(qp), intent(inout) :: b(ldb,*) + complex(${ck}$), intent(in) :: ab(ldab,*) + complex(${ck}$), intent(inout) :: b(ldb,*) ! ===================================================================== ! Local Scalars @@ -3618,58 +3620,58 @@ module stdlib_linalg_lapack_w do j = 1, n - 1 lm = min( kl, n-j ) l = ipiv( j ) - if( l/=j )call stdlib_wswap( nrhs, b( l, 1 ), ldb, b( j, 1 ), ldb ) - call stdlib_wgeru( lm, nrhs, -cone, ab( kd+1, j ), 1, b( j, 1 ),ldb, b( j+1, & + if( l/=j )call stdlib_${ci}$swap( nrhs, b( l, 1 ), ldb, b( j, 1 ), ldb ) + call stdlib_${ci}$geru( lm, nrhs, -cone, ab( kd+1, j ), 1, b( j, 1 ),ldb, b( j+1, & 1 ), ldb ) end do end if do i = 1, nrhs ! solve u*x = b, overwriting b with x. - call stdlib_wtbsv( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', n, kl+ku,ab, ldab, b( 1, & + call stdlib_${ci}$tbsv( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', n, kl+ku,ab, ldab, b( 1, & i ), 1 ) end do else if( stdlib_lsame( trans, 'T' ) ) then ! solve a**t * x = b. do i = 1, nrhs ! solve u**t * x = b, overwriting b with x. - call stdlib_wtbsv( 'UPPER', 'TRANSPOSE', 'NON-UNIT', n, kl+ku, ab,ldab, b( 1, i )& + call stdlib_${ci}$tbsv( 'UPPER', 'TRANSPOSE', 'NON-UNIT', n, kl+ku, ab,ldab, b( 1, i )& , 1 ) end do ! solve l**t * x = b, overwriting b with x. if( lnoti ) then do j = n - 1, 1, -1 lm = min( kl, n-j ) - call stdlib_wgemv( 'TRANSPOSE', lm, nrhs, -cone, b( j+1, 1 ),ldb, ab( kd+1, j & + call stdlib_${ci}$gemv( 'TRANSPOSE', lm, nrhs, -cone, b( j+1, 1 ),ldb, ab( kd+1, j & ), 1, cone, b( j, 1 ), ldb ) l = ipiv( j ) - if( l/=j )call stdlib_wswap( nrhs, b( l, 1 ), ldb, b( j, 1 ), ldb ) + if( l/=j )call stdlib_${ci}$swap( nrhs, b( l, 1 ), ldb, b( j, 1 ), ldb ) end do end if else ! solve a**h * x = b. do i = 1, nrhs ! solve u**h * x = b, overwriting b with x. - call stdlib_wtbsv( 'UPPER', 'CONJUGATE TRANSPOSE', 'NON-UNIT', n,kl+ku, ab, ldab,& + call stdlib_${ci}$tbsv( 'UPPER', 'CONJUGATE TRANSPOSE', 'NON-UNIT', n,kl+ku, ab, ldab,& b( 1, i ), 1 ) end do ! solve l**h * x = b, overwriting b with x. if( lnoti ) then do j = n - 1, 1, -1 lm = min( kl, n-j ) - call stdlib_wlacgv( nrhs, b( j, 1 ), ldb ) - call stdlib_wgemv( 'CONJUGATE TRANSPOSE', lm, nrhs, -cone,b( j+1, 1 ), ldb, & + call stdlib_${ci}$lacgv( nrhs, b( j, 1 ), ldb ) + call stdlib_${ci}$gemv( 'CONJUGATE TRANSPOSE', lm, nrhs, -cone,b( j+1, 1 ), ldb, & ab( kd+1, j ), 1, cone,b( j, 1 ), ldb ) - call stdlib_wlacgv( nrhs, b( j, 1 ), ldb ) + call stdlib_${ci}$lacgv( nrhs, b( j, 1 ), ldb ) l = ipiv( j ) - if( l/=j )call stdlib_wswap( nrhs, b( l, 1 ), ldb, b( j, 1 ), ldb ) + if( l/=j )call stdlib_${ci}$swap( nrhs, b( l, 1 ), ldb, b( j, 1 ), ldb ) end do end if end if return - end subroutine stdlib_wgbtrs + end subroutine stdlib_${ci}$gbtrs - pure subroutine stdlib_wgebak( job, side, n, ilo, ihi, scale, m, v, ldv,info ) + pure subroutine stdlib_${ci}$gebak( job, side, n, ilo, ihi, scale, m, v, ldv,info ) !! ZGEBAK: forms the right or left eigenvectors of a complex general !! matrix by backward transformation on the computed eigenvectors of the !! balanced matrix output by ZGEBAL. @@ -3681,14 +3683,14 @@ module stdlib_linalg_lapack_w integer(ilp), intent(in) :: ihi, ilo, ldv, m, n integer(ilp), intent(out) :: info ! Array Arguments - real(qp), intent(in) :: scale(*) - complex(qp), intent(inout) :: v(ldv,*) + real(${ck}$), intent(in) :: scale(*) + complex(${ck}$), intent(inout) :: v(ldv,*) ! ===================================================================== ! Local Scalars logical(lk) :: leftv, rightv integer(ilp) :: i, ii, k - real(qp) :: s + real(${ck}$) :: s ! Intrinsic Functions intrinsic :: max,min ! Executable Statements @@ -3726,13 +3728,13 @@ module stdlib_linalg_lapack_w if( rightv ) then do i = ilo, ihi s = scale( i ) - call stdlib_wdscal( m, s, v( i, 1 ), ldv ) + call stdlib_${ci}$dscal( m, s, v( i, 1 ), ldv ) end do end if if( leftv ) then do i = ilo, ihi s = one / scale( i ) - call stdlib_wdscal( m, s, v( i, 1 ), ldv ) + call stdlib_${ci}$dscal( m, s, v( i, 1 ), ldv ) end do end if end if @@ -3748,7 +3750,7 @@ module stdlib_linalg_lapack_w if( i=g .or. max( f, c, ca )>=sfmax2 .or.min( r, g, ra )<=sfmin2 )go to 170 - if( stdlib_qisnan( c+f+ca+r+g+ra ) ) then + if( stdlib_${c2ri(ci)}$isnan( c+f+ca+r+g+ra ) ) then ! exit if nan to avoid infinite loop info = -3 call stdlib_xerbla( 'ZGEBAL', -info ) @@ -3925,18 +3927,18 @@ module stdlib_linalg_lapack_w g = one / f scale( i ) = scale( i )*f noconv = .true. - call stdlib_wdscal( n-k+1, g, a( i, k ), lda ) - call stdlib_wdscal( l, f, a( 1, i ), 1 ) + call stdlib_${ci}$dscal( n-k+1, g, a( i, k ), lda ) + call stdlib_${ci}$dscal( l, f, a( 1, i ), 1 ) end do loop_200 if( noconv )go to 140 210 continue ilo = k ihi = l return - end subroutine stdlib_wgebal + end subroutine stdlib_${ci}$gebal - pure subroutine stdlib_wgebd2( m, n, a, lda, d, e, tauq, taup, work, info ) + pure subroutine stdlib_${ci}$gebd2( m, n, a, lda, d, e, tauq, taup, work, info ) !! ZGEBD2: reduces a complex general m by n matrix A to upper or lower !! real bidiagonal form B by a unitary transformation: Q**H * A * P = B. !! If m >= n, B is upper bidiagonal; if m < n, B is lower bidiagonal. @@ -3947,14 +3949,14 @@ module stdlib_linalg_lapack_w integer(ilp), intent(out) :: info integer(ilp), intent(in) :: lda, m, n ! Array Arguments - real(qp), intent(out) :: d(*), e(*) - complex(qp), intent(inout) :: a(lda,*) - complex(qp), intent(out) :: taup(*), tauq(*), work(*) + real(${ck}$), intent(out) :: d(*), e(*) + complex(${ck}$), intent(inout) :: a(lda,*) + complex(${ck}$), intent(out) :: taup(*), tauq(*), work(*) ! ===================================================================== ! Local Scalars integer(ilp) :: i - complex(qp) :: alpha + complex(${ck}$) :: alpha ! Intrinsic Functions intrinsic :: conjg,max,min ! Executable Statements @@ -3976,25 +3978,25 @@ module stdlib_linalg_lapack_w do i = 1, n ! generate elementary reflector h(i) to annihilate a(i+1:m,i) alpha = a( i, i ) - call stdlib_wlarfg( m-i+1, alpha, a( min( i+1, m ), i ), 1,tauq( i ) ) - d( i ) = real( alpha,KIND=qp) + call stdlib_${ci}$larfg( m-i+1, alpha, a( min( i+1, m ), i ), 1,tauq( i ) ) + d( i ) = real( alpha,KIND=${ck}$) a( i, i ) = cone ! apply h(i)**h to a(i:m,i+1:n) from the left - if( i= n, B is upper bidiagonal; if m < n, B is lower bidiagonal. @@ -4045,9 +4047,9 @@ module stdlib_linalg_lapack_w integer(ilp), intent(out) :: info integer(ilp), intent(in) :: lda, lwork, m, n ! Array Arguments - real(qp), intent(out) :: d(*), e(*) - complex(qp), intent(inout) :: a(lda,*) - complex(qp), intent(out) :: taup(*), tauq(*), work(*) + real(${ck}$), intent(out) :: d(*), e(*) + complex(${ck}$), intent(inout) :: a(lda,*) + complex(${ck}$), intent(out) :: taup(*), tauq(*), work(*) ! ===================================================================== ! Local Scalars @@ -4060,7 +4062,7 @@ module stdlib_linalg_lapack_w info = 0 nb = max( 1, stdlib_ilaenv( 1, 'ZGEBRD', ' ', m, n, -1, -1 ) ) lwkopt = ( m+n )*nb - work( 1 ) = real( lwkopt,KIND=qp) + work( 1 ) = real( lwkopt,KIND=${ck}$) lquery = ( lwork==-1 ) if( m<0 ) then info = -1 @@ -4111,14 +4113,14 @@ module stdlib_linalg_lapack_w ! reduce rows and columns i:i+ib-1 to bidiagonal form and return ! the matrices x and y which are needed to update the unreduced ! part of the matrix - call stdlib_wlabrd( m-i+1, n-i+1, nb, a( i, i ), lda, d( i ), e( i ),tauq( i ), & + call stdlib_${ci}$labrd( m-i+1, n-i+1, nb, a( i, i ), lda, d( i ), e( i ),tauq( i ), & taup( i ), work, ldwrkx,work( ldwrkx*nb+1 ), ldwrky ) ! update the trailing submatrix a(i+ib:m,i+ib:n), using ! an update of the form a := a - v*y**h - x*u**h - call stdlib_wgemm( 'NO TRANSPOSE', 'CONJUGATE TRANSPOSE', m-i-nb+1,n-i-nb+1, nb, -& + call stdlib_${ci}$gemm( 'NO TRANSPOSE', 'CONJUGATE TRANSPOSE', m-i-nb+1,n-i-nb+1, nb, -& cone, a( i+nb, i ), lda,work( ldwrkx*nb+nb+1 ), ldwrky, cone,a( i+nb, i+nb ), lda ) - call stdlib_wgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', m-i-nb+1, n-i-nb+1,nb, -cone, & + call stdlib_${ci}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', m-i-nb+1, n-i-nb+1,nb, -cone, & work( nb+1 ), ldwrkx, a( i, i+nb ), lda,cone, a( i+nb, i+nb ), lda ) ! copy diagonal and off-diagonal elements of b back into a if( m>=n ) then @@ -4134,14 +4136,14 @@ module stdlib_linalg_lapack_w end if end do ! use unblocked code to reduce the remainder of the matrix - call stdlib_wgebd2( m-i+1, n-i+1, a( i, i ), lda, d( i ), e( i ),tauq( i ), taup( i ), & + call stdlib_${ci}$gebd2( m-i+1, n-i+1, a( i, i ), lda, d( i ), e( i ),tauq( i ), taup( i ), & work, iinfo ) work( 1 ) = ws return - end subroutine stdlib_wgebrd + end subroutine stdlib_${ci}$gebrd - pure subroutine stdlib_wgecon( norm, n, a, lda, anorm, rcond, work, rwork,info ) + pure subroutine stdlib_${ci}$gecon( norm, n, a, lda, anorm, rcond, work, rwork,info ) !! ZGECON: estimates the reciprocal of the condition number of a general !! complex matrix A, in either the 1-norm or the infinity-norm, using !! the LU factorization computed by ZGETRF. @@ -4155,28 +4157,28 @@ module stdlib_linalg_lapack_w character, intent(in) :: norm integer(ilp), intent(out) :: info integer(ilp), intent(in) :: lda, n - real(qp), intent(in) :: anorm - real(qp), intent(out) :: rcond + real(${ck}$), intent(in) :: anorm + real(${ck}$), intent(out) :: rcond ! Array Arguments - real(qp), intent(out) :: rwork(*) - complex(qp), intent(inout) :: a(lda,*) - complex(qp), intent(out) :: work(*) + real(${ck}$), intent(out) :: rwork(*) + complex(${ck}$), intent(inout) :: a(lda,*) + complex(${ck}$), intent(out) :: work(*) ! ===================================================================== ! Local Scalars logical(lk) :: onenrm character :: normin integer(ilp) :: ix, kase, kase1 - real(qp) :: ainvnm, scale, sl, smlnum, su - complex(qp) :: zdum + real(${ck}$) :: ainvnm, scale, sl, smlnum, su + complex(${ck}$) :: zdum ! Local Arrays integer(ilp) :: isave(3) ! Intrinsic Functions intrinsic :: abs,real,aimag,max ! Statement Functions - real(qp) :: cabs1 + real(${ck}$) :: cabs1 ! Statement Function Definitions - cabs1( zdum ) = abs( real( zdum,KIND=qp) ) + abs( aimag( zdum ) ) + cabs1( zdum ) = abs( real( zdum,KIND=${ck}$) ) + abs( aimag( zdum ) ) ! Executable Statements ! test the input parameters. info = 0 @@ -4202,7 +4204,7 @@ module stdlib_linalg_lapack_w else if( anorm==zero ) then return end if - smlnum = stdlib_qlamch( 'SAFE MINIMUM' ) + smlnum = stdlib_${c2ri(ci)}$lamch( 'SAFE MINIMUM' ) ! estimate the norm of inv(a). ainvnm = zero normin = 'N' @@ -4213,30 +4215,30 @@ module stdlib_linalg_lapack_w end if kase = 0 10 continue - call stdlib_wlacn2( n, work( n+1 ), work, ainvnm, kase, isave ) + call stdlib_${ci}$lacn2( n, work( n+1 ), work, ainvnm, kase, isave ) if( kase/=0 ) then if( kase==kase1 ) then ! multiply by inv(l). - call stdlib_wlatrs( 'LOWER', 'NO TRANSPOSE', 'UNIT', normin, n, a,lda, work, sl, & + call stdlib_${ci}$latrs( 'LOWER', 'NO TRANSPOSE', 'UNIT', normin, n, a,lda, work, sl, & rwork, info ) ! multiply by inv(u). - call stdlib_wlatrs( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', normin, n,a, lda, work, & + call stdlib_${ci}$latrs( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', normin, n,a, lda, work, & su, rwork( n+1 ), info ) else ! multiply by inv(u**h). - call stdlib_wlatrs( 'UPPER', 'CONJUGATE TRANSPOSE', 'NON-UNIT',normin, n, a, lda,& + call stdlib_${ci}$latrs( 'UPPER', 'CONJUGATE TRANSPOSE', 'NON-UNIT',normin, n, a, lda,& work, su, rwork( n+1 ),info ) ! multiply by inv(l**h). - call stdlib_wlatrs( 'LOWER', 'CONJUGATE TRANSPOSE', 'UNIT', normin,n, a, lda, & + call stdlib_${ci}$latrs( 'LOWER', 'CONJUGATE TRANSPOSE', 'UNIT', normin,n, a, lda, & work, sl, rwork, info ) end if ! divide x by 1/(sl*su) if doing so will not cause overflow. scale = sl*su normin = 'Y' if( scale/=one ) then - ix = stdlib_iwamax( n, work, 1 ) + ix = stdlib_i${ci}$amax( n, work, 1 ) if( scalezero .and. anrm0 )info = ieval ! sort eigenvalues if desired if( wantst .and. info==0 ) then - if( scalea )call stdlib_wlascl( 'G', 0, 0, cscale, anrm, n, 1, w, n, ierr ) + if( scalea )call stdlib_${ci}$lascl( 'G', 0, 0, cscale, anrm, n, 1, w, n, ierr ) do i = 1, n bwork( i ) = select( w( i ) ) end do ! reorder eigenvalues and transform schur vectors ! (cworkspace: none) ! (rworkspace: none) - call stdlib_wtrsen( 'N', jobvs, bwork, n, a, lda, vs, ldvs, w, sdim,s, sep, work( & + call stdlib_${ci}$trsen( 'N', jobvs, bwork, n, a, lda, vs, ldvs, w, sdim,s, sep, work( & iwrk ), lwork-iwrk+1, icond ) end if if( wantvs ) then ! undo balancing ! (cworkspace: none) ! (rworkspace: need n) - call stdlib_wgebak( 'P', 'R', n, ilo, ihi, rwork( ibal ), n, vs, ldvs,ierr ) + call stdlib_${ci}$gebak( 'P', 'R', n, ilo, ihi, rwork( ibal ), n, vs, ldvs,ierr ) end if if( scalea ) then ! undo scaling for the schur form of a - call stdlib_wlascl( 'U', 0, 0, cscale, anrm, n, n, a, lda, ierr ) - call stdlib_wcopy( n, a, lda+1, w, 1 ) + call stdlib_${ci}$lascl( 'U', 0, 0, cscale, anrm, n, n, a, lda, ierr ) + call stdlib_${ci}$copy( n, a, lda+1, w, 1 ) end if work( 1 ) = maxwrk return - end subroutine stdlib_wgees + end subroutine stdlib_${ci}$gees - subroutine stdlib_wgeesx( jobvs, sort, select, sense, n, a, lda, sdim, w,vs, ldvs, rconde, & + subroutine stdlib_${ci}$geesx( jobvs, sort, select, sense, n, a, lda, sdim, w,vs, ldvs, rconde, & !! ZGEESX: computes for an N-by-N complex nonsymmetric matrix A, the !! eigenvalues, the Schur form T, and, optionally, the matrix of Schur !! vectors Z. This gives the Schur factorization A = Z*T*(Z**H). @@ -4702,7 +4704,7 @@ module stdlib_linalg_lapack_w !! selected eigenvalues (RCONDV). The leading columns of Z form an !! orthonormal basis for this invariant subspace. !! For further explanation of the reciprocal condition numbers RCONDE - !! and RCONDV, see Section 4.10_qp of the LAPACK Users' Guide (where + !! and RCONDV, see Section 4.10_${ck}$ of the LAPACK Users' Guide (where !! these quantities are called s and sep respectively). !! A complex matrix is in Schur form if it is upper triangular. rcondv, work, lwork, rwork,bwork, info ) @@ -4713,23 +4715,23 @@ module stdlib_linalg_lapack_w character, intent(in) :: jobvs, sense, sort integer(ilp), intent(out) :: info, sdim integer(ilp), intent(in) :: lda, ldvs, lwork, n - real(qp), intent(out) :: rconde, rcondv + real(${ck}$), intent(out) :: rconde, rcondv ! Array Arguments logical(lk), intent(out) :: bwork(*) - real(qp), intent(out) :: rwork(*) - complex(qp), intent(inout) :: a(lda,*) - complex(qp), intent(out) :: vs(ldvs,*), w(*), work(*) + real(${ck}$), intent(out) :: rwork(*) + complex(${ck}$), intent(inout) :: a(lda,*) + complex(${ck}$), intent(out) :: vs(ldvs,*), w(*), work(*) ! Function Arguments - procedure(stdlib_select_w) :: select + procedure(stdlib_select_${ci}$) :: select ! ===================================================================== ! Local Scalars logical(lk) :: lquery, scalea, wantsb, wantse, wantsn, wantst, wantsv, wantvs integer(ilp) :: hswork, i, ibal, icond, ierr, ieval, ihi, ilo, itau, iwrk, lwrk, & maxwrk, minwrk - real(qp) :: anrm, bignum, cscale, eps, smlnum + real(${ck}$) :: anrm, bignum, cscale, eps, smlnum ! Local Arrays - real(qp) :: dum(1) + real(${ck}$) :: dum(1) ! Intrinsic Functions intrinsic :: max,sqrt ! Executable Statements @@ -4763,11 +4765,11 @@ module stdlib_linalg_lapack_w ! cworkspace refers to complex workspace, and rworkspace to real ! workspace. nb refers to the optimal block size for the ! immediately following subroutine, as returned by stdlib_ilaenv. - ! hswork refers to the workspace preferred by stdlib_whseqr, as + ! hswork refers to the workspace preferred by stdlib_${ci}$hseqr, as ! calculated below. hswork is computed assuming ilo=1 and ihi=n, ! the worst case. ! if sense = 'e', 'v' or 'b', then the amount of workspace needed - ! depends on sdim, which is computed by the routine stdlib_wtrsen later + ! depends on sdim, which is computed by the routine stdlib_${ci}$trsen later ! in the code.) if( info==0 ) then if( n==0 ) then @@ -4776,9 +4778,9 @@ module stdlib_linalg_lapack_w else maxwrk = n + n*stdlib_ilaenv( 1, 'ZGEHRD', ' ', n, 1, n, 0 ) minwrk = 2*n - call stdlib_whseqr( 'S', jobvs, n, 1, n, a, lda, w, vs, ldvs,work, -1, ieval ) + call stdlib_${ci}$hseqr( 'S', jobvs, n, 1, n, a, lda, w, vs, ldvs,work, -1, ieval ) - hswork = real( work( 1 ),KIND=qp) + hswork = real( work( 1 ),KIND=${ck}$) if( .not.wantvs ) then maxwrk = max( maxwrk, hswork ) else @@ -4806,14 +4808,14 @@ module stdlib_linalg_lapack_w return end if ! get machine constants - eps = stdlib_qlamch( 'P' ) - smlnum = stdlib_qlamch( 'S' ) + eps = stdlib_${c2ri(ci)}$lamch( 'P' ) + smlnum = stdlib_${c2ri(ci)}$lamch( 'S' ) bignum = one / smlnum - call stdlib_qlabad( smlnum, bignum ) + call stdlib_${c2ri(ci)}$labad( smlnum, bignum ) smlnum = sqrt( smlnum ) / eps bignum = one / smlnum ! scale a if max element outside range [smlnum,bignum] - anrm = stdlib_wlange( 'M', n, n, a, lda, dum ) + anrm = stdlib_${ci}$lange( 'M', n, n, a, lda, dum ) scalea = .false. if( anrm>zero .and. anrm0 )info = ieval ! sort eigenvalues if desired if( wantst .and. info==0 ) then - if( scalea )call stdlib_wlascl( 'G', 0, 0, cscale, anrm, n, 1, w, n, ierr ) + if( scalea )call stdlib_${ci}$lascl( 'G', 0, 0, cscale, anrm, n, 1, w, n, ierr ) do i = 1, n bwork( i ) = select( w( i ) ) end do @@ -4863,7 +4865,7 @@ module stdlib_linalg_lapack_w ! (cworkspace: if sense is not 'n', need 2*sdim*(n-sdim) ! otherwise, need none ) ! (rworkspace: none) - call stdlib_wtrsen( sense, jobvs, bwork, n, a, lda, vs, ldvs, w, sdim,rconde, & + call stdlib_${ci}$trsen( sense, jobvs, bwork, n, a, lda, vs, ldvs, w, sdim,rconde, & rcondv, work( iwrk ), lwork-iwrk+1,icond ) if( .not.wantsn )maxwrk = max( maxwrk, 2*sdim*( n-sdim ) ) if( icond==-14 ) then @@ -4875,24 +4877,24 @@ module stdlib_linalg_lapack_w ! undo balancing ! (cworkspace: none) ! (rworkspace: need n) - call stdlib_wgebak( 'P', 'R', n, ilo, ihi, rwork( ibal ), n, vs, ldvs,ierr ) + call stdlib_${ci}$gebak( 'P', 'R', n, ilo, ihi, rwork( ibal ), n, vs, ldvs,ierr ) end if if( scalea ) then ! undo scaling for the schur form of a - call stdlib_wlascl( 'U', 0, 0, cscale, anrm, n, n, a, lda, ierr ) - call stdlib_wcopy( n, a, lda+1, w, 1 ) + call stdlib_${ci}$lascl( 'U', 0, 0, cscale, anrm, n, n, a, lda, ierr ) + call stdlib_${ci}$copy( n, a, lda+1, w, 1 ) if( ( wantsv .or. wantsb ) .and. info==0 ) then dum( 1 ) = rcondv - call stdlib_qlascl( 'G', 0, 0, cscale, anrm, 1, 1, dum, 1, ierr ) + call stdlib_${c2ri(ci)}$lascl( 'G', 0, 0, cscale, anrm, 1, 1, dum, 1, ierr ) rcondv = dum( 1 ) end if end if work( 1 ) = maxwrk return - end subroutine stdlib_wgeesx + end subroutine stdlib_${ci}$geesx - subroutine stdlib_wgeev( jobvl, jobvr, n, a, lda, w, vl, ldvl, vr, ldvr,work, lwork, rwork, & + subroutine stdlib_${ci}$geev( jobvl, jobvr, n, a, lda, w, vl, ldvl, vr, ldvr,work, lwork, rwork, & !! ZGEEV: computes for an N-by-N complex nonsymmetric matrix A, the !! eigenvalues and, optionally, the left and/or right eigenvectors. !! The right eigenvector v(j) of A satisfies @@ -4912,9 +4914,9 @@ module stdlib_linalg_lapack_w integer(ilp), intent(out) :: info integer(ilp), intent(in) :: lda, ldvl, ldvr, lwork, n ! Array Arguments - real(qp), intent(out) :: rwork(*) - complex(qp), intent(inout) :: a(lda,*) - complex(qp), intent(out) :: vl(ldvl,*), vr(ldvr,*), w(*), work(*) + real(${ck}$), intent(out) :: rwork(*) + complex(${ck}$), intent(inout) :: a(lda,*) + complex(${ck}$), intent(out) :: vl(ldvl,*), vr(ldvr,*), w(*), work(*) ! ===================================================================== ! Local Scalars @@ -4922,11 +4924,11 @@ module stdlib_linalg_lapack_w character :: side integer(ilp) :: hswork, i, ibal, ierr, ihi, ilo, irwork, itau, iwrk, k, lwork_trevc, & maxwrk, minwrk, nout - real(qp) :: anrm, bignum, cscale, eps, scl, smlnum - complex(qp) :: tmp + real(${ck}$) :: anrm, bignum, cscale, eps, scl, smlnum + complex(${ck}$) :: tmp ! Local Arrays logical(lk) :: select(1) - real(qp) :: dum(1) + real(${ck}$) :: dum(1) ! Intrinsic Functions intrinsic :: real,cmplx,conjg,aimag,max,sqrt ! Executable Statements @@ -4955,7 +4957,7 @@ module stdlib_linalg_lapack_w ! cworkspace refers to complex workspace, and rworkspace to real ! workspace. nb refers to the optimal block size for the ! immediately following subroutine, as returned by stdlib_ilaenv. - ! hswork refers to the workspace preferred by stdlib_whseqr, as + ! hswork refers to the workspace preferred by stdlib_${ci}$hseqr, as ! calculated below. hswork is computed assuming ilo=1 and ihi=n, ! the worst case.) if( info==0 ) then @@ -4968,23 +4970,23 @@ module stdlib_linalg_lapack_w if( wantvl ) then maxwrk = max( maxwrk, n + ( n - 1 )*stdlib_ilaenv( 1, 'ZUNGHR',' ', n, 1, n, -& 1 ) ) - call stdlib_wtrevc3( 'L', 'B', select, n, a, lda,vl, ldvl, vr, ldvr,n, nout, & + call stdlib_${ci}$trevc3( 'L', 'B', select, n, a, lda,vl, ldvl, vr, ldvr,n, nout, & work, -1, rwork, -1, ierr ) lwork_trevc = int( work(1),KIND=ilp) maxwrk = max( maxwrk, n + lwork_trevc ) - call stdlib_whseqr( 'S', 'V', n, 1, n, a, lda, w, vl, ldvl,work, -1, info ) + call stdlib_${ci}$hseqr( 'S', 'V', n, 1, n, a, lda, w, vl, ldvl,work, -1, info ) else if( wantvr ) then maxwrk = max( maxwrk, n + ( n - 1 )*stdlib_ilaenv( 1, 'ZUNGHR',' ', n, 1, n, -& 1 ) ) - call stdlib_wtrevc3( 'R', 'B', select, n, a, lda,vl, ldvl, vr, ldvr,n, nout, & + call stdlib_${ci}$trevc3( 'R', 'B', select, n, a, lda,vl, ldvl, vr, ldvr,n, nout, & work, -1, rwork, -1, ierr ) lwork_trevc = int( work(1),KIND=ilp) maxwrk = max( maxwrk, n + lwork_trevc ) - call stdlib_whseqr( 'S', 'V', n, 1, n, a, lda, w, vr, ldvr,work, -1, info ) + call stdlib_${ci}$hseqr( 'S', 'V', n, 1, n, a, lda, w, vr, ldvr,work, -1, info ) else - call stdlib_whseqr( 'E', 'N', n, 1, n, a, lda, w, vr, ldvr,work, -1, info ) + call stdlib_${ci}$hseqr( 'E', 'N', n, 1, n, a, lda, w, vr, ldvr,work, -1, info ) end if hswork = int( work(1),KIND=ilp) @@ -5004,14 +5006,14 @@ module stdlib_linalg_lapack_w ! quick return if possible if( n==0 )return ! get machine constants - eps = stdlib_qlamch( 'P' ) - smlnum = stdlib_qlamch( 'S' ) + eps = stdlib_${c2ri(ci)}$lamch( 'P' ) + smlnum = stdlib_${c2ri(ci)}$lamch( 'S' ) bignum = one / smlnum - call stdlib_qlabad( smlnum, bignum ) + call stdlib_${c2ri(ci)}$labad( smlnum, bignum ) smlnum = sqrt( smlnum ) / eps bignum = one / smlnum ! scale a if max element outside range [smlnum,bignum] - anrm = stdlib_wlange( 'M', n, n, a, lda, dum ) + anrm = stdlib_${ci}$lange( 'M', n, n, a, lda, dum ) scalea = .false. if( anrm>zero .and. anrm0 ) then - call stdlib_wlascl( 'G', 0, 0, cscale, anrm, ilo-1, 1, w, n, ierr ) + call stdlib_${ci}$lascl( 'G', 0, 0, cscale, anrm, ilo-1, 1, w, n, ierr ) end if end if work( 1 ) = maxwrk return - end subroutine stdlib_wgeev + end subroutine stdlib_${ci}$geev - subroutine stdlib_wgeevx( balanc, jobvl, jobvr, sense, n, a, lda, w, vl,ldvl, vr, ldvr, ilo, & + subroutine stdlib_${ci}$geevx( balanc, jobvl, jobvr, sense, n, a, lda, w, vl,ldvl, vr, ldvr, ilo, & !! ZGEEVX: computes for an N-by-N complex nonsymmetric matrix A, the !! eigenvalues and, optionally, the left and/or right eigenvectors. !! Optionally also, it computes a balancing transformation to improve @@ -5165,7 +5167,7 @@ module stdlib_linalg_lapack_w !! reciprocal condition numbers correspond to the balanced matrix. !! Permuting rows and columns will not change the condition numbers !! (in exact arithmetic) but diagonal scaling will. For further - !! explanation of balancing, see section 4.10.2_qp of the LAPACK + !! explanation of balancing, see section 4.10.2_${ck}$ of the LAPACK !! Users' Guide. ihi, scale, abnrm, rconde,rcondv, work, lwork, rwork, info ) ! -- lapack driver routine -- @@ -5175,11 +5177,11 @@ module stdlib_linalg_lapack_w character, intent(in) :: balanc, jobvl, jobvr, sense integer(ilp), intent(out) :: ihi, ilo, info integer(ilp), intent(in) :: lda, ldvl, ldvr, lwork, n - real(qp), intent(out) :: abnrm + real(${ck}$), intent(out) :: abnrm ! Array Arguments - real(qp), intent(out) :: rconde(*), rcondv(*), rwork(*), scale(*) - complex(qp), intent(inout) :: a(lda,*) - complex(qp), intent(out) :: vl(ldvl,*), vr(ldvr,*), w(*), work(*) + real(${ck}$), intent(out) :: rconde(*), rcondv(*), rwork(*), scale(*) + complex(${ck}$), intent(inout) :: a(lda,*) + complex(${ck}$), intent(out) :: vl(ldvl,*), vr(ldvr,*), w(*), work(*) ! ===================================================================== ! Local Scalars @@ -5187,11 +5189,11 @@ module stdlib_linalg_lapack_w character :: job, side integer(ilp) :: hswork, i, icond, ierr, itau, iwrk, k, lwork_trevc, maxwrk, minwrk, & nout - real(qp) :: anrm, bignum, cscale, eps, scl, smlnum - complex(qp) :: tmp + real(${ck}$) :: anrm, bignum, cscale, eps, scl, smlnum + complex(${ck}$) :: tmp ! Local Arrays logical(lk) :: select(1) - real(qp) :: dum(1) + real(${ck}$) :: dum(1) ! Intrinsic Functions intrinsic :: real,cmplx,conjg,aimag,max,sqrt ! Executable Statements @@ -5230,7 +5232,7 @@ module stdlib_linalg_lapack_w ! cworkspace refers to complex workspace, and rworkspace to real ! workspace. nb refers to the optimal block size for the ! immediately following subroutine, as returned by stdlib_ilaenv. - ! hswork refers to the workspace preferred by stdlib_whseqr, as + ! hswork refers to the workspace preferred by stdlib_${ci}$hseqr, as ! calculated below. hswork is computed assuming ilo=1 and ihi=n, ! the worst case.) if( info==0 ) then @@ -5240,25 +5242,25 @@ module stdlib_linalg_lapack_w else maxwrk = n + n*stdlib_ilaenv( 1, 'ZGEHRD', ' ', n, 1, n, 0 ) if( wantvl ) then - call stdlib_wtrevc3( 'L', 'B', select, n, a, lda,vl, ldvl, vr, ldvr,n, nout, & + call stdlib_${ci}$trevc3( 'L', 'B', select, n, a, lda,vl, ldvl, vr, ldvr,n, nout, & work, -1, rwork, -1, ierr ) lwork_trevc = int( work(1),KIND=ilp) maxwrk = max( maxwrk, lwork_trevc ) - call stdlib_whseqr( 'S', 'V', n, 1, n, a, lda, w, vl, ldvl,work, -1, info ) + call stdlib_${ci}$hseqr( 'S', 'V', n, 1, n, a, lda, w, vl, ldvl,work, -1, info ) else if( wantvr ) then - call stdlib_wtrevc3( 'R', 'B', select, n, a, lda,vl, ldvl, vr, ldvr,n, nout, & + call stdlib_${ci}$trevc3( 'R', 'B', select, n, a, lda,vl, ldvl, vr, ldvr,n, nout, & work, -1, rwork, -1, ierr ) lwork_trevc = int( work(1),KIND=ilp) maxwrk = max( maxwrk, lwork_trevc ) - call stdlib_whseqr( 'S', 'V', n, 1, n, a, lda, w, vr, ldvr,work, -1, info ) + call stdlib_${ci}$hseqr( 'S', 'V', n, 1, n, a, lda, w, vr, ldvr,work, -1, info ) else if( wntsnn ) then - call stdlib_whseqr( 'E', 'N', n, 1, n, a, lda, w, vr, ldvr,work, -1, info ) + call stdlib_${ci}$hseqr( 'E', 'N', n, 1, n, a, lda, w, vr, ldvr,work, -1, info ) else - call stdlib_whseqr( 'S', 'N', n, 1, n, a, lda, w, vr, ldvr,work, -1, info ) + call stdlib_${ci}$hseqr( 'S', 'N', n, 1, n, a, lda, w, vr, ldvr,work, -1, info ) end if end if @@ -5293,15 +5295,15 @@ module stdlib_linalg_lapack_w ! quick return if possible if( n==0 )return ! get machine constants - eps = stdlib_qlamch( 'P' ) - smlnum = stdlib_qlamch( 'S' ) + eps = stdlib_${c2ri(ci)}$lamch( 'P' ) + smlnum = stdlib_${c2ri(ci)}$lamch( 'S' ) bignum = one / smlnum - call stdlib_qlabad( smlnum, bignum ) + call stdlib_${c2ri(ci)}$labad( smlnum, bignum ) smlnum = sqrt( smlnum ) / eps bignum = one / smlnum ! scale a if max element outside range [smlnum,bignum] icond = 0 - anrm = stdlib_wlange( 'M', n, n, a, lda, dum ) + anrm = stdlib_${ci}$lange( 'M', n, n, a, lda, dum ) scalea = .false. if( anrm>zero .and. anrm= N. The SVD of [A] is written as !! [A] = [U] * [SIGMA] * [V]^*, @@ -5644,17 +5646,17 @@ module stdlib_linalg_lapack_w integer(ilp), intent(out) :: info integer(ilp), intent(in) :: lda, ldu, ldv, lwork, lrwork, m, n ! Array Arguments - complex(qp), intent(inout) :: a(lda,*) - complex(qp), intent(out) :: u(ldu,*), v(ldv,*), cwork(lwork) - real(qp), intent(out) :: sva(n), rwork(lrwork) + complex(${ck}$), intent(inout) :: a(lda,*) + complex(${ck}$), intent(out) :: u(ldu,*), v(ldv,*), cwork(lwork) + real(${ck}$), intent(out) :: sva(n), rwork(lrwork) integer(ilp), intent(out) :: iwork(*) character, intent(in) :: joba, jobp, jobr, jobt, jobu, jobv ! =========================================================================== ! Local Scalars - complex(qp) :: ctemp - real(qp) :: aapp, aaqq, aatmax, aatmin, big, big1, cond_ok, condr1, condr2, entra, & + complex(${ck}$) :: ctemp + real(${ck}$) :: aapp, aaqq, aatmax, aatmin, big, big1, cond_ok, condr1, condr2, entra, & entrat, epsln, maxprj, scalem, sconda, sfmin, small, temp1, uscal1, uscal2, xsc integer(ilp) :: ierr, n1, nr, numrank, p, q, warning logical(lk) :: almort, defr, errest, goscal, jracc, kill, lquery, lsvec, l2aber, & @@ -5665,8 +5667,8 @@ module stdlib_linalg_lapack_w integer(ilp) :: lwrk_wgelqf, lwrk_wgeqp3, lwrk_wgeqp3n, lwrk_wgeqrf, lwrk_wgesvj, & lwrk_wgesvjv, lwrk_wgesvju, lwrk_wunmlq, lwrk_wunmqr, lwrk_wunmqrm ! Local Arrays - complex(qp) :: cdummy(1) - real(qp) :: rdummy(1) + complex(${ck}$) :: cdummy(1) + real(${ck}$) :: rdummy(1) ! Intrinsic Functions intrinsic :: abs,cmplx,conjg,log,max,min,real,nint,sqrt ! test the input arguments @@ -5717,10 +5719,10 @@ module stdlib_linalg_lapack_w ! values of lcwork, lrwork are written with a lot of redundancy and ! can be simplified. however, this verbose form is useful for ! maintenance and modifications of the code.]] - ! .. minimal workspace length for stdlib_wgeqp3 of an m x n matrix, - ! stdlib_wgeqrf of an n x n matrix, stdlib_wgelqf of an n x n matrix, - ! stdlib_wunmlq for computing n x n matrix, stdlib_wunmqr for computing n x n - ! matrix, stdlib_wunmqr for computing m x n matrix, respectively. + ! .. minimal workspace length for stdlib_${ci}$geqp3 of an m x n matrix, + ! stdlib_${ci}$geqrf of an n x n matrix, stdlib_${ci}$gelqf of an n x n matrix, + ! stdlib_${ci}$unmlq for computing n x n matrix, stdlib_${ci}$unmqr for computing n x n + ! matrix, stdlib_${ci}$unmqr for computing m x n matrix, respectively. lwqp3 = n+1 lwqrf = max( 1, n ) lwlqf = max( 1, n ) @@ -5729,22 +5731,22 @@ module stdlib_linalg_lapack_w lwunmqrm = max( 1, m ) ! Minimal Workspace Length For Stdlib_Zpocon Of An N X N Matrix lwcon = 2 * n - ! .. minimal workspace length for stdlib_wgesvj of an n x n matrix, + ! .. minimal workspace length for stdlib_${ci}$gesvj of an n x n matrix, ! without and with explicit accumulation of jacobi rotations lwsvdj = max( 2 * n, 1 ) lwsvdjv = max( 2 * n, 1 ) - ! .. minimal real workspace length for stdlib_wgeqp3, stdlib_wpocon, stdlib_wgesvj + ! .. minimal real workspace length for stdlib_${ci}$geqp3, stdlib_${ci}$pocon, stdlib_${ci}$gesvj lrwqp3 = 2 * n lrwcon = n lrwsvdj = n if ( lquery ) then - call stdlib_wgeqp3( m, n, a, lda, iwork, cdummy, cdummy, -1,rdummy, ierr ) + call stdlib_${ci}$geqp3( m, n, a, lda, iwork, cdummy, cdummy, -1,rdummy, ierr ) - lwrk_wgeqp3 = real( cdummy(1),KIND=qp) - call stdlib_wgeqrf( n, n, a, lda, cdummy, cdummy,-1, ierr ) - lwrk_wgeqrf = real( cdummy(1),KIND=qp) - call stdlib_wgelqf( n, n, a, lda, cdummy, cdummy,-1, ierr ) - lwrk_wgelqf = real( cdummy(1),KIND=qp) + lwrk_wgeqp3 = real( cdummy(1),KIND=${ck}$) + call stdlib_${ci}$geqrf( n, n, a, lda, cdummy, cdummy,-1, ierr ) + lwrk_wgeqrf = real( cdummy(1),KIND=${ck}$) + call stdlib_${ci}$gelqf( n, n, a, lda, cdummy, cdummy,-1, ierr ) + lwrk_wgelqf = real( cdummy(1),KIND=${ck}$) end if minwrk = 2 optwrk = 2 @@ -5758,9 +5760,9 @@ module stdlib_linalg_lapack_w minwrk = max( n+lwqp3, n+lwqrf, lwsvdj ) end if if ( lquery ) then - call stdlib_wgesvj( 'L', 'N', 'N', n, n, a, lda, sva, n, v,ldv, cdummy, -1,& + call stdlib_${ci}$gesvj( 'L', 'N', 'N', n, n, a, lda, sva, n, v,ldv, cdummy, -1,& rdummy, -1, ierr ) - lwrk_wgesvj = real( cdummy(1),KIND=qp) + lwrk_wgesvj = real( cdummy(1),KIND=${ck}$) if ( errest ) then optwrk = max( n+lwrk_wgeqp3, n**2+lwcon,n+lwrk_wgeqrf, lwrk_wgesvj ) @@ -5793,12 +5795,12 @@ module stdlib_linalg_lapack_w end if if ( lquery ) then - call stdlib_wgesvj( 'L', 'U', 'N', n,n, u, ldu, sva, n, a,lda, cdummy, -1, & + call stdlib_${ci}$gesvj( 'L', 'U', 'N', n,n, u, ldu, sva, n, a,lda, cdummy, -1, & rdummy, -1, ierr ) - lwrk_wgesvj = real( cdummy(1),KIND=qp) - call stdlib_wunmlq( 'L', 'C', n, n, n, a, lda, cdummy,v, ldv, cdummy, -1, & + lwrk_wgesvj = real( cdummy(1),KIND=${ck}$) + call stdlib_${ci}$unmlq( 'L', 'C', n, n, n, a, lda, cdummy,v, ldv, cdummy, -1, & ierr ) - lwrk_wunmlq = real( cdummy(1),KIND=qp) + lwrk_wunmlq = real( cdummy(1),KIND=${ck}$) if ( errest ) then optwrk = max( n+lwrk_wgeqp3, lwcon, lwrk_wgesvj,n+lwrk_wgelqf, 2*n+& lwrk_wgeqrf,n+lwrk_wgesvj, n+lwrk_wunmlq ) @@ -5830,12 +5832,12 @@ module stdlib_linalg_lapack_w minwrk = n + max( lwqp3, n+lwqrf, lwsvdj, lwunmqrm ) end if if ( lquery ) then - call stdlib_wgesvj( 'L', 'U', 'N', n,n, u, ldu, sva, n, a,lda, cdummy, -1, & + call stdlib_${ci}$gesvj( 'L', 'U', 'N', n,n, u, ldu, sva, n, a,lda, cdummy, -1, & rdummy, -1, ierr ) - lwrk_wgesvj = real( cdummy(1),KIND=qp) - call stdlib_wunmqr( 'L', 'N', m, n, n, a, lda, cdummy, u,ldu, cdummy, -1, & + lwrk_wgesvj = real( cdummy(1),KIND=${ck}$) + call stdlib_${ci}$unmqr( 'L', 'N', m, n, n, a, lda, cdummy, u,ldu, cdummy, -1, & ierr ) - lwrk_wunmqrm = real( cdummy(1),KIND=qp) + lwrk_wunmqrm = real( cdummy(1),KIND=${ck}$) if ( errest ) then optwrk = n + max( lwrk_wgeqp3, lwcon, n+lwrk_wgeqrf,lwrk_wgesvj, & lwrk_wunmqrm ) @@ -5886,28 +5888,28 @@ module stdlib_linalg_lapack_w if ( rowpiv .or. l2tran ) miniwrk = miniwrk + m end if if ( lquery ) then - call stdlib_wunmqr( 'L', 'N', m, n, n, a, lda, cdummy, u,ldu, cdummy, -1, & + call stdlib_${ci}$unmqr( 'L', 'N', m, n, n, a, lda, cdummy, u,ldu, cdummy, -1, & ierr ) - lwrk_wunmqrm = real( cdummy(1),KIND=qp) - call stdlib_wunmqr( 'L', 'N', n, n, n, a, lda, cdummy, u,ldu, cdummy, -1, & + lwrk_wunmqrm = real( cdummy(1),KIND=${ck}$) + call stdlib_${ci}$unmqr( 'L', 'N', n, n, n, a, lda, cdummy, u,ldu, cdummy, -1, & ierr ) - lwrk_wunmqr = real( cdummy(1),KIND=qp) + lwrk_wunmqr = real( cdummy(1),KIND=${ck}$) if ( .not. jracc ) then - call stdlib_wgeqp3( n,n, a, lda, iwork, cdummy,cdummy, -1,rdummy, ierr ) + call stdlib_${ci}$geqp3( n,n, a, lda, iwork, cdummy,cdummy, -1,rdummy, ierr ) - lwrk_wgeqp3n = real( cdummy(1),KIND=qp) - call stdlib_wgesvj( 'L', 'U', 'N', n, n, u, ldu, sva,n, v, ldv, cdummy, & + lwrk_wgeqp3n = real( cdummy(1),KIND=${ck}$) + call stdlib_${ci}$gesvj( 'L', 'U', 'N', n, n, u, ldu, sva,n, v, ldv, cdummy, & -1, rdummy, -1, ierr ) - lwrk_wgesvj = real( cdummy(1),KIND=qp) - call stdlib_wgesvj( 'U', 'U', 'N', n, n, u, ldu, sva,n, v, ldv, cdummy, & + lwrk_wgesvj = real( cdummy(1),KIND=${ck}$) + call stdlib_${ci}$gesvj( 'U', 'U', 'N', n, n, u, ldu, sva,n, v, ldv, cdummy, & -1, rdummy, -1, ierr ) - lwrk_wgesvju = real( cdummy(1),KIND=qp) - call stdlib_wgesvj( 'L', 'U', 'V', n, n, u, ldu, sva,n, v, ldv, cdummy, & + lwrk_wgesvju = real( cdummy(1),KIND=${ck}$) + call stdlib_${ci}$gesvj( 'L', 'U', 'V', n, n, u, ldu, sva,n, v, ldv, cdummy, & -1, rdummy, -1, ierr ) - lwrk_wgesvjv = real( cdummy(1),KIND=qp) - call stdlib_wunmlq( 'L', 'C', n, n, n, a, lda, cdummy,v, ldv, cdummy, -& + lwrk_wgesvjv = real( cdummy(1),KIND=${ck}$) + call stdlib_${ci}$unmlq( 'L', 'C', n, n, n, a, lda, cdummy,v, ldv, cdummy, -& 1, ierr ) - lwrk_wunmlq = real( cdummy(1),KIND=qp) + lwrk_wunmlq = real( cdummy(1),KIND=${ck}$) if ( errest ) then optwrk = max( n+lwrk_wgeqp3, n+lwcon,2*n+n**2+lwcon, 2*n+lwrk_wgeqrf,& 2*n+lwrk_wgeqp3n,2*n+n**2+n+lwrk_wgelqf,2*n+n**2+n+n**2+lwcon,2*n+& @@ -5920,15 +5922,15 @@ module stdlib_linalg_lapack_w lwrk_wunmlq,n+n**2+lwrk_wgesvju,n+lwrk_wunmqrm ) end if else - call stdlib_wgesvj( 'L', 'U', 'V', n, n, u, ldu, sva,n, v, ldv, cdummy, & + call stdlib_${ci}$gesvj( 'L', 'U', 'V', n, n, u, ldu, sva,n, v, ldv, cdummy, & -1, rdummy, -1, ierr ) - lwrk_wgesvjv = real( cdummy(1),KIND=qp) - call stdlib_wunmqr( 'L', 'N', n, n, n, cdummy, n, cdummy,v, ldv, cdummy,& + lwrk_wgesvjv = real( cdummy(1),KIND=${ck}$) + call stdlib_${ci}$unmqr( 'L', 'N', n, n, n, cdummy, n, cdummy,v, ldv, cdummy,& -1, ierr ) - lwrk_wunmqr = real( cdummy(1),KIND=qp) - call stdlib_wunmqr( 'L', 'N', m, n, n, a, lda, cdummy, u,ldu, cdummy, -& + lwrk_wunmqr = real( cdummy(1),KIND=${ck}$) + call stdlib_${ci}$unmqr( 'L', 'N', m, n, n, a, lda, cdummy, u,ldu, cdummy, -& 1, ierr ) - lwrk_wunmqrm = real( cdummy(1),KIND=qp) + lwrk_wunmqrm = real( cdummy(1),KIND=${ck}$) if ( errest ) then optwrk = max( n+lwrk_wgeqp3, n+lwcon,2*n+lwrk_wgeqrf, 2*n+n**2,2*n+& n**2+lwrk_wgesvjv,2*n+n**2+n+lwrk_wunmqr,n+lwrk_wunmqrm ) @@ -5973,23 +5975,23 @@ module stdlib_linalg_lapack_w if ( stdlib_lsame( jobu, 'F' ) ) n1 = m end if ! set numerical parameters - ! ! note: make sure stdlib_qlamch() does not fail on the target architecture. - epsln = stdlib_qlamch('EPSILON') - sfmin = stdlib_qlamch('SAFEMINIMUM') + ! ! note: make sure stdlib_${c2ri(ci)}$lamch() does not fail on the target architecture. + epsln = stdlib_${c2ri(ci)}$lamch('EPSILON') + sfmin = stdlib_${c2ri(ci)}$lamch('SAFEMINIMUM') small = sfmin / epsln - big = stdlib_qlamch('O') + big = stdlib_${c2ri(ci)}$lamch('O') ! big = one / sfmin ! initialize sva(1:n) = diag( ||a e_i||_2 )_1^n ! (!) if necessary, scale sva() to protect the largest norm from ! overflow. it is possible that this scaling pushes the smallest ! column norm left from the underflow threshold (extreme case). - scalem = one / sqrt(real(m,KIND=qp)*real(n,KIND=qp)) + scalem = one / sqrt(real(m,KIND=${ck}$)*real(n,KIND=${ck}$)) noscal = .true. goscal = .true. do p = 1, n aapp = zero aaqq = one - call stdlib_wlassq( m, a(1,p), 1, aapp, aaqq ) + call stdlib_${ci}$lassq( m, a(1,p), 1, aapp, aaqq ) if ( aapp > big ) then info = - 9 call stdlib_xerbla( 'ZGEJSV', -info ) @@ -6003,7 +6005,7 @@ module stdlib_linalg_lapack_w sva(p) = aapp * ( aaqq * scalem ) if ( goscal ) then goscal = .false. - call stdlib_qscal( p-1, scalem, sva, 1 ) + call stdlib_${c2ri(ci)}$scal( p-1, scalem, sva, 1 ) end if end if end do @@ -6017,8 +6019,8 @@ module stdlib_linalg_lapack_w ! quick return for zero m x n matrix ! #:) if ( aapp == zero ) then - if ( lsvec ) call stdlib_wlaset( 'G', m, n1, czero, cone, u, ldu ) - if ( rsvec ) call stdlib_wlaset( 'G', n, n, czero, cone, v, ldv ) + if ( lsvec ) call stdlib_${ci}$laset( 'G', m, n1, czero, cone, u, ldu ) + if ( rsvec ) call stdlib_${ci}$laset( 'G', n, n, czero, cone, v, ldv ) rwork(1) = one rwork(2) = one if ( errest ) rwork(3) = one @@ -6050,13 +6052,13 @@ module stdlib_linalg_lapack_w ! #:) if ( n == 1 ) then if ( lsvec ) then - call stdlib_wlascl( 'G',0,0,sva(1),scalem, m,1,a(1,1),lda,ierr ) - call stdlib_wlacpy( 'A', m, 1, a, lda, u, ldu ) + call stdlib_${ci}$lascl( 'G',0,0,sva(1),scalem, m,1,a(1,1),lda,ierr ) + call stdlib_${ci}$lacpy( 'A', m, 1, a, lda, u, ldu ) ! computing all m left singular vectors of the m x 1 matrix if ( n1 /= n ) then - call stdlib_wgeqrf( m, n, u,ldu, cwork, cwork(n+1),lwork-n,ierr ) - call stdlib_wungqr( m,n1,1, u,ldu,cwork,cwork(n+1),lwork-n,ierr ) - call stdlib_wcopy( m, a(1,1), 1, u(1,1), 1 ) + call stdlib_${ci}$geqrf( m, n, u,ldu, cwork, cwork(n+1),lwork-n,ierr ) + call stdlib_${ci}$ungqr( m,n1,1, u,ldu,cwork,cwork(n+1),lwork-n,ierr ) + call stdlib_${ci}$copy( m, a(1,1), 1, u(1,1), 1 ) end if end if if ( rsvec ) then @@ -6104,8 +6106,8 @@ module stdlib_linalg_lapack_w do p = 1, m xsc = zero temp1 = one - call stdlib_wlassq( n, a(p,1), lda, xsc, temp1 ) - ! stdlib_wlassq gets both the ell_2 and the ell_infinity norm + call stdlib_${ci}$lassq( n, a(p,1), lda, xsc, temp1 ) + ! stdlib_${ci}$lassq gets both the ell_2 and the ell_infinity norm ! in one pass through the vector rwork(m+p) = xsc * scalem rwork(p) = xsc * (scalem*sqrt(temp1)) @@ -6114,7 +6116,7 @@ module stdlib_linalg_lapack_w end do else do p = 1, m - rwork(m+p) = scalem*abs( a(p,stdlib_iwamax(n,a(p,1),lda)) ) + rwork(m+p) = scalem*abs( a(p,stdlib_i${ci}$amax(n,a(p,1),lda)) ) aatmax = max( aatmax, rwork(m+p) ) aatmin = min( aatmin, rwork(m+p) ) end do @@ -6131,14 +6133,14 @@ module stdlib_linalg_lapack_w if ( l2tran ) then xsc = zero temp1 = one - call stdlib_qlassq( n, sva, 1, xsc, temp1 ) + call stdlib_${c2ri(ci)}$lassq( n, sva, 1, xsc, temp1 ) temp1 = one / temp1 entra = zero do p = 1, n big1 = ( ( sva(p) / xsc )**2 ) * temp1 if ( big1 /= zero ) entra = entra + big1 * log(big1) end do - entra = - entra / log(real(n,KIND=qp)) + entra = - entra / log(real(n,KIND=${ck}$)) ! now, sva().^2/trace(a^* * a) is a point in the probability simplex. ! it is derived from the diagonal of a^* * a. do the same with the ! diagonal of a * a^*, compute the entropy of the corresponding @@ -6149,7 +6151,7 @@ module stdlib_linalg_lapack_w big1 = ( ( rwork(p) / xsc )**2 ) * temp1 if ( big1 /= zero ) entrat = entrat + big1 * log(big1) end do - entrat = - entrat / log(real(m,KIND=qp)) + entrat = - entrat / log(real(m,KIND=${ck}$)) ! analyze the entropies and decide a or a^*. smaller entropy ! usually means better input for the algorithm. transp = ( entrat < entra ) @@ -6190,25 +6192,25 @@ module stdlib_linalg_lapack_w ! scale the matrix so that its maximal singular value remains less ! than sqrt(big) -- the matrix is scaled so that its maximal column ! has euclidean norm equal to sqrt(big/n). the only reason to keep - ! sqrt(big) instead of big is the fact that stdlib_wgejsv uses lapack and + ! sqrt(big) instead of big is the fact that stdlib_${ci}$gejsv uses lapack and ! blas routines that, in some implementations, are not capable of ! working in the full interval [sfmin,big] and that they may provoke ! overflows in the intermediate results. if the singular values spread - ! from sfmin to big, then stdlib_wgesvj will compute them. so, in that case, - ! one should use stdlib_wgesvj instead of stdlib_wgejsv. + ! from sfmin to big, then stdlib_${ci}$gesvj will compute them. so, in that case, + ! one should use stdlib_${ci}$gesvj instead of stdlib_${ci}$gejsv. ! >> change in the april 2016 update: allow bigger range, i.e. the - ! largest column is allowed up to big/n and stdlib_wgesvj will do the rest. + ! largest column is allowed up to big/n and stdlib_${ci}$gesvj will do the rest. big1 = sqrt( big ) - temp1 = sqrt( big / real(n,KIND=qp) ) - ! temp1 = big/real(n,KIND=qp) - call stdlib_qlascl( 'G', 0, 0, aapp, temp1, n, 1, sva, n, ierr ) + temp1 = sqrt( big / real(n,KIND=${ck}$) ) + ! temp1 = big/real(n,KIND=${ck}$) + call stdlib_${c2ri(ci)}$lascl( 'G', 0, 0, aapp, temp1, n, 1, sva, n, ierr ) if ( aaqq > (aapp * sfmin) ) then aaqq = ( aaqq / aapp ) * temp1 else aaqq = ( aaqq * temp1 ) / aapp end if temp1 = temp1 * scalem - call stdlib_wlascl( 'G', 0, 0, aapp, temp1, m, n, a, lda, ierr ) + call stdlib_${ci}$lascl( 'G', 0, 0, aapp, temp1, m, n, a, lda, ierr ) ! to undo scaling at the end of this procedure, multiply the ! computed singular values with uscal2 / uscal1. uscal1 = temp1 @@ -6222,7 +6224,7 @@ module stdlib_linalg_lapack_w xsc = small ! now, if the condition number of a is too big, ! sigma_max(a) / sigma_min(a) > sqrt(big/n) * epsln / sfmin, - ! as a precaution measure, the full svd is computed using stdlib_wgesvj + ! as a precaution measure, the full svd is computed using stdlib_${ci}$gesvj ! with accumulated jacobi rotations. this provides numerically ! more robust computation, at the cost of slightly increased run ! time. depending on the concrete implementation of blas and lapack @@ -6235,7 +6237,7 @@ module stdlib_linalg_lapack_w if ( aaqq < xsc ) then do p = 1, n if ( sva(p) < xsc ) then - call stdlib_wlaset( 'A', m, 1, czero, czero, a(1,p), lda ) + call stdlib_${ci}$laset( 'A', m, 1, czero, czero, a(1,p), lda ) sva(p) = zero end if end do @@ -6253,7 +6255,7 @@ module stdlib_linalg_lapack_w iwoff = n end if do p = 1, m - 1 - q = stdlib_iqamax( m-p+1, rwork(m+p), 1 ) + p - 1 + q = stdlib_i${c2ri(ci)}$amax( m-p+1, rwork(m+p), 1 ) + p - 1 iwork(iwoff+p) = q if ( p /= q ) then temp1 = rwork(m+p) @@ -6261,32 +6263,32 @@ module stdlib_linalg_lapack_w rwork(m+q) = temp1 end if end do - call stdlib_wlaswp( n, a, lda, 1, m-1, iwork(iwoff+1), 1 ) + call stdlib_${ci}$laswp( n, a, lda, 1, m-1, iwork(iwoff+1), 1 ) end if ! end of the preparation phase (scaling, optional sorting and ! transposing, optional flushing of small columns). ! preconditioning ! if the full svd is needed, the right singular vectors are computed ! from a matrix equation, and for that we need theoretical analysis - ! of the businger-golub pivoting. so we use stdlib_wgeqp3 as the first rr qrf. + ! of the businger-golub pivoting. so we use stdlib_${ci}$geqp3 as the first rr qrf. ! in all other cases the first rr qrf can be chosen by other criteria ! (eg speed by replacing global with restricted window pivoting, such ! as in xgeqpx from toms # 782). good results will be obtained using ! xgeqpx with properly (!) chosen numerical parameters. - ! any improvement of stdlib_wgeqp3 improves overall performance of stdlib_wgejsv. + ! any improvement of stdlib_${ci}$geqp3 improves overall performance of stdlib_${ci}$gejsv. ! a * p1 = q1 * [ r1^* 0]^*: do p = 1, n ! All Columns Are Free Columns iwork(p) = 0 end do - call stdlib_wgeqp3( m, n, a, lda, iwork, cwork, cwork(n+1), lwork-n,rwork, ierr ) + call stdlib_${ci}$geqp3( m, n, a, lda, iwork, cwork, cwork(n+1), lwork-n,rwork, ierr ) ! the upper triangular matrix r1 from the first qrf is inspected for ! rank deficiency and possibilities for deflation, or possible ! ill-conditioning. depending on the user specified flag l2rank, ! the procedure explores possibilities to reduce the numerical ! rank by inspecting the computed upper triangular factor. if - ! l2rank or l2aber are up, then stdlib_wgejsv will compute the svd of + ! l2rank or l2aber are up, then stdlib_${ci}$gejsv will compute the svd of ! a + da, where ||da|| <= f(m,n)*epsln. nr = 1 if ( l2aber ) then @@ -6294,7 +6296,7 @@ module stdlib_linalg_lapack_w ! sigma_i < n*epsln*||a|| are flushed to zero. this is an ! aggressive enforcement of lower numerical rank by introducing a ! backward error of the order of n*epsln*||a||. - temp1 = sqrt(real(n,KIND=qp))*epsln + temp1 = sqrt(real(n,KIND=${ck}$))*epsln do p = 2, n if ( abs(a(p,p)) >= (temp1*abs(a(1,1))) ) then nr = nr + 1 @@ -6337,7 +6339,7 @@ module stdlib_linalg_lapack_w temp1 = abs(a(p,p)) / sva(iwork(p)) maxprj = min( maxprj, temp1 ) end do - if ( maxprj**2 >= one - real(n,KIND=qp)*epsln ) almort = .true. + if ( maxprj**2 >= one - real(n,KIND=${ck}$)*epsln ) almort = .true. end if sconda = - one condr1 = - one @@ -6346,41 +6348,41 @@ module stdlib_linalg_lapack_w if ( n == nr ) then if ( rsvec ) then ! V Is Available As Workspace - call stdlib_wlacpy( 'U', n, n, a, lda, v, ldv ) + call stdlib_${ci}$lacpy( 'U', n, n, a, lda, v, ldv ) do p = 1, n temp1 = sva(iwork(p)) - call stdlib_wdscal( p, one/temp1, v(1,p), 1 ) + call stdlib_${ci}$dscal( p, one/temp1, v(1,p), 1 ) end do if ( lsvec )then - call stdlib_wpocon( 'U', n, v, ldv, one, temp1,cwork(n+1), rwork, ierr ) + call stdlib_${ci}$pocon( 'U', n, v, ldv, one, temp1,cwork(n+1), rwork, ierr ) else - call stdlib_wpocon( 'U', n, v, ldv, one, temp1,cwork, rwork, ierr ) + call stdlib_${ci}$pocon( 'U', n, v, ldv, one, temp1,cwork, rwork, ierr ) end if else if ( lsvec ) then ! U Is Available As Workspace - call stdlib_wlacpy( 'U', n, n, a, lda, u, ldu ) + call stdlib_${ci}$lacpy( 'U', n, n, a, lda, u, ldu ) do p = 1, n temp1 = sva(iwork(p)) - call stdlib_wdscal( p, one/temp1, u(1,p), 1 ) + call stdlib_${ci}$dscal( p, one/temp1, u(1,p), 1 ) end do - call stdlib_wpocon( 'U', n, u, ldu, one, temp1,cwork(n+1), rwork, ierr ) + call stdlib_${ci}$pocon( 'U', n, u, ldu, one, temp1,cwork(n+1), rwork, ierr ) else - call stdlib_wlacpy( 'U', n, n, a, lda, cwork, n ) - ! [] call stdlib_wlacpy( 'u', n, n, a, lda, cwork(n+1), n ) + call stdlib_${ci}$lacpy( 'U', n, n, a, lda, cwork, n ) + ! [] call stdlib_${ci}$lacpy( 'u', n, n, a, lda, cwork(n+1), n ) ! change: here index shifted by n to the left, cwork(1:n) ! not needed for sigma only computation do p = 1, n temp1 = sva(iwork(p)) - ! [] call stdlib_wdscal( p, one/temp1, cwork(n+(p-1)*n+1), 1 ) - call stdlib_wdscal( p, one/temp1, cwork((p-1)*n+1), 1 ) + ! [] call stdlib_${ci}$dscal( p, one/temp1, cwork(n+(p-1)*n+1), 1 ) + call stdlib_${ci}$dscal( p, one/temp1, cwork((p-1)*n+1), 1 ) end do ! The Columns Of R Are Scaled To Have Unit Euclidean Lengths - ! [] call stdlib_wpocon( 'u', n, cwork(n+1), n, one, temp1, + ! [] call stdlib_${ci}$pocon( 'u', n, cwork(n+1), n, one, temp1, ! [] $ cwork(n+n*n+1), rwork, ierr ) - call stdlib_wpocon( 'U', n, cwork, n, one, temp1,cwork(n*n+1), rwork, ierr ) + call stdlib_${ci}$pocon( 'U', n, cwork, n, one, temp1,cwork(n*n+1), rwork, ierr ) end if if ( temp1 /= zero ) then @@ -6401,8 +6403,8 @@ module stdlib_linalg_lapack_w ! singular values only ! .. transpose a(1:nr,1:n) do p = 1, min( n-1, nr ) - call stdlib_wcopy( n-p, a(p,p+1), lda, a(p+1,p), 1 ) - call stdlib_wlacgv( n-p+1, a(p,p), 1 ) + call stdlib_${ci}$copy( n-p, a(p,p+1), lda, a(p+1,p), 1 ) + call stdlib_${ci}$lacgv( n-p+1, a(p,p), 1 ) end do if ( nr == n ) a(n,n) = conjg(a(n,n)) ! the following two do-loops introduce small relative perturbation @@ -6419,9 +6421,9 @@ module stdlib_linalg_lapack_w if ( .not. almort ) then if ( l2pert ) then ! xsc = sqrt(small) - xsc = epsln / real(n,KIND=qp) + xsc = epsln / real(n,KIND=${ck}$) do q = 1, nr - ctemp = cmplx(xsc*abs(a(q,q)),zero,KIND=qp) + ctemp = cmplx(xsc*abs(a(q,q)),zero,KIND=${ck}$) do p = 1, n if ( ( (p>q) .and. (abs(a(p,q))<=temp1) ).or. ( p < q ) )a(p,q) = & ctemp @@ -6429,14 +6431,14 @@ module stdlib_linalg_lapack_w end do end do else - if (nr>1) call stdlib_wlaset( 'U', nr-1,nr-1, czero,czero, a(1,2),lda ) + if (nr>1) call stdlib_${ci}$laset( 'U', nr-1,nr-1, czero,czero, a(1,2),lda ) end if ! Second Preconditioning Using The Qr Factorization - call stdlib_wgeqrf( n,nr, a,lda, cwork, cwork(n+1),lwork-n, ierr ) + call stdlib_${ci}$geqrf( n,nr, a,lda, cwork, cwork(n+1),lwork-n, ierr ) ! And Transpose Upper To Lower Triangular do p = 1, nr - 1 - call stdlib_wcopy( nr-p, a(p,p+1), lda, a(p+1,p), 1 ) - call stdlib_wlacgv( nr-p+1, a(p,p), 1 ) + call stdlib_${ci}$copy( nr-p, a(p,p+1), lda, a(p+1,p), 1 ) + call stdlib_${ci}$lacgv( nr-p+1, a(p,p), 1 ) end do end if ! row-cyclic jacobi svd algorithm with column pivoting @@ -6444,9 +6446,9 @@ module stdlib_linalg_lapack_w ! to drown denormals if ( l2pert ) then ! xsc = sqrt(small) - xsc = epsln / real(n,KIND=qp) + xsc = epsln / real(n,KIND=${ck}$) do q = 1, nr - ctemp = cmplx(xsc*abs(a(q,q)),zero,KIND=qp) + ctemp = cmplx(xsc*abs(a(q,q)),zero,KIND=${ck}$) do p = 1, nr if ( ( (p>q) .and. (abs(a(p,q))<=temp1) ).or. ( p < q ) )a(p,q) = & ctemp @@ -6454,12 +6456,12 @@ module stdlib_linalg_lapack_w end do end do else - if (nr>1) call stdlib_wlaset( 'U', nr-1, nr-1, czero, czero, a(1,2), lda ) + if (nr>1) call stdlib_${ci}$laset( 'U', nr-1, nr-1, czero, czero, a(1,2), lda ) end if ! .. and one-sided jacobi rotations are started on a lower ! triangular matrix (plus perturbation which is ignored in ! the part which destroys triangular form (confusing?!)) - call stdlib_wgesvj( 'L', 'N', 'N', nr, nr, a, lda, sva,n, v, ldv, cwork, lwork, & + call stdlib_${ci}$gesvj( 'L', 'N', 'N', nr, nr, a, lda, sva,n, v, ldv, cwork, lwork, & rwork, lrwork, info ) scalem = rwork(1) numrank = nint(rwork(2),KIND=ilp) @@ -6469,92 +6471,92 @@ module stdlib_linalg_lapack_w if ( almort ) then ! In This Case Nr Equals N do p = 1, nr - call stdlib_wcopy( n-p+1, a(p,p), lda, v(p,p), 1 ) - call stdlib_wlacgv( n-p+1, v(p,p), 1 ) + call stdlib_${ci}$copy( n-p+1, a(p,p), lda, v(p,p), 1 ) + call stdlib_${ci}$lacgv( n-p+1, v(p,p), 1 ) end do - if (nr>1) call stdlib_wlaset( 'U', nr-1,nr-1, czero, czero, v(1,2), ldv ) - call stdlib_wgesvj( 'L','U','N', n, nr, v, ldv, sva, nr, a, lda,cwork, lwork, & + if (nr>1) call stdlib_${ci}$laset( 'U', nr-1,nr-1, czero, czero, v(1,2), ldv ) + call stdlib_${ci}$gesvj( 'L','U','N', n, nr, v, ldv, sva, nr, a, lda,cwork, lwork, & rwork, lrwork, info ) scalem = rwork(1) numrank = nint(rwork(2),KIND=ilp) else ! .. two more qr factorizations ( one qrf is not enough, two require ! accumulated product of jacobi rotations, three are perfect ) - if (nr>1) call stdlib_wlaset( 'L', nr-1,nr-1, czero, czero, a(2,1), lda ) - call stdlib_wgelqf( nr,n, a, lda, cwork, cwork(n+1), lwork-n, ierr) - call stdlib_wlacpy( 'L', nr, nr, a, lda, v, ldv ) - if (nr>1) call stdlib_wlaset( 'U', nr-1,nr-1, czero, czero, v(1,2), ldv ) - call stdlib_wgeqrf( nr, nr, v, ldv, cwork(n+1), cwork(2*n+1),lwork-2*n, ierr ) + if (nr>1) call stdlib_${ci}$laset( 'L', nr-1,nr-1, czero, czero, a(2,1), lda ) + call stdlib_${ci}$gelqf( nr,n, a, lda, cwork, cwork(n+1), lwork-n, ierr) + call stdlib_${ci}$lacpy( 'L', nr, nr, a, lda, v, ldv ) + if (nr>1) call stdlib_${ci}$laset( 'U', nr-1,nr-1, czero, czero, v(1,2), ldv ) + call stdlib_${ci}$geqrf( nr, nr, v, ldv, cwork(n+1), cwork(2*n+1),lwork-2*n, ierr ) do p = 1, nr - call stdlib_wcopy( nr-p+1, v(p,p), ldv, v(p,p), 1 ) - call stdlib_wlacgv( nr-p+1, v(p,p), 1 ) + call stdlib_${ci}$copy( nr-p+1, v(p,p), ldv, v(p,p), 1 ) + call stdlib_${ci}$lacgv( nr-p+1, v(p,p), 1 ) end do - if (nr>1) call stdlib_wlaset('U', nr-1, nr-1, czero, czero, v(1,2), ldv) - call stdlib_wgesvj( 'L', 'U','N', nr, nr, v,ldv, sva, nr, u,ldu, cwork(n+1), & + if (nr>1) call stdlib_${ci}$laset('U', nr-1, nr-1, czero, czero, v(1,2), ldv) + call stdlib_${ci}$gesvj( 'L', 'U','N', nr, nr, v,ldv, sva, nr, u,ldu, cwork(n+1), & lwork-n, rwork, lrwork, info ) scalem = rwork(1) numrank = nint(rwork(2),KIND=ilp) if ( nr < n ) then - call stdlib_wlaset( 'A',n-nr, nr, czero,czero, v(nr+1,1), ldv ) - call stdlib_wlaset( 'A',nr, n-nr, czero,czero, v(1,nr+1), ldv ) - call stdlib_wlaset( 'A',n-nr,n-nr,czero,cone, v(nr+1,nr+1),ldv ) + call stdlib_${ci}$laset( 'A',n-nr, nr, czero,czero, v(nr+1,1), ldv ) + call stdlib_${ci}$laset( 'A',nr, n-nr, czero,czero, v(1,nr+1), ldv ) + call stdlib_${ci}$laset( 'A',n-nr,n-nr,czero,cone, v(nr+1,nr+1),ldv ) end if - call stdlib_wunmlq( 'L', 'C', n, n, nr, a, lda, cwork,v, ldv, cwork(n+1), lwork-n, & + call stdlib_${ci}$unmlq( 'L', 'C', n, n, nr, a, lda, cwork,v, ldv, cwork(n+1), lwork-n, & ierr ) end if ! Permute The Rows Of V ! do 8991 p = 1, n - ! call stdlib_wcopy( n, v(p,1), ldv, a(iwork(p),1), lda ) + ! call stdlib_${ci}$copy( n, v(p,1), ldv, a(iwork(p),1), lda ) 8991 continue - ! call stdlib_wlacpy( 'all', n, n, a, lda, v, ldv ) - call stdlib_wlapmr( .false., n, n, v, ldv, iwork ) + ! call stdlib_${ci}$lacpy( 'all', n, n, a, lda, v, ldv ) + call stdlib_${ci}$lapmr( .false., n, n, v, ldv, iwork ) if ( transp ) then - call stdlib_wlacpy( 'A', n, n, v, ldv, u, ldu ) + call stdlib_${ci}$lacpy( 'A', n, n, v, ldv, u, ldu ) end if else if ( jracc .and. (.not. lsvec) .and. ( nr== n ) ) then - if (n>1) call stdlib_wlaset( 'L', n-1,n-1, czero, czero, a(2,1), lda ) - call stdlib_wgesvj( 'U','N','V', n, n, a, lda, sva, n, v, ldv,cwork, lwork, rwork, & + if (n>1) call stdlib_${ci}$laset( 'L', n-1,n-1, czero, czero, a(2,1), lda ) + call stdlib_${ci}$gesvj( 'U','N','V', n, n, a, lda, sva, n, v, ldv,cwork, lwork, rwork, & lrwork, info ) scalem = rwork(1) numrank = nint(rwork(2),KIND=ilp) - call stdlib_wlapmr( .false., n, n, v, ldv, iwork ) + call stdlib_${ci}$lapmr( .false., n, n, v, ldv, iwork ) else if ( lsvec .and. ( .not. rsvec ) ) then ! Singular Values And Left Singular Vectors ! Second Preconditioning Step To Avoid Need To Accumulate ! jacobi rotations in the jacobi iterations. do p = 1, nr - call stdlib_wcopy( n-p+1, a(p,p), lda, u(p,p), 1 ) - call stdlib_wlacgv( n-p+1, u(p,p), 1 ) + call stdlib_${ci}$copy( n-p+1, a(p,p), lda, u(p,p), 1 ) + call stdlib_${ci}$lacgv( n-p+1, u(p,p), 1 ) end do - if (nr>1) call stdlib_wlaset( 'U', nr-1, nr-1, czero, czero, u(1,2), ldu ) - call stdlib_wgeqrf( n, nr, u, ldu, cwork(n+1), cwork(2*n+1),lwork-2*n, ierr ) + if (nr>1) call stdlib_${ci}$laset( 'U', nr-1, nr-1, czero, czero, u(1,2), ldu ) + call stdlib_${ci}$geqrf( n, nr, u, ldu, cwork(n+1), cwork(2*n+1),lwork-2*n, ierr ) do p = 1, nr - 1 - call stdlib_wcopy( nr-p, u(p,p+1), ldu, u(p+1,p), 1 ) - call stdlib_wlacgv( n-p+1, u(p,p), 1 ) + call stdlib_${ci}$copy( nr-p, u(p,p+1), ldu, u(p+1,p), 1 ) + call stdlib_${ci}$lacgv( n-p+1, u(p,p), 1 ) end do - if (nr>1) call stdlib_wlaset( 'U', nr-1, nr-1, czero, czero, u(1,2), ldu ) - call stdlib_wgesvj( 'L', 'U', 'N', nr,nr, u, ldu, sva, nr, a,lda, cwork(n+1), lwork-& + if (nr>1) call stdlib_${ci}$laset( 'U', nr-1, nr-1, czero, czero, u(1,2), ldu ) + call stdlib_${ci}$gesvj( 'L', 'U', 'N', nr,nr, u, ldu, sva, nr, a,lda, cwork(n+1), lwork-& n, rwork, lrwork, info ) scalem = rwork(1) numrank = nint(rwork(2),KIND=ilp) if ( nr < m ) then - call stdlib_wlaset( 'A', m-nr, nr,czero, czero, u(nr+1,1), ldu ) + call stdlib_${ci}$laset( 'A', m-nr, nr,czero, czero, u(nr+1,1), ldu ) if ( nr < n1 ) then - call stdlib_wlaset( 'A',nr, n1-nr, czero, czero, u(1,nr+1),ldu ) - call stdlib_wlaset( 'A',m-nr,n1-nr,czero,cone,u(nr+1,nr+1),ldu ) + call stdlib_${ci}$laset( 'A',nr, n1-nr, czero, czero, u(1,nr+1),ldu ) + call stdlib_${ci}$laset( 'A',m-nr,n1-nr,czero,cone,u(nr+1,nr+1),ldu ) end if end if - call stdlib_wunmqr( 'L', 'N', m, n1, n, a, lda, cwork, u,ldu, cwork(n+1), lwork-n, & + call stdlib_${ci}$unmqr( 'L', 'N', m, n1, n, a, lda, cwork, u,ldu, cwork(n+1), lwork-n, & ierr ) - if ( rowpiv )call stdlib_wlaswp( n1, u, ldu, 1, m-1, iwork(iwoff+1), -1 ) + if ( rowpiv )call stdlib_${ci}$laswp( n1, u, ldu, 1, m-1, iwork(iwoff+1), -1 ) do p = 1, n1 - xsc = one / stdlib_qznrm2( m, u(1,p), 1 ) - call stdlib_wdscal( m, xsc, u(1,p), 1 ) + xsc = one / stdlib_${c2ri(ci)}$znrm2( m, u(1,p), 1 ) + call stdlib_${ci}$dscal( m, xsc, u(1,p), 1 ) end do if ( transp ) then - call stdlib_wlacpy( 'A', n, n, u, ldu, v, ldv ) + call stdlib_${ci}$lacpy( 'A', n, n, u, ldu, v, ldv ) end if else ! Full Svd @@ -6565,10 +6567,10 @@ module stdlib_linalg_lapack_w ! equivalent to an lqf call. since in many libraries the qrf ! seems to be better optimized than the lqf, we do explicit ! transpose and use the qrf. this is subject to changes in an - ! optimized implementation of stdlib_wgejsv. + ! optimized implementation of stdlib_${ci}$gejsv. do p = 1, nr - call stdlib_wcopy( n-p+1, a(p,p), lda, v(p,p), 1 ) - call stdlib_wlacgv( n-p+1, v(p,p), 1 ) + call stdlib_${ci}$copy( n-p+1, a(p,p), lda, v(p,p), 1 ) + call stdlib_${ci}$lacgv( n-p+1, v(p,p), 1 ) end do ! The Following Two Loops Perturb Small Entries To Avoid ! denormals in the second qr factorization, where they are @@ -6584,7 +6586,7 @@ module stdlib_linalg_lapack_w if ( l2pert ) then xsc = sqrt(small) do q = 1, nr - ctemp = cmplx(xsc*abs( v(q,q) ),zero,KIND=qp) + ctemp = cmplx(xsc*abs( v(q,q) ),zero,KIND=${ck}$) do p = 1, n if ( ( p > q ) .and. ( abs(v(p,q)) <= temp1 ).or. ( p < q ) )v(p,q) = & ctemp @@ -6593,49 +6595,49 @@ module stdlib_linalg_lapack_w end do end do else - if (nr>1) call stdlib_wlaset( 'U', nr-1, nr-1, czero, czero, v(1,2), ldv ) + if (nr>1) call stdlib_${ci}$laset( 'U', nr-1, nr-1, czero, czero, v(1,2), ldv ) end if ! estimate the row scaled condition number of r1 ! (if r1 is rectangular, n > nr, then the condition number ! of the leading nr x nr submatrix is estimated.) - call stdlib_wlacpy( 'L', nr, nr, v, ldv, cwork(2*n+1), nr ) + call stdlib_${ci}$lacpy( 'L', nr, nr, v, ldv, cwork(2*n+1), nr ) do p = 1, nr - temp1 = stdlib_qznrm2(nr-p+1,cwork(2*n+(p-1)*nr+p),1) - call stdlib_wdscal(nr-p+1,one/temp1,cwork(2*n+(p-1)*nr+p),1) + temp1 = stdlib_${c2ri(ci)}$znrm2(nr-p+1,cwork(2*n+(p-1)*nr+p),1) + call stdlib_${ci}$dscal(nr-p+1,one/temp1,cwork(2*n+(p-1)*nr+p),1) end do - call stdlib_wpocon('L',nr,cwork(2*n+1),nr,one,temp1,cwork(2*n+nr*nr+1),rwork,& + call stdlib_${ci}$pocon('L',nr,cwork(2*n+1),nr,one,temp1,cwork(2*n+nr*nr+1),rwork,& ierr) condr1 = one / sqrt(temp1) ! Here Need A Second Opinion On The Condition Number ! Then Assume Worst Case Scenario - ! r1 is ok for inverse <=> condr1 < real(n,KIND=qp) - ! more conservative <=> condr1 < sqrt(real(n,KIND=qp)) - cond_ok = sqrt(sqrt(real(nr,KIND=qp))) + ! r1 is ok for inverse <=> condr1 < real(n,KIND=${ck}$) + ! more conservative <=> condr1 < sqrt(real(n,KIND=${ck}$)) + cond_ok = sqrt(sqrt(real(nr,KIND=${ck}$))) ! [tp] cond_ok is a tuning parameter. if ( condr1 < cond_ok ) then ! .. the second qrf without pivoting. note: in an optimized ! implementation, this qrf should be implemented as the qrf ! of a lower triangular matrix. ! r1^* = q2 * r2 - call stdlib_wgeqrf( n, nr, v, ldv, cwork(n+1), cwork(2*n+1),lwork-2*n, ierr ) + call stdlib_${ci}$geqrf( n, nr, v, ldv, cwork(n+1), cwork(2*n+1),lwork-2*n, ierr ) if ( l2pert ) then xsc = sqrt(small)/epsln do p = 2, nr do q = 1, p - 1 - ctemp=cmplx(xsc*min(abs(v(p,p)),abs(v(q,q))),zero,KIND=qp) + ctemp=cmplx(xsc*min(abs(v(p,p)),abs(v(q,q))),zero,KIND=${ck}$) if ( abs(v(q,p)) <= temp1 )v(q,p) = ctemp ! $ v(q,p) = temp1 * ( v(q,p) / abs(v(q,p)) ) end do end do end if - if ( nr /= n )call stdlib_wlacpy( 'A', n, nr, v, ldv, cwork(2*n+1), n ) + if ( nr /= n )call stdlib_${ci}$lacpy( 'A', n, nr, v, ldv, cwork(2*n+1), n ) ! .. save ... ! This Transposed Copy Should Be Better Than Naive do p = 1, nr - 1 - call stdlib_wcopy( nr-p, v(p,p+1), ldv, v(p+1,p), 1 ) - call stdlib_wlacgv(nr-p+1, v(p,p), 1 ) + call stdlib_${ci}$copy( nr-p, v(p,p+1), ldv, v(p+1,p), 1 ) + call stdlib_${ci}$lacgv(nr-p+1, v(p,p), 1 ) end do v(nr,nr)=conjg(v(nr,nr)) condr2 = condr1 @@ -6643,50 +6645,50 @@ module stdlib_linalg_lapack_w ! .. ill-conditioned case: second qrf with pivoting ! note that windowed pivoting would be equally good ! numerically, and more run-time efficient. so, in - ! an optimal implementation, the next call to stdlib_wgeqp3 + ! an optimal implementation, the next call to stdlib_${ci}$geqp3 ! should be replaced with eg. call zgeqpx (acm toms #782) ! with properly (carefully) chosen parameters. ! r1^* * p2 = q2 * r2 do p = 1, nr iwork(n+p) = 0 end do - call stdlib_wgeqp3( n, nr, v, ldv, iwork(n+1), cwork(n+1),cwork(2*n+1), lwork-& + call stdlib_${ci}$geqp3( n, nr, v, ldv, iwork(n+1), cwork(n+1),cwork(2*n+1), lwork-& 2*n, rwork, ierr ) - ! * call stdlib_wgeqrf( n, nr, v, ldv, cwork(n+1), cwork(2*n+1), + ! * call stdlib_${ci}$geqrf( n, nr, v, ldv, cwork(n+1), cwork(2*n+1), ! * $ lwork-2*n, ierr ) if ( l2pert ) then xsc = sqrt(small) do p = 2, nr do q = 1, p - 1 - ctemp=cmplx(xsc*min(abs(v(p,p)),abs(v(q,q))),zero,KIND=qp) + ctemp=cmplx(xsc*min(abs(v(p,p)),abs(v(q,q))),zero,KIND=${ck}$) if ( abs(v(q,p)) <= temp1 )v(q,p) = ctemp ! $ v(q,p) = temp1 * ( v(q,p) / abs(v(q,p)) ) end do end do end if - call stdlib_wlacpy( 'A', n, nr, v, ldv, cwork(2*n+1), n ) + call stdlib_${ci}$lacpy( 'A', n, nr, v, ldv, cwork(2*n+1), n ) if ( l2pert ) then xsc = sqrt(small) do p = 2, nr do q = 1, p - 1 - ctemp=cmplx(xsc*min(abs(v(p,p)),abs(v(q,q))),zero,KIND=qp) + ctemp=cmplx(xsc*min(abs(v(p,p)),abs(v(q,q))),zero,KIND=${ck}$) ! v(p,q) = - temp1*( v(q,p) / abs(v(q,p)) ) v(p,q) = - ctemp end do end do else - if (nr>1) call stdlib_wlaset( 'L',nr-1,nr-1,czero,czero,v(2,1),ldv ) + if (nr>1) call stdlib_${ci}$laset( 'L',nr-1,nr-1,czero,czero,v(2,1),ldv ) end if ! now, compute r2 = l3 * q3, the lq factorization. - call stdlib_wgelqf( nr, nr, v, ldv, cwork(2*n+n*nr+1),cwork(2*n+n*nr+nr+1), & + call stdlib_${ci}$gelqf( nr, nr, v, ldv, cwork(2*n+n*nr+1),cwork(2*n+n*nr+nr+1), & lwork-2*n-n*nr-nr, ierr ) ! And Estimate The Condition Number - call stdlib_wlacpy( 'L',nr,nr,v,ldv,cwork(2*n+n*nr+nr+1),nr ) + call stdlib_${ci}$lacpy( 'L',nr,nr,v,ldv,cwork(2*n+n*nr+nr+1),nr ) do p = 1, nr - temp1 = stdlib_qznrm2( p, cwork(2*n+n*nr+nr+p), nr ) - call stdlib_wdscal( p, one/temp1, cwork(2*n+n*nr+nr+p), nr ) + temp1 = stdlib_${c2ri(ci)}$znrm2( p, cwork(2*n+n*nr+nr+p), nr ) + call stdlib_${ci}$dscal( p, one/temp1, cwork(2*n+n*nr+nr+p), nr ) end do - call stdlib_wpocon( 'L',nr,cwork(2*n+n*nr+nr+1),nr,one,temp1,cwork(2*n+n*nr+& + call stdlib_${ci}$pocon( 'L',nr,cwork(2*n+n*nr+nr+1),nr,one,temp1,cwork(2*n+n*nr+& nr+nr*nr+1),rwork,ierr ) condr2 = one / sqrt(temp1) if ( condr2 >= cond_ok ) then @@ -6694,7 +6696,7 @@ module stdlib_linalg_lapack_w ! (this overwrites the copy of r2, as it will not be ! needed in this branch, but it does not overwritte the ! huseholder vectors of q2.). - call stdlib_wlacpy( 'U', nr, nr, v, ldv, cwork(2*n+1), n ) + call stdlib_${ci}$lacpy( 'U', nr, nr, v, ldv, cwork(2*n+1), n ) ! And The Rest Of The Information On Q3 Is In ! work(2*n+n*nr+1:2*n+n*nr+n) end if @@ -6709,40 +6711,40 @@ module stdlib_linalg_lapack_w end do end do else - if (nr>1) call stdlib_wlaset( 'U', nr-1,nr-1, czero,czero, v(1,2), ldv ) + if (nr>1) call stdlib_${ci}$laset( 'U', nr-1,nr-1, czero,czero, v(1,2), ldv ) end if ! second preconditioning finished; continue with jacobi svd ! the input matrix is lower trinagular. ! recover the right singular vectors as solution of a well ! conditioned triangular matrix equation. if ( condr1 < cond_ok ) then - call stdlib_wgesvj( 'L','U','N',nr,nr,v,ldv,sva,nr,u, ldu,cwork(2*n+n*nr+nr+1)& + call stdlib_${ci}$gesvj( 'L','U','N',nr,nr,v,ldv,sva,nr,u, ldu,cwork(2*n+n*nr+nr+1)& ,lwork-2*n-n*nr-nr,rwork,lrwork, info ) scalem = rwork(1) numrank = nint(rwork(2),KIND=ilp) do p = 1, nr - call stdlib_wcopy( nr, v(1,p), 1, u(1,p), 1 ) - call stdlib_wdscal( nr, sva(p), v(1,p), 1 ) + call stdlib_${ci}$copy( nr, v(1,p), 1, u(1,p), 1 ) + call stdlib_${ci}$dscal( nr, sva(p), v(1,p), 1 ) end do ! Pick The Right Matrix Equation And Solve It if ( nr == n ) then ! :)) .. best case, r1 is inverted. the solution of this matrix ! equation is q2*v2 = the product of the jacobi rotations - ! used in stdlib_wgesvj, premultiplied with the orthogonal matrix + ! used in stdlib_${ci}$gesvj, premultiplied with the orthogonal matrix ! from the second qr factorization. - call stdlib_wtrsm('L','U','N','N', nr,nr,cone, a,lda, v,ldv) + call stdlib_${ci}$trsm('L','U','N','N', nr,nr,cone, a,lda, v,ldv) else ! .. r1 is well conditioned, but non-square. adjoint of r2 ! is inverted to get the product of the jacobi rotations - ! used in stdlib_wgesvj. the q-factor from the second qr + ! used in stdlib_${ci}$gesvj. the q-factor from the second qr ! factorization is then built in explicitly. - call stdlib_wtrsm('L','U','C','N',nr,nr,cone,cwork(2*n+1),n,v,ldv) + call stdlib_${ci}$trsm('L','U','C','N',nr,nr,cone,cwork(2*n+1),n,v,ldv) if ( nr < n ) then - call stdlib_wlaset('A',n-nr,nr,czero,czero,v(nr+1,1),ldv) - call stdlib_wlaset('A',nr,n-nr,czero,czero,v(1,nr+1),ldv) - call stdlib_wlaset('A',n-nr,n-nr,czero,cone,v(nr+1,nr+1),ldv) + call stdlib_${ci}$laset('A',n-nr,nr,czero,czero,v(nr+1,1),ldv) + call stdlib_${ci}$laset('A',nr,n-nr,czero,czero,v(1,nr+1),ldv) + call stdlib_${ci}$laset('A',n-nr,n-nr,czero,cone,v(nr+1,nr+1),ldv) end if - call stdlib_wunmqr('L','N',n,n,nr,cwork(2*n+1),n,cwork(n+1),v,ldv,cwork(& + call stdlib_${ci}$unmqr('L','N',n,n,nr,cwork(2*n+1),n,cwork(n+1),v,ldv,cwork(& 2*n+n*nr+nr+1),lwork-2*n-n*nr-nr,ierr) end if else if ( condr2 < cond_ok ) then @@ -6750,15 +6752,15 @@ module stdlib_linalg_lapack_w ! is q3^* * v3 = the product of the jacobi rotations (appplied to ! the lower triangular l3 from the lq factorization of ! r2=l3*q3), pre-multiplied with the transposed q3. - call stdlib_wgesvj( 'L', 'U', 'N', nr, nr, v, ldv, sva, nr, u,ldu, cwork(2*n+& + call stdlib_${ci}$gesvj( 'L', 'U', 'N', nr, nr, v, ldv, sva, nr, u,ldu, cwork(2*n+& n*nr+nr+1), lwork-2*n-n*nr-nr,rwork, lrwork, info ) scalem = rwork(1) numrank = nint(rwork(2),KIND=ilp) do p = 1, nr - call stdlib_wcopy( nr, v(1,p), 1, u(1,p), 1 ) - call stdlib_wdscal( nr, sva(p), u(1,p), 1 ) + call stdlib_${ci}$copy( nr, v(1,p), 1, u(1,p), 1 ) + call stdlib_${ci}$dscal( nr, sva(p), u(1,p), 1 ) end do - call stdlib_wtrsm('L','U','N','N',nr,nr,cone,cwork(2*n+1),n,u,ldu) + call stdlib_${ci}$trsm('L','U','N','N',nr,nr,cone,cwork(2*n+1),n,u,ldu) ! Apply The Permutation From The Second Qr Factorization do q = 1, nr do p = 1, nr @@ -6769,11 +6771,11 @@ module stdlib_linalg_lapack_w end do end do if ( nr < n ) then - call stdlib_wlaset( 'A',n-nr,nr,czero,czero,v(nr+1,1),ldv ) - call stdlib_wlaset( 'A',nr,n-nr,czero,czero,v(1,nr+1),ldv ) - call stdlib_wlaset('A',n-nr,n-nr,czero,cone,v(nr+1,nr+1),ldv) + call stdlib_${ci}$laset( 'A',n-nr,nr,czero,czero,v(nr+1,1),ldv ) + call stdlib_${ci}$laset( 'A',nr,n-nr,czero,czero,v(1,nr+1),ldv ) + call stdlib_${ci}$laset('A',n-nr,n-nr,czero,cone,v(nr+1,nr+1),ldv) end if - call stdlib_wunmqr( 'L','N',n,n,nr,cwork(2*n+1),n,cwork(n+1),v,ldv,cwork(2*n+& + call stdlib_${ci}$unmqr( 'L','N',n,n,nr,cwork(2*n+1),n,cwork(n+1),v,ldv,cwork(2*n+& n*nr+nr+1),lwork-2*n-n*nr-nr,ierr ) else ! last line of defense. @@ -6784,21 +6786,21 @@ module stdlib_linalg_lapack_w ! is set very close to one (which is unnecessary). normally, ! this branch should never be executed, but in rare cases of ! failure of the rrqr or condition estimator, the last line of - ! defense ensures that stdlib_wgejsv completes the task. - ! compute the full svd of l3 using stdlib_wgesvj with explicit + ! defense ensures that stdlib_${ci}$gejsv completes the task. + ! compute the full svd of l3 using stdlib_${ci}$gesvj with explicit ! accumulation of jacobi rotations. - call stdlib_wgesvj( 'L', 'U', 'V', nr, nr, v, ldv, sva, nr, u,ldu, cwork(2*n+& + call stdlib_${ci}$gesvj( 'L', 'U', 'V', nr, nr, v, ldv, sva, nr, u,ldu, cwork(2*n+& n*nr+nr+1), lwork-2*n-n*nr-nr,rwork, lrwork, info ) scalem = rwork(1) numrank = nint(rwork(2),KIND=ilp) if ( nr < n ) then - call stdlib_wlaset( 'A',n-nr,nr,czero,czero,v(nr+1,1),ldv ) - call stdlib_wlaset( 'A',nr,n-nr,czero,czero,v(1,nr+1),ldv ) - call stdlib_wlaset('A',n-nr,n-nr,czero,cone,v(nr+1,nr+1),ldv) + call stdlib_${ci}$laset( 'A',n-nr,nr,czero,czero,v(nr+1,1),ldv ) + call stdlib_${ci}$laset( 'A',nr,n-nr,czero,czero,v(1,nr+1),ldv ) + call stdlib_${ci}$laset('A',n-nr,n-nr,czero,cone,v(nr+1,nr+1),ldv) end if - call stdlib_wunmqr( 'L','N',n,n,nr,cwork(2*n+1),n,cwork(n+1),v,ldv,cwork(2*n+& + call stdlib_${ci}$unmqr( 'L','N',n,n,nr,cwork(2*n+1),n,cwork(n+1),v,ldv,cwork(2*n+& n*nr+nr+1),lwork-2*n-n*nr-nr,ierr ) - call stdlib_wunmlq( 'L', 'C', nr, nr, nr, cwork(2*n+1), n,cwork(2*n+n*nr+1), & + call stdlib_${ci}$unmlq( 'L', 'C', nr, nr, nr, cwork(2*n+1), n,cwork(2*n+n*nr+1), & u, ldu, cwork(2*n+n*nr+nr+1),lwork-2*n-n*nr-nr, ierr ) do q = 1, nr do p = 1, nr @@ -6812,7 +6814,7 @@ module stdlib_linalg_lapack_w ! permute the rows of v using the (column) permutation from the ! first qrf. also, scale the columns to make them unit in ! euclidean norm. this applies to all cases. - temp1 = sqrt(real(n,KIND=qp)) * epsln + temp1 = sqrt(real(n,KIND=${ck}$)) * epsln do q = 1, n do p = 1, n cwork(2*n+n*nr+nr+iwork(p)) = v(p,q) @@ -6820,37 +6822,37 @@ module stdlib_linalg_lapack_w do p = 1, n v(p,q) = cwork(2*n+n*nr+nr+p) end do - xsc = one / stdlib_qznrm2( n, v(1,q), 1 ) - if ( (xsc < (one-temp1)) .or. (xsc > (one+temp1)) )call stdlib_wdscal( n, xsc,& + xsc = one / stdlib_${c2ri(ci)}$znrm2( n, v(1,q), 1 ) + if ( (xsc < (one-temp1)) .or. (xsc > (one+temp1)) )call stdlib_${ci}$dscal( n, xsc,& v(1,q), 1 ) end do ! at this moment, v contains the right singular vectors of a. ! next, assemble the left singular vector matrix u (m x n). if ( nr < m ) then - call stdlib_wlaset('A', m-nr, nr, czero, czero, u(nr+1,1), ldu) + call stdlib_${ci}$laset('A', m-nr, nr, czero, czero, u(nr+1,1), ldu) if ( nr < n1 ) then - call stdlib_wlaset('A',nr,n1-nr,czero,czero,u(1,nr+1),ldu) - call stdlib_wlaset('A',m-nr,n1-nr,czero,cone,u(nr+1,nr+1),ldu) + call stdlib_${ci}$laset('A',nr,n1-nr,czero,czero,u(1,nr+1),ldu) + call stdlib_${ci}$laset('A',m-nr,n1-nr,czero,cone,u(nr+1,nr+1),ldu) end if end if ! the q matrix from the first qrf is built into the left singular ! matrix u. this applies to all cases. - call stdlib_wunmqr( 'L', 'N', m, n1, n, a, lda, cwork, u,ldu, cwork(n+1), lwork-& + call stdlib_${ci}$unmqr( 'L', 'N', m, n1, n, a, lda, cwork, u,ldu, cwork(n+1), lwork-& n, ierr ) ! the columns of u are normalized. the cost is o(m*n) flops. - temp1 = sqrt(real(m,KIND=qp)) * epsln + temp1 = sqrt(real(m,KIND=${ck}$)) * epsln do p = 1, nr - xsc = one / stdlib_qznrm2( m, u(1,p), 1 ) - if ( (xsc < (one-temp1)) .or. (xsc > (one+temp1)) )call stdlib_wdscal( m, xsc,& + xsc = one / stdlib_${c2ri(ci)}$znrm2( m, u(1,p), 1 ) + if ( (xsc < (one-temp1)) .or. (xsc > (one+temp1)) )call stdlib_${ci}$dscal( m, xsc,& u(1,p), 1 ) end do ! if the initial qrf is computed with row pivoting, the left ! singular vectors must be adjusted. - if ( rowpiv )call stdlib_wlaswp( n1, u, ldu, 1, m-1, iwork(iwoff+1), -1 ) + if ( rowpiv )call stdlib_${ci}$laswp( n1, u, ldu, 1, m-1, iwork(iwoff+1), -1 ) else ! The Initial Matrix A Has Almost Orthogonal Columns And ! the second qrf is not needed - call stdlib_wlacpy( 'U', n, n, a, lda, cwork(n+1), n ) + call stdlib_${ci}$lacpy( 'U', n, n, a, lda, cwork(n+1), n ) if ( l2pert ) then xsc = sqrt(small) do p = 2, n @@ -6862,43 +6864,43 @@ module stdlib_linalg_lapack_w end do end do else - call stdlib_wlaset( 'L',n-1,n-1,czero,czero,cwork(n+2),n ) + call stdlib_${ci}$laset( 'L',n-1,n-1,czero,czero,cwork(n+2),n ) end if - call stdlib_wgesvj( 'U', 'U', 'N', n, n, cwork(n+1), n, sva,n, u, ldu, cwork(n+& + call stdlib_${ci}$gesvj( 'U', 'U', 'N', n, n, cwork(n+1), n, sva,n, u, ldu, cwork(n+& n*n+1), lwork-n-n*n, rwork, lrwork,info ) scalem = rwork(1) numrank = nint(rwork(2),KIND=ilp) do p = 1, n - call stdlib_wcopy( n, cwork(n+(p-1)*n+1), 1, u(1,p), 1 ) - call stdlib_wdscal( n, sva(p), cwork(n+(p-1)*n+1), 1 ) + call stdlib_${ci}$copy( n, cwork(n+(p-1)*n+1), 1, u(1,p), 1 ) + call stdlib_${ci}$dscal( n, sva(p), cwork(n+(p-1)*n+1), 1 ) end do - call stdlib_wtrsm( 'L', 'U', 'N', 'N', n, n,cone, a, lda, cwork(n+1), n ) + call stdlib_${ci}$trsm( 'L', 'U', 'N', 'N', n, n,cone, a, lda, cwork(n+1), n ) do p = 1, n - call stdlib_wcopy( n, cwork(n+p), n, v(iwork(p),1), ldv ) + call stdlib_${ci}$copy( n, cwork(n+p), n, v(iwork(p),1), ldv ) end do - temp1 = sqrt(real(n,KIND=qp))*epsln + temp1 = sqrt(real(n,KIND=${ck}$))*epsln do p = 1, n - xsc = one / stdlib_qznrm2( n, v(1,p), 1 ) - if ( (xsc < (one-temp1)) .or. (xsc > (one+temp1)) )call stdlib_wdscal( n, xsc,& + xsc = one / stdlib_${c2ri(ci)}$znrm2( n, v(1,p), 1 ) + if ( (xsc < (one-temp1)) .or. (xsc > (one+temp1)) )call stdlib_${ci}$dscal( n, xsc,& v(1,p), 1 ) end do ! assemble the left singular vector matrix u (m x n). if ( n < m ) then - call stdlib_wlaset( 'A', m-n, n, czero, czero, u(n+1,1), ldu ) + call stdlib_${ci}$laset( 'A', m-n, n, czero, czero, u(n+1,1), ldu ) if ( n < n1 ) then - call stdlib_wlaset('A',n, n1-n, czero, czero, u(1,n+1),ldu) - call stdlib_wlaset( 'A',m-n,n1-n, czero, cone,u(n+1,n+1),ldu) + call stdlib_${ci}$laset('A',n, n1-n, czero, czero, u(1,n+1),ldu) + call stdlib_${ci}$laset( 'A',m-n,n1-n, czero, cone,u(n+1,n+1),ldu) end if end if - call stdlib_wunmqr( 'L', 'N', m, n1, n, a, lda, cwork, u,ldu, cwork(n+1), lwork-& + call stdlib_${ci}$unmqr( 'L', 'N', m, n1, n, a, lda, cwork, u,ldu, cwork(n+1), lwork-& n, ierr ) - temp1 = sqrt(real(m,KIND=qp))*epsln + temp1 = sqrt(real(m,KIND=${ck}$))*epsln do p = 1, n1 - xsc = one / stdlib_qznrm2( m, u(1,p), 1 ) - if ( (xsc < (one-temp1)) .or. (xsc > (one+temp1)) )call stdlib_wdscal( m, xsc,& + xsc = one / stdlib_${c2ri(ci)}$znrm2( m, u(1,p), 1 ) + if ( (xsc < (one-temp1)) .or. (xsc > (one+temp1)) )call stdlib_${ci}$dscal( m, xsc,& u(1,p), 1 ) end do - if ( rowpiv )call stdlib_wlaswp( n1, u, ldu, 1, m-1, iwork(iwoff+1), -1 ) + if ( rowpiv )call stdlib_${ci}$laswp( n1, u, ldu, 1, m-1, iwork(iwoff+1), -1 ) end if ! end of the >> almost orthogonal case << in the full svd else @@ -6913,13 +6915,13 @@ module stdlib_linalg_lapack_w ! in presence of extreme values, e.g. when the singular values spread from ! the underflow to the overflow threshold. do p = 1, nr - call stdlib_wcopy( n-p+1, a(p,p), lda, v(p,p), 1 ) - call stdlib_wlacgv( n-p+1, v(p,p), 1 ) + call stdlib_${ci}$copy( n-p+1, a(p,p), lda, v(p,p), 1 ) + call stdlib_${ci}$lacgv( n-p+1, v(p,p), 1 ) end do if ( l2pert ) then xsc = sqrt(small/epsln) do q = 1, nr - ctemp = cmplx(xsc*abs( v(q,q) ),zero,KIND=qp) + ctemp = cmplx(xsc*abs( v(q,q) ),zero,KIND=${ck}$) do p = 1, n if ( ( p > q ) .and. ( abs(v(p,q)) <= temp1 ).or. ( p < q ) )v(p,q) = & ctemp @@ -6928,42 +6930,42 @@ module stdlib_linalg_lapack_w end do end do else - if (nr>1) call stdlib_wlaset( 'U', nr-1, nr-1, czero, czero, v(1,2), ldv ) + if (nr>1) call stdlib_${ci}$laset( 'U', nr-1, nr-1, czero, czero, v(1,2), ldv ) end if - call stdlib_wgeqrf( n, nr, v, ldv, cwork(n+1), cwork(2*n+1),lwork-2*n, ierr ) + call stdlib_${ci}$geqrf( n, nr, v, ldv, cwork(n+1), cwork(2*n+1),lwork-2*n, ierr ) - call stdlib_wlacpy( 'L', n, nr, v, ldv, cwork(2*n+1), n ) + call stdlib_${ci}$lacpy( 'L', n, nr, v, ldv, cwork(2*n+1), n ) do p = 1, nr - call stdlib_wcopy( nr-p+1, v(p,p), ldv, u(p,p), 1 ) - call stdlib_wlacgv( nr-p+1, u(p,p), 1 ) + call stdlib_${ci}$copy( nr-p+1, v(p,p), ldv, u(p,p), 1 ) + call stdlib_${ci}$lacgv( nr-p+1, u(p,p), 1 ) end do if ( l2pert ) then xsc = sqrt(small/epsln) do q = 2, nr do p = 1, q - 1 - ctemp = cmplx(xsc * min(abs(u(p,p)),abs(u(q,q))),zero,KIND=qp) + ctemp = cmplx(xsc * min(abs(u(p,p)),abs(u(q,q))),zero,KIND=${ck}$) ! u(p,q) = - temp1 * ( u(q,p) / abs(u(q,p)) ) u(p,q) = - ctemp end do end do else - if (nr>1) call stdlib_wlaset('U', nr-1, nr-1, czero, czero, u(1,2), ldu ) + if (nr>1) call stdlib_${ci}$laset('U', nr-1, nr-1, czero, czero, u(1,2), ldu ) end if - call stdlib_wgesvj( 'L', 'U', 'V', nr, nr, u, ldu, sva,n, v, ldv, cwork(2*n+n*nr+1),& + call stdlib_${ci}$gesvj( 'L', 'U', 'V', nr, nr, u, ldu, sva,n, v, ldv, cwork(2*n+n*nr+1),& lwork-2*n-n*nr,rwork, lrwork, info ) scalem = rwork(1) numrank = nint(rwork(2),KIND=ilp) if ( nr < n ) then - call stdlib_wlaset( 'A',n-nr,nr,czero,czero,v(nr+1,1),ldv ) - call stdlib_wlaset( 'A',nr,n-nr,czero,czero,v(1,nr+1),ldv ) - call stdlib_wlaset( 'A',n-nr,n-nr,czero,cone,v(nr+1,nr+1),ldv ) + call stdlib_${ci}$laset( 'A',n-nr,nr,czero,czero,v(nr+1,1),ldv ) + call stdlib_${ci}$laset( 'A',nr,n-nr,czero,czero,v(1,nr+1),ldv ) + call stdlib_${ci}$laset( 'A',n-nr,n-nr,czero,cone,v(nr+1,nr+1),ldv ) end if - call stdlib_wunmqr( 'L','N',n,n,nr,cwork(2*n+1),n,cwork(n+1),v,ldv,cwork(2*n+n*nr+& + call stdlib_${ci}$unmqr( 'L','N',n,n,nr,cwork(2*n+1),n,cwork(n+1),v,ldv,cwork(2*n+n*nr+& nr+1),lwork-2*n-n*nr-nr,ierr ) ! permute the rows of v using the (column) permutation from the ! first qrf. also, scale the columns to make them unit in ! euclidean norm. this applies to all cases. - temp1 = sqrt(real(n,KIND=qp)) * epsln + temp1 = sqrt(real(n,KIND=${ck}$)) * epsln do q = 1, n do p = 1, n cwork(2*n+n*nr+nr+iwork(p)) = v(p,q) @@ -6971,34 +6973,34 @@ module stdlib_linalg_lapack_w do p = 1, n v(p,q) = cwork(2*n+n*nr+nr+p) end do - xsc = one / stdlib_qznrm2( n, v(1,q), 1 ) - if ( (xsc < (one-temp1)) .or. (xsc > (one+temp1)) )call stdlib_wdscal( n, xsc,& + xsc = one / stdlib_${c2ri(ci)}$znrm2( n, v(1,q), 1 ) + if ( (xsc < (one-temp1)) .or. (xsc > (one+temp1)) )call stdlib_${ci}$dscal( n, xsc,& v(1,q), 1 ) end do ! at this moment, v contains the right singular vectors of a. ! next, assemble the left singular vector matrix u (m x n). if ( nr < m ) then - call stdlib_wlaset( 'A', m-nr, nr, czero, czero, u(nr+1,1), ldu ) + call stdlib_${ci}$laset( 'A', m-nr, nr, czero, czero, u(nr+1,1), ldu ) if ( nr < n1 ) then - call stdlib_wlaset('A',nr, n1-nr, czero, czero, u(1,nr+1),ldu) - call stdlib_wlaset('A',m-nr,n1-nr, czero, cone,u(nr+1,nr+1),ldu) + call stdlib_${ci}$laset('A',nr, n1-nr, czero, czero, u(1,nr+1),ldu) + call stdlib_${ci}$laset('A',m-nr,n1-nr, czero, cone,u(nr+1,nr+1),ldu) end if end if - call stdlib_wunmqr( 'L', 'N', m, n1, n, a, lda, cwork, u,ldu, cwork(n+1), lwork-n, & + call stdlib_${ci}$unmqr( 'L', 'N', m, n1, n, a, lda, cwork, u,ldu, cwork(n+1), lwork-n, & ierr ) - if ( rowpiv )call stdlib_wlaswp( n1, u, ldu, 1, m-1, iwork(iwoff+1), -1 ) + if ( rowpiv )call stdlib_${ci}$laswp( n1, u, ldu, 1, m-1, iwork(iwoff+1), -1 ) end if if ( transp ) then ! .. swap u and v because the procedure worked on a^* do p = 1, n - call stdlib_wswap( n, u(1,p), 1, v(1,p), 1 ) + call stdlib_${ci}$swap( n, u(1,p), 1, v(1,p), 1 ) end do end if end if ! end of the full svd ! undo scaling, if necessary (and possible) if ( uscal2 <= (big/sva(1))*uscal1 ) then - call stdlib_qlascl( 'G', 0, 0, uscal1, uscal2, nr, 1, sva, n, ierr ) + call stdlib_${c2ri(ci)}$lascl( 'G', 0, 0, uscal1, uscal2, nr, 1, sva, n, ierr ) uscal1 = one uscal2 = one end if @@ -7027,10 +7029,10 @@ module stdlib_linalg_lapack_w iwork(4) = -1 end if return - end subroutine stdlib_wgejsv + end subroutine stdlib_${ci}$gejsv - pure subroutine stdlib_wgelq( m, n, a, lda, t, tsize, work, lwork,info ) + pure subroutine stdlib_${ci}$gelq( m, n, a, lda, t, tsize, work, lwork,info ) !! ZGELQ: computes an LQ factorization of a complex M-by-N matrix A: !! A = ( L 0 ) * Q !! where: @@ -7044,8 +7046,8 @@ module stdlib_linalg_lapack_w integer(ilp), intent(out) :: info integer(ilp), intent(in) :: lda, m, n, tsize, lwork ! Array Arguments - complex(qp), intent(inout) :: a(lda,*) - complex(qp), intent(out) :: t(*), work(*) + complex(${ck}$), intent(inout) :: a(lda,*) + complex(${ck}$), intent(out) :: t(*), work(*) ! ===================================================================== ! Local Scalars logical(lk) :: lquery, lminws, mint, minw @@ -7146,16 +7148,16 @@ module stdlib_linalg_lapack_w end if ! the lq decomposition if( ( n<=m ) .or. ( nb<=m ) .or. ( nb>=n ) ) then - call stdlib_wgelqt( m, n, mb, a, lda, t( 6 ), mb, work, info ) + call stdlib_${ci}$gelqt( m, n, mb, a, lda, t( 6 ), mb, work, info ) else - call stdlib_wlaswlq( m, n, mb, nb, a, lda, t( 6 ), mb, work,lwork, info ) + call stdlib_${ci}$laswlq( m, n, mb, nb, a, lda, t( 6 ), mb, work,lwork, info ) end if work( 1 ) = lwreq return - end subroutine stdlib_wgelq + end subroutine stdlib_${ci}$gelq - pure subroutine stdlib_wgelq2( m, n, a, lda, tau, work, info ) + pure subroutine stdlib_${ci}$gelq2( m, n, a, lda, tau, work, info ) !! ZGELQ2: computes an LQ factorization of a complex m-by-n matrix A: !! A = ( L 0 ) * Q !! where: @@ -7169,13 +7171,13 @@ module stdlib_linalg_lapack_w integer(ilp), intent(out) :: info integer(ilp), intent(in) :: lda, m, n ! Array Arguments - complex(qp), intent(inout) :: a(lda,*) - complex(qp), intent(out) :: tau(*), work(*) + complex(${ck}$), intent(inout) :: a(lda,*) + complex(${ck}$), intent(out) :: tau(*), work(*) ! ===================================================================== ! Local Scalars integer(ilp) :: i, k - complex(qp) :: alpha + complex(${ck}$) :: alpha ! Intrinsic Functions intrinsic :: max,min ! Executable Statements @@ -7195,23 +7197,23 @@ module stdlib_linalg_lapack_w k = min( m, n ) do i = 1, k ! generate elementary reflector h(i) to annihilate a(i,i+1:n) - call stdlib_wlacgv( n-i+1, a( i, i ), lda ) + call stdlib_${ci}$lacgv( n-i+1, a( i, i ), lda ) alpha = a( i, i ) - call stdlib_wlarfg( n-i+1, alpha, a( i, min( i+1, n ) ), lda,tau( i ) ) + call stdlib_${ci}$larfg( n-i+1, alpha, a( i, min( i+1, n ) ), lda,tau( i ) ) if( izero .and. anrmbignum ) then ! scale matrix norm down to bignum - call stdlib_wlascl( 'G', 0, 0, anrm, bignum, m, n, a, lda, info ) + call stdlib_${ci}$lascl( 'G', 0, 0, anrm, bignum, m, n, a, lda, info ) iascl = 2 else if( anrm==zero ) then ! matrix all zero. return zero solution. - call stdlib_wlaset( 'F', max( m, n ), nrhs, czero, czero, b, ldb ) + call stdlib_${ci}$laset( 'F', max( m, n ), nrhs, czero, czero, b, ldb ) go to 50 end if brow = m if( tpsd )brow = n - bnrm = stdlib_wlange( 'M', brow, nrhs, b, ldb, rwork ) + bnrm = stdlib_${ci}$lange( 'M', brow, nrhs, b, ldb, rwork ) ibscl = 0 if( bnrm>zero .and. bnrmbignum ) then ! scale matrix norm down to bignum - call stdlib_wlascl( 'G', 0, 0, bnrm, bignum, brow, nrhs, b, ldb,info ) + call stdlib_${ci}$lascl( 'G', 0, 0, bnrm, bignum, brow, nrhs, b, ldb,info ) ibscl = 2 end if if( m>=n ) then ! compute qr factorization of a - call stdlib_wgeqrf( m, n, a, lda, work( 1 ), work( mn+1 ), lwork-mn,info ) + call stdlib_${ci}$geqrf( m, n, a, lda, work( 1 ), work( mn+1 ), lwork-mn,info ) ! workspace at least n, optimally n*nb if( .not.tpsd ) then ! least-squares problem min || a * x - b || ! b(1:m,1:nrhs) := q**h * b(1:m,1:nrhs) - call stdlib_wunmqr( 'LEFT', 'CONJUGATE TRANSPOSE', m, nrhs, n, a,lda, work( 1 ), & + call stdlib_${ci}$unmqr( 'LEFT', 'CONJUGATE TRANSPOSE', m, nrhs, n, a,lda, work( 1 ), & b, ldb, work( mn+1 ), lwork-mn,info ) ! workspace at least nrhs, optimally nrhs*nb ! b(1:n,1:nrhs) := inv(r) * b(1:n,1:nrhs) - call stdlib_wtrtrs( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', n, nrhs,a, lda, b, ldb, & + call stdlib_${ci}$trtrs( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', n, nrhs,a, lda, b, ldb, & info ) if( info>0 ) then return @@ -7595,7 +7597,7 @@ module stdlib_linalg_lapack_w else ! underdetermined system of equations a**t * x = b ! b(1:n,1:nrhs) := inv(r**h) * b(1:n,1:nrhs) - call stdlib_wtrtrs( 'UPPER', 'CONJUGATE TRANSPOSE','NON-UNIT',n, nrhs, a, lda, b,& + call stdlib_${ci}$trtrs( 'UPPER', 'CONJUGATE TRANSPOSE','NON-UNIT',n, nrhs, a, lda, b,& ldb, info ) if( info>0 ) then return @@ -7607,19 +7609,19 @@ module stdlib_linalg_lapack_w end do end do ! b(1:m,1:nrhs) := q(1:n,:) * b(1:n,1:nrhs) - call stdlib_wunmqr( 'LEFT', 'NO TRANSPOSE', m, nrhs, n, a, lda,work( 1 ), b, ldb,& + call stdlib_${ci}$unmqr( 'LEFT', 'NO TRANSPOSE', m, nrhs, n, a, lda,work( 1 ), b, ldb,& work( mn+1 ), lwork-mn,info ) ! workspace at least nrhs, optimally nrhs*nb scllen = m end if else ! compute lq factorization of a - call stdlib_wgelqf( m, n, a, lda, work( 1 ), work( mn+1 ), lwork-mn,info ) + call stdlib_${ci}$gelqf( m, n, a, lda, work( 1 ), work( mn+1 ), lwork-mn,info ) ! workspace at least m, optimally m*nb. if( .not.tpsd ) then ! underdetermined system of equations a * x = b ! b(1:m,1:nrhs) := inv(l) * b(1:m,1:nrhs) - call stdlib_wtrtrs( 'LOWER', 'NO TRANSPOSE', 'NON-UNIT', m, nrhs,a, lda, b, ldb, & + call stdlib_${ci}$trtrs( 'LOWER', 'NO TRANSPOSE', 'NON-UNIT', m, nrhs,a, lda, b, ldb, & info ) if( info>0 ) then return @@ -7631,18 +7633,18 @@ module stdlib_linalg_lapack_w end do end do ! b(1:n,1:nrhs) := q(1:n,:)**h * b(1:m,1:nrhs) - call stdlib_wunmlq( 'LEFT', 'CONJUGATE TRANSPOSE', n, nrhs, m, a,lda, work( 1 ), & + call stdlib_${ci}$unmlq( 'LEFT', 'CONJUGATE TRANSPOSE', n, nrhs, m, a,lda, work( 1 ), & b, ldb, work( mn+1 ), lwork-mn,info ) ! workspace at least nrhs, optimally nrhs*nb scllen = n else ! overdetermined system min || a**h * x - b || ! b(1:n,1:nrhs) := q * b(1:n,1:nrhs) - call stdlib_wunmlq( 'LEFT', 'NO TRANSPOSE', n, nrhs, m, a, lda,work( 1 ), b, ldb,& + call stdlib_${ci}$unmlq( 'LEFT', 'NO TRANSPOSE', n, nrhs, m, a, lda,work( 1 ), b, ldb,& work( mn+1 ), lwork-mn,info ) ! workspace at least nrhs, optimally nrhs*nb ! b(1:m,1:nrhs) := inv(l**h) * b(1:m,1:nrhs) - call stdlib_wtrtrs( 'LOWER', 'CONJUGATE TRANSPOSE', 'NON-UNIT',m, nrhs, a, lda, & + call stdlib_${ci}$trtrs( 'LOWER', 'CONJUGATE TRANSPOSE', 'NON-UNIT',m, nrhs, a, lda, & b, ldb, info ) if( info>0 ) then return @@ -7652,22 +7654,22 @@ module stdlib_linalg_lapack_w end if ! undo scaling if( iascl==1 ) then - call stdlib_wlascl( 'G', 0, 0, anrm, smlnum, scllen, nrhs, b, ldb,info ) + call stdlib_${ci}$lascl( 'G', 0, 0, anrm, smlnum, scllen, nrhs, b, ldb,info ) else if( iascl==2 ) then - call stdlib_wlascl( 'G', 0, 0, anrm, bignum, scllen, nrhs, b, ldb,info ) + call stdlib_${ci}$lascl( 'G', 0, 0, anrm, bignum, scllen, nrhs, b, ldb,info ) end if if( ibscl==1 ) then - call stdlib_wlascl( 'G', 0, 0, smlnum, bnrm, scllen, nrhs, b, ldb,info ) + call stdlib_${ci}$lascl( 'G', 0, 0, smlnum, bnrm, scllen, nrhs, b, ldb,info ) else if( ibscl==2 ) then - call stdlib_wlascl( 'G', 0, 0, bignum, bnrm, scllen, nrhs, b, ldb,info ) + call stdlib_${ci}$lascl( 'G', 0, 0, bignum, bnrm, scllen, nrhs, b, ldb,info ) end if 50 continue - work( 1 ) = real( wsize,KIND=qp) + work( 1 ) = real( wsize,KIND=${ck}$) return - end subroutine stdlib_wgels + end subroutine stdlib_${ci}$gels - subroutine stdlib_wgelsd( m, n, nrhs, a, lda, b, ldb, s, rcond, rank,work, lwork, rwork, & + subroutine stdlib_${ci}$gelsd( m, n, nrhs, a, lda, b, ldb, s, rcond, rank,work, lwork, rwork, & !! ZGELSD: computes the minimum-norm solution to a real linear least !! squares problem: !! minimize 2-norm(| b - A*x |) @@ -7700,12 +7702,12 @@ module stdlib_linalg_lapack_w ! Scalar Arguments integer(ilp), intent(out) :: info, rank integer(ilp), intent(in) :: lda, ldb, lwork, m, n, nrhs - real(qp), intent(in) :: rcond + real(${ck}$), intent(in) :: rcond ! Array Arguments integer(ilp), intent(out) :: iwork(*) - real(qp), intent(out) :: rwork(*), s(*) - complex(qp), intent(inout) :: a(lda,*), b(ldb,*) - complex(qp), intent(out) :: work(*) + real(${ck}$), intent(out) :: rwork(*), s(*) + complex(${ck}$), intent(inout) :: a(lda,*), b(ldb,*) + complex(${ck}$), intent(out) :: work(*) ! ===================================================================== @@ -7713,7 +7715,7 @@ module stdlib_linalg_lapack_w logical(lk) :: lquery integer(ilp) :: iascl, ibscl, ie, il, itau, itaup, itauq, ldwork, liwork, lrwork, & maxmn, maxwrk, minmn, minwrk, mm, mnthr, nlvl, nrwork, nwork, smlsiz - real(qp) :: anrm, bignum, bnrm, eps, sfmin, smlnum + real(${ck}$) :: anrm, bignum, bnrm, eps, sfmin, smlnum ! Intrinsic Functions intrinsic :: int,log,max,min,real ! Executable Statements @@ -7747,7 +7749,7 @@ module stdlib_linalg_lapack_w if( minmn>0 ) then smlsiz = stdlib_ilaenv( 9, 'ZGELSD', ' ', 0, 0, 0, 0 ) mnthr = stdlib_ilaenv( 6, 'ZGELSD', ' ', m, n, nrhs, -1 ) - nlvl = max( int( log( real( minmn,KIND=qp) / real( smlsiz + 1,KIND=qp) ) /log( & + nlvl = max( int( log( real( minmn,KIND=${ck}$) / real( smlsiz + 1,KIND=${ck}$) ) /log( & two ),KIND=ilp) + 1, 0 ) liwork = 3*minmn*nlvl + 11*minmn mm = m @@ -7828,43 +7830,43 @@ module stdlib_linalg_lapack_w return end if ! get machine parameters. - eps = stdlib_qlamch( 'P' ) - sfmin = stdlib_qlamch( 'S' ) + eps = stdlib_${c2ri(ci)}$lamch( 'P' ) + sfmin = stdlib_${c2ri(ci)}$lamch( 'S' ) smlnum = sfmin / eps bignum = one / smlnum - call stdlib_qlabad( smlnum, bignum ) + call stdlib_${c2ri(ci)}$labad( smlnum, bignum ) ! scale a if max entry outside range [smlnum,bignum]. - anrm = stdlib_wlange( 'M', m, n, a, lda, rwork ) + anrm = stdlib_${ci}$lange( 'M', m, n, a, lda, rwork ) iascl = 0 if( anrm>zero .and. anrmbignum ) then ! scale matrix norm down to bignum. - call stdlib_wlascl( 'G', 0, 0, anrm, bignum, m, n, a, lda, info ) + call stdlib_${ci}$lascl( 'G', 0, 0, anrm, bignum, m, n, a, lda, info ) iascl = 2 else if( anrm==zero ) then ! matrix all zero. return zero solution. - call stdlib_wlaset( 'F', max( m, n ), nrhs, czero, czero, b, ldb ) - call stdlib_qlaset( 'F', minmn, 1, zero, zero, s, 1 ) + call stdlib_${ci}$laset( 'F', max( m, n ), nrhs, czero, czero, b, ldb ) + call stdlib_${c2ri(ci)}$laset( 'F', minmn, 1, zero, zero, s, 1 ) rank = 0 go to 10 end if ! scale b if max entry outside range [smlnum,bignum]. - bnrm = stdlib_wlange( 'M', m, nrhs, b, ldb, rwork ) + bnrm = stdlib_${ci}$lange( 'M', m, nrhs, b, ldb, rwork ) ibscl = 0 if( bnrm>zero .and. bnrmbignum ) then ! scale matrix norm down to bignum. - call stdlib_wlascl( 'G', 0, 0, bnrm, bignum, m, nrhs, b, ldb, info ) + call stdlib_${ci}$lascl( 'G', 0, 0, bnrm, bignum, m, nrhs, b, ldb, info ) ibscl = 2 end if ! if m < n make sure b(m+1:n,:) = 0 - if( m=n ) then ! path 1 - overdetermined or exactly determined. @@ -7877,16 +7879,16 @@ module stdlib_linalg_lapack_w ! compute a=q*r. ! (rworkspace: need n) ! (cworkspace: need n, prefer n*nb) - call stdlib_wgeqrf( m, n, a, lda, work( itau ), work( nwork ),lwork-nwork+1, & + call stdlib_${ci}$geqrf( m, n, a, lda, work( itau ), work( nwork ),lwork-nwork+1, & info ) ! multiply b by transpose(q). ! (rworkspace: need n) ! (cworkspace: need nrhs, prefer nrhs*nb) - call stdlib_wunmqr( 'L', 'C', m, nrhs, n, a, lda, work( itau ), b,ldb, work( & + call stdlib_${ci}$unmqr( 'L', 'C', m, nrhs, n, a, lda, work( itau ), b,ldb, work( & nwork ), lwork-nwork+1, info ) ! zero out below r. if( n>1 ) then - call stdlib_wlaset( 'L', n-1, n-1, czero, czero, a( 2, 1 ),lda ) + call stdlib_${ci}$laset( 'L', n-1, n-1, czero, czero, a( 2, 1 ),lda ) end if end if itauq = 1 @@ -7897,20 +7899,20 @@ module stdlib_linalg_lapack_w ! bidiagonalize r in a. ! (rworkspace: need n) ! (cworkspace: need 2*n+mm, prefer 2*n+(mm+n)*nb) - call stdlib_wgebrd( mm, n, a, lda, s, rwork( ie ), work( itauq ),work( itaup ), & + call stdlib_${ci}$gebrd( mm, n, a, lda, s, rwork( ie ), work( itauq ),work( itaup ), & work( nwork ), lwork-nwork+1,info ) ! multiply b by transpose of left bidiagonalizing vectors of r. ! (cworkspace: need 2*n+nrhs, prefer 2*n+nrhs*nb) - call stdlib_wunmbr( 'Q', 'L', 'C', mm, nrhs, n, a, lda, work( itauq ),b, ldb, work( & + call stdlib_${ci}$unmbr( 'Q', 'L', 'C', mm, nrhs, n, a, lda, work( itauq ),b, ldb, work( & nwork ), lwork-nwork+1, info ) ! solve the bidiagonal least squares problem. - call stdlib_wlalsd( 'U', smlsiz, n, nrhs, s, rwork( ie ), b, ldb,rcond, rank, work( & + call stdlib_${ci}$lalsd( 'U', smlsiz, n, nrhs, s, rwork( ie ), b, ldb,rcond, rank, work( & nwork ), rwork( nrwork ),iwork, info ) if( info/=0 ) then go to 10 end if ! multiply b by right bidiagonalizing vectors of r. - call stdlib_wunmbr( 'P', 'L', 'N', n, nrhs, n, a, lda, work( itaup ),b, ldb, work( & + call stdlib_${ci}$unmbr( 'P', 'L', 'N', n, nrhs, n, a, lda, work( itaup ),b, ldb, work( & nwork ), lwork-nwork+1, info ) else if( n>=mnthr .and. lwork>=4*m+m*m+max( m, 2*m-4, nrhs, n-3*m ) ) then ! path 2a - underdetermined, with many more columns than rows @@ -7922,12 +7924,12 @@ module stdlib_linalg_lapack_w nwork = m + 1 ! compute a=l*q. ! (cworkspace: need 2*m, prefer m+m*nb) - call stdlib_wgelqf( m, n, a, lda, work( itau ), work( nwork ),lwork-nwork+1, info ) + call stdlib_${ci}$gelqf( m, n, a, lda, work( itau ), work( nwork ),lwork-nwork+1, info ) il = nwork ! copy l to work(il), zeroing out above its diagonal. - call stdlib_wlacpy( 'L', m, m, a, lda, work( il ), ldwork ) - call stdlib_wlaset( 'U', m-1, m-1, czero, czero, work( il+ldwork ),ldwork ) + call stdlib_${ci}$lacpy( 'L', m, m, a, lda, work( il ), ldwork ) + call stdlib_${ci}$laset( 'U', m-1, m-1, czero, czero, work( il+ldwork ),ldwork ) itauq = il + ldwork*m itaup = itauq + m nwork = itaup + m @@ -7936,27 +7938,27 @@ module stdlib_linalg_lapack_w ! bidiagonalize l in work(il). ! (rworkspace: need m) ! (cworkspace: need m*m+4*m, prefer m*m+4*m+2*m*nb) - call stdlib_wgebrd( m, m, work( il ), ldwork, s, rwork( ie ),work( itauq ), work( & + call stdlib_${ci}$gebrd( m, m, work( il ), ldwork, s, rwork( ie ),work( itauq ), work( & itaup ), work( nwork ),lwork-nwork+1, info ) ! multiply b by transpose of left bidiagonalizing vectors of l. ! (cworkspace: need m*m+4*m+nrhs, prefer m*m+4*m+nrhs*nb) - call stdlib_wunmbr( 'Q', 'L', 'C', m, nrhs, m, work( il ), ldwork,work( itauq ), b, & + call stdlib_${ci}$unmbr( 'Q', 'L', 'C', m, nrhs, m, work( il ), ldwork,work( itauq ), b, & ldb, work( nwork ),lwork-nwork+1, info ) ! solve the bidiagonal least squares problem. - call stdlib_wlalsd( 'U', smlsiz, m, nrhs, s, rwork( ie ), b, ldb,rcond, rank, work( & + call stdlib_${ci}$lalsd( 'U', smlsiz, m, nrhs, s, rwork( ie ), b, ldb,rcond, rank, work( & nwork ), rwork( nrwork ),iwork, info ) if( info/=0 ) then go to 10 end if ! multiply b by right bidiagonalizing vectors of l. - call stdlib_wunmbr( 'P', 'L', 'N', m, nrhs, m, work( il ), ldwork,work( itaup ), b, & + call stdlib_${ci}$unmbr( 'P', 'L', 'N', m, nrhs, m, work( il ), ldwork,work( itaup ), b, & ldb, work( nwork ),lwork-nwork+1, info ) ! zero out below first m rows of b. - call stdlib_wlaset( 'F', n-m, nrhs, czero, czero, b( m+1, 1 ), ldb ) + call stdlib_${ci}$laset( 'F', n-m, nrhs, czero, czero, b( m+1, 1 ), ldb ) nwork = itau + m ! multiply transpose(q) by b. ! (cworkspace: need nrhs, prefer nrhs*nb) - call stdlib_wunmlq( 'L', 'C', n, nrhs, m, a, lda, work( itau ), b,ldb, work( nwork )& + call stdlib_${ci}$unmlq( 'L', 'C', n, nrhs, m, a, lda, work( itau ), b,ldb, work( nwork )& , lwork-nwork+1, info ) else ! path 2 - remaining underdetermined cases. @@ -7968,44 +7970,44 @@ module stdlib_linalg_lapack_w ! bidiagonalize a. ! (rworkspace: need m) ! (cworkspace: need 2*m+n, prefer 2*m+(m+n)*nb) - call stdlib_wgebrd( m, n, a, lda, s, rwork( ie ), work( itauq ),work( itaup ), work(& + call stdlib_${ci}$gebrd( m, n, a, lda, s, rwork( ie ), work( itauq ),work( itaup ), work(& nwork ), lwork-nwork+1,info ) ! multiply b by transpose of left bidiagonalizing vectors. ! (cworkspace: need 2*m+nrhs, prefer 2*m+nrhs*nb) - call stdlib_wunmbr( 'Q', 'L', 'C', m, nrhs, n, a, lda, work( itauq ),b, ldb, work( & + call stdlib_${ci}$unmbr( 'Q', 'L', 'C', m, nrhs, n, a, lda, work( itauq ),b, ldb, work( & nwork ), lwork-nwork+1, info ) ! solve the bidiagonal least squares problem. - call stdlib_wlalsd( 'L', smlsiz, m, nrhs, s, rwork( ie ), b, ldb,rcond, rank, work( & + call stdlib_${ci}$lalsd( 'L', smlsiz, m, nrhs, s, rwork( ie ), b, ldb,rcond, rank, work( & nwork ), rwork( nrwork ),iwork, info ) if( info/=0 ) then go to 10 end if ! multiply b by right bidiagonalizing vectors of a. - call stdlib_wunmbr( 'P', 'L', 'N', n, nrhs, m, a, lda, work( itaup ),b, ldb, work( & + call stdlib_${ci}$unmbr( 'P', 'L', 'N', n, nrhs, m, a, lda, work( itaup ),b, ldb, work( & nwork ), lwork-nwork+1, info ) end if ! undo scaling. if( iascl==1 ) then - call stdlib_wlascl( 'G', 0, 0, anrm, smlnum, n, nrhs, b, ldb, info ) - call stdlib_qlascl( 'G', 0, 0, smlnum, anrm, minmn, 1, s, minmn,info ) + call stdlib_${ci}$lascl( 'G', 0, 0, anrm, smlnum, n, nrhs, b, ldb, info ) + call stdlib_${c2ri(ci)}$lascl( 'G', 0, 0, smlnum, anrm, minmn, 1, s, minmn,info ) else if( iascl==2 ) then - call stdlib_wlascl( 'G', 0, 0, anrm, bignum, n, nrhs, b, ldb, info ) - call stdlib_qlascl( 'G', 0, 0, bignum, anrm, minmn, 1, s, minmn,info ) + call stdlib_${ci}$lascl( 'G', 0, 0, anrm, bignum, n, nrhs, b, ldb, info ) + call stdlib_${c2ri(ci)}$lascl( 'G', 0, 0, bignum, anrm, minmn, 1, s, minmn,info ) end if if( ibscl==1 ) then - call stdlib_wlascl( 'G', 0, 0, smlnum, bnrm, n, nrhs, b, ldb, info ) + call stdlib_${ci}$lascl( 'G', 0, 0, smlnum, bnrm, n, nrhs, b, ldb, info ) else if( ibscl==2 ) then - call stdlib_wlascl( 'G', 0, 0, bignum, bnrm, n, nrhs, b, ldb, info ) + call stdlib_${ci}$lascl( 'G', 0, 0, bignum, bnrm, n, nrhs, b, ldb, info ) end if 10 continue work( 1 ) = maxwrk iwork( 1 ) = liwork rwork( 1 ) = lrwork return - end subroutine stdlib_wgelsd + end subroutine stdlib_${ci}$gelsd - subroutine stdlib_wgelss( m, n, nrhs, a, lda, b, ldb, s, rcond, rank,work, lwork, rwork, & + subroutine stdlib_${ci}$gelss( m, n, nrhs, a, lda, b, ldb, s, rcond, rank,work, lwork, rwork, & !! ZGELSS: computes the minimum norm solution to a complex linear !! least squares problem: !! Minimize 2-norm(| b - A*x |). @@ -8025,11 +8027,11 @@ module stdlib_linalg_lapack_w ! Scalar Arguments integer(ilp), intent(out) :: info, rank integer(ilp), intent(in) :: lda, ldb, lwork, m, n, nrhs - real(qp), intent(in) :: rcond + real(${ck}$), intent(in) :: rcond ! Array Arguments - real(qp), intent(out) :: rwork(*), s(*) - complex(qp), intent(inout) :: a(lda,*), b(ldb,*) - complex(qp), intent(out) :: work(*) + real(${ck}$), intent(out) :: rwork(*), s(*) + complex(${ck}$), intent(inout) :: a(lda,*), b(ldb,*) + complex(${ck}$), intent(out) :: work(*) ! ===================================================================== @@ -8039,9 +8041,9 @@ module stdlib_linalg_lapack_w ldwork, maxmn, maxwrk, minmn, minwrk, mm, mnthr integer(ilp) :: lwork_wgeqrf, lwork_wunmqr, lwork_wgebrd, lwork_wunmbr, lwork_wungbr, & lwork_wunmlq, lwork_wgelqf - real(qp) :: anrm, bignum, bnrm, eps, sfmin, smlnum, thr + real(${ck}$) :: anrm, bignum, bnrm, eps, sfmin, smlnum, thr ! Local Arrays - complex(qp) :: dum(1) + complex(${ck}$) :: dum(1) ! Intrinsic Functions intrinsic :: max,min ! Executable Statements @@ -8077,13 +8079,13 @@ module stdlib_linalg_lapack_w if( m>=n .and. m>=mnthr ) then ! path 1a - overdetermined, with many more rows than ! columns - ! compute space needed for stdlib_wgeqrf - call stdlib_wgeqrf( m, n, a, lda, dum(1), dum(1), -1, info ) - lwork_wgeqrf = real( dum(1),KIND=qp) - ! compute space needed for stdlib_wunmqr - call stdlib_wunmqr( 'L', 'C', m, nrhs, n, a, lda, dum(1), b,ldb, dum(1), -1, & + ! compute space needed for stdlib_${ci}$geqrf + call stdlib_${ci}$geqrf( m, n, a, lda, dum(1), dum(1), -1, info ) + lwork_wgeqrf = real( dum(1),KIND=${ck}$) + ! compute space needed for stdlib_${ci}$unmqr + call stdlib_${ci}$unmqr( 'L', 'C', m, nrhs, n, a, lda, dum(1), b,ldb, dum(1), -1, & info ) - lwork_wunmqr = real( dum(1),KIND=qp) + lwork_wunmqr = real( dum(1),KIND=${ck}$) mm = n maxwrk = max( maxwrk, n + n*stdlib_ilaenv( 1, 'ZGEQRF', ' ', m,n, -1, -1 ) ) @@ -8092,17 +8094,17 @@ module stdlib_linalg_lapack_w end if if( m>=n ) then ! path 1 - overdetermined or exactly determined - ! compute space needed for stdlib_wgebrd - call stdlib_wgebrd( mm, n, a, lda, s, s, dum(1), dum(1), dum(1),-1, info ) + ! compute space needed for stdlib_${ci}$gebrd + call stdlib_${ci}$gebrd( mm, n, a, lda, s, s, dum(1), dum(1), dum(1),-1, info ) - lwork_wgebrd = real( dum(1),KIND=qp) - ! compute space needed for stdlib_wunmbr - call stdlib_wunmbr( 'Q', 'L', 'C', mm, nrhs, n, a, lda, dum(1),b, ldb, dum(1),& + lwork_wgebrd = real( dum(1),KIND=${ck}$) + ! compute space needed for stdlib_${ci}$unmbr + call stdlib_${ci}$unmbr( 'Q', 'L', 'C', mm, nrhs, n, a, lda, dum(1),b, ldb, dum(1),& -1, info ) - lwork_wunmbr = real( dum(1),KIND=qp) - ! compute space needed for stdlib_wungbr - call stdlib_wungbr( 'P', n, n, n, a, lda, dum(1),dum(1), -1, info ) - lwork_wungbr = real( dum(1),KIND=qp) + lwork_wunmbr = real( dum(1),KIND=${ck}$) + ! compute space needed for stdlib_${ci}$ungbr + call stdlib_${ci}$ungbr( 'P', n, n, n, a, lda, dum(1),dum(1), -1, info ) + lwork_wungbr = real( dum(1),KIND=${ck}$) ! compute total workspace needed maxwrk = max( maxwrk, 2*n + lwork_wgebrd ) maxwrk = max( maxwrk, 2*n + lwork_wunmbr ) @@ -8115,24 +8117,24 @@ module stdlib_linalg_lapack_w if( n>=mnthr ) then ! path 2a - underdetermined, with many more columns ! than rows - ! compute space needed for stdlib_wgelqf - call stdlib_wgelqf( m, n, a, lda, dum(1), dum(1),-1, info ) - lwork_wgelqf = real( dum(1),KIND=qp) - ! compute space needed for stdlib_wgebrd - call stdlib_wgebrd( m, m, a, lda, s, s, dum(1), dum(1),dum(1), -1, info ) + ! compute space needed for stdlib_${ci}$gelqf + call stdlib_${ci}$gelqf( m, n, a, lda, dum(1), dum(1),-1, info ) + lwork_wgelqf = real( dum(1),KIND=${ck}$) + ! compute space needed for stdlib_${ci}$gebrd + call stdlib_${ci}$gebrd( m, m, a, lda, s, s, dum(1), dum(1),dum(1), -1, info ) - lwork_wgebrd = real( dum(1),KIND=qp) - ! compute space needed for stdlib_wunmbr - call stdlib_wunmbr( 'Q', 'L', 'C', m, nrhs, n, a, lda,dum(1), b, ldb, dum(& + lwork_wgebrd = real( dum(1),KIND=${ck}$) + ! compute space needed for stdlib_${ci}$unmbr + call stdlib_${ci}$unmbr( 'Q', 'L', 'C', m, nrhs, n, a, lda,dum(1), b, ldb, dum(& 1), -1, info ) - lwork_wunmbr = real( dum(1),KIND=qp) - ! compute space needed for stdlib_wungbr - call stdlib_wungbr( 'P', m, m, m, a, lda, dum(1),dum(1), -1, info ) - lwork_wungbr = real( dum(1),KIND=qp) - ! compute space needed for stdlib_wunmlq - call stdlib_wunmlq( 'L', 'C', n, nrhs, m, a, lda, dum(1),b, ldb, dum(1), -& + lwork_wunmbr = real( dum(1),KIND=${ck}$) + ! compute space needed for stdlib_${ci}$ungbr + call stdlib_${ci}$ungbr( 'P', m, m, m, a, lda, dum(1),dum(1), -1, info ) + lwork_wungbr = real( dum(1),KIND=${ck}$) + ! compute space needed for stdlib_${ci}$unmlq + call stdlib_${ci}$unmlq( 'L', 'C', n, nrhs, m, a, lda, dum(1),b, ldb, dum(1), -& 1, info ) - lwork_wunmlq = real( dum(1),KIND=qp) + lwork_wunmlq = real( dum(1),KIND=${ck}$) ! compute total workspace needed maxwrk = m + lwork_wgelqf maxwrk = max( maxwrk, 3*m + m*m + lwork_wgebrd ) @@ -8146,17 +8148,17 @@ module stdlib_linalg_lapack_w maxwrk = max( maxwrk, m + lwork_wunmlq ) else ! path 2 - underdetermined - ! compute space needed for stdlib_wgebrd - call stdlib_wgebrd( m, n, a, lda, s, s, dum(1), dum(1),dum(1), -1, info ) + ! compute space needed for stdlib_${ci}$gebrd + call stdlib_${ci}$gebrd( m, n, a, lda, s, s, dum(1), dum(1),dum(1), -1, info ) - lwork_wgebrd = real( dum(1),KIND=qp) - ! compute space needed for stdlib_wunmbr - call stdlib_wunmbr( 'Q', 'L', 'C', m, nrhs, m, a, lda,dum(1), b, ldb, dum(& + lwork_wgebrd = real( dum(1),KIND=${ck}$) + ! compute space needed for stdlib_${ci}$unmbr + call stdlib_${ci}$unmbr( 'Q', 'L', 'C', m, nrhs, m, a, lda,dum(1), b, ldb, dum(& 1), -1, info ) - lwork_wunmbr = real( dum(1),KIND=qp) - ! compute space needed for stdlib_wungbr - call stdlib_wungbr( 'P', m, n, m, a, lda, dum(1),dum(1), -1, info ) - lwork_wungbr = real( dum(1),KIND=qp) + lwork_wunmbr = real( dum(1),KIND=${ck}$) + ! compute space needed for stdlib_${ci}$ungbr + call stdlib_${ci}$ungbr( 'P', m, n, m, a, lda, dum(1),dum(1), -1, info ) + lwork_wungbr = real( dum(1),KIND=${ck}$) maxwrk = 2*m + lwork_wgebrd maxwrk = max( maxwrk, 2*m + lwork_wunmbr ) maxwrk = max( maxwrk, 2*m + lwork_wungbr ) @@ -8180,39 +8182,39 @@ module stdlib_linalg_lapack_w return end if ! get machine parameters - eps = stdlib_qlamch( 'P' ) - sfmin = stdlib_qlamch( 'S' ) + eps = stdlib_${c2ri(ci)}$lamch( 'P' ) + sfmin = stdlib_${c2ri(ci)}$lamch( 'S' ) smlnum = sfmin / eps bignum = one / smlnum - call stdlib_qlabad( smlnum, bignum ) + call stdlib_${c2ri(ci)}$labad( smlnum, bignum ) ! scale a if max element outside range [smlnum,bignum] - anrm = stdlib_wlange( 'M', m, n, a, lda, rwork ) + anrm = stdlib_${ci}$lange( 'M', m, n, a, lda, rwork ) iascl = 0 if( anrm>zero .and. anrmbignum ) then ! scale matrix norm down to bignum - call stdlib_wlascl( 'G', 0, 0, anrm, bignum, m, n, a, lda, info ) + call stdlib_${ci}$lascl( 'G', 0, 0, anrm, bignum, m, n, a, lda, info ) iascl = 2 else if( anrm==zero ) then ! matrix all zero. return zero solution. - call stdlib_wlaset( 'F', max( m, n ), nrhs, czero, czero, b, ldb ) - call stdlib_qlaset( 'F', minmn, 1, zero, zero, s, minmn ) + call stdlib_${ci}$laset( 'F', max( m, n ), nrhs, czero, czero, b, ldb ) + call stdlib_${c2ri(ci)}$laset( 'F', minmn, 1, zero, zero, s, minmn ) rank = 0 go to 70 end if ! scale b if max element outside range [smlnum,bignum] - bnrm = stdlib_wlange( 'M', m, nrhs, b, ldb, rwork ) + bnrm = stdlib_${ci}$lange( 'M', m, nrhs, b, ldb, rwork ) ibscl = 0 if( bnrm>zero .and. bnrmbignum ) then ! scale matrix norm down to bignum - call stdlib_wlascl( 'G', 0, 0, bnrm, bignum, m, nrhs, b, ldb, info ) + call stdlib_${ci}$lascl( 'G', 0, 0, bnrm, bignum, m, nrhs, b, ldb, info ) ibscl = 2 end if ! overdetermined case @@ -8227,15 +8229,15 @@ module stdlib_linalg_lapack_w ! compute a=q*r ! (cworkspace: need 2*n, prefer n+n*nb) ! (rworkspace: none) - call stdlib_wgeqrf( m, n, a, lda, work( itau ), work( iwork ),lwork-iwork+1, & + call stdlib_${ci}$geqrf( m, n, a, lda, work( itau ), work( iwork ),lwork-iwork+1, & info ) ! multiply b by transpose(q) ! (cworkspace: need n+nrhs, prefer n+nrhs*nb) ! (rworkspace: none) - call stdlib_wunmqr( 'L', 'C', m, nrhs, n, a, lda, work( itau ), b,ldb, work( & + call stdlib_${ci}$unmqr( 'L', 'C', m, nrhs, n, a, lda, work( itau ), b,ldb, work( & iwork ), lwork-iwork+1, info ) ! zero out below r - if( n>1 )call stdlib_wlaset( 'L', n-1, n-1, czero, czero, a( 2, 1 ),lda ) + if( n>1 )call stdlib_${ci}$laset( 'L', n-1, n-1, czero, czero, a( 2, 1 ),lda ) end if ie = 1 itauq = 1 @@ -8244,17 +8246,17 @@ module stdlib_linalg_lapack_w ! bidiagonalize r in a ! (cworkspace: need 2*n+mm, prefer 2*n+(mm+n)*nb) ! (rworkspace: need n) - call stdlib_wgebrd( mm, n, a, lda, s, rwork( ie ), work( itauq ),work( itaup ), & + call stdlib_${ci}$gebrd( mm, n, a, lda, s, rwork( ie ), work( itauq ),work( itaup ), & work( iwork ), lwork-iwork+1,info ) ! multiply b by transpose of left bidiagonalizing vectors of r ! (cworkspace: need 2*n+nrhs, prefer 2*n+nrhs*nb) ! (rworkspace: none) - call stdlib_wunmbr( 'Q', 'L', 'C', mm, nrhs, n, a, lda, work( itauq ),b, ldb, work( & + call stdlib_${ci}$unmbr( 'Q', 'L', 'C', mm, nrhs, n, a, lda, work( itauq ),b, ldb, work( & iwork ), lwork-iwork+1, info ) ! generate right bidiagonalizing vectors of r in a ! (cworkspace: need 3*n-1, prefer 2*n+(n-1)*nb) ! (rworkspace: none) - call stdlib_wungbr( 'P', n, n, n, a, lda, work( itaup ),work( iwork ), lwork-iwork+& + call stdlib_${ci}$ungbr( 'P', n, n, n, a, lda, work( itaup ),work( iwork ), lwork-iwork+& 1, info ) irwork = ie + n ! perform bidiagonal qr iteration @@ -8262,7 +8264,7 @@ module stdlib_linalg_lapack_w ! compute right singular vectors in a ! (cworkspace: none) ! (rworkspace: need bdspac) - call stdlib_wbdsqr( 'U', n, n, 0, nrhs, s, rwork( ie ), a, lda, dum,1, b, ldb, & + call stdlib_${ci}$bdsqr( 'U', n, n, 0, nrhs, s, rwork( ie ), a, lda, dum,1, b, ldb, & rwork( irwork ), info ) if( info/=0 )go to 70 ! multiply b by reciprocals of singular values @@ -8271,30 +8273,30 @@ module stdlib_linalg_lapack_w rank = 0 do i = 1, n if( s( i )>thr ) then - call stdlib_wdrscl( nrhs, s( i ), b( i, 1 ), ldb ) + call stdlib_${ci}$drscl( nrhs, s( i ), b( i, 1 ), ldb ) rank = rank + 1 else - call stdlib_wlaset( 'F', 1, nrhs, czero, czero, b( i, 1 ), ldb ) + call stdlib_${ci}$laset( 'F', 1, nrhs, czero, czero, b( i, 1 ), ldb ) end if end do ! multiply b by right singular vectors ! (cworkspace: need n, prefer n*nrhs) ! (rworkspace: none) if( lwork>=ldb*nrhs .and. nrhs>1 ) then - call stdlib_wgemm( 'C', 'N', n, nrhs, n, cone, a, lda, b, ldb,czero, work, ldb ) + call stdlib_${ci}$gemm( 'C', 'N', n, nrhs, n, cone, a, lda, b, ldb,czero, work, ldb ) - call stdlib_wlacpy( 'G', n, nrhs, work, ldb, b, ldb ) + call stdlib_${ci}$lacpy( 'G', n, nrhs, work, ldb, b, ldb ) else if( nrhs>1 ) then chunk = lwork / n do i = 1, nrhs, chunk bl = min( nrhs-i+1, chunk ) - call stdlib_wgemm( 'C', 'N', n, bl, n, cone, a, lda, b( 1, i ),ldb, czero, & + call stdlib_${ci}$gemm( 'C', 'N', n, bl, n, cone, a, lda, b( 1, i ),ldb, czero, & work, n ) - call stdlib_wlacpy( 'G', n, bl, work, n, b( 1, i ), ldb ) + call stdlib_${ci}$lacpy( 'G', n, bl, work, n, b( 1, i ), ldb ) end do else - call stdlib_wgemv( 'C', n, n, cone, a, lda, b, 1, czero, work, 1 ) - call stdlib_wcopy( n, work, 1, b, 1 ) + call stdlib_${ci}$gemv( 'C', n, n, cone, a, lda, b, 1, czero, work, 1 ) + call stdlib_${ci}$copy( n, work, 1, b, 1 ) end if else if( n>=mnthr .and. lwork>=3*m+m*m+max( m, nrhs, n-2*m ) )then ! underdetermined case, m much less than n @@ -8307,12 +8309,12 @@ module stdlib_linalg_lapack_w ! compute a=l*q ! (cworkspace: need 2*m, prefer m+m*nb) ! (rworkspace: none) - call stdlib_wgelqf( m, n, a, lda, work( itau ), work( iwork ),lwork-iwork+1, info ) + call stdlib_${ci}$gelqf( m, n, a, lda, work( itau ), work( iwork ),lwork-iwork+1, info ) il = iwork ! copy l to work(il), zeroing out above it - call stdlib_wlacpy( 'L', m, m, a, lda, work( il ), ldwork ) - call stdlib_wlaset( 'U', m-1, m-1, czero, czero, work( il+ldwork ),ldwork ) + call stdlib_${ci}$lacpy( 'L', m, m, a, lda, work( il ), ldwork ) + call stdlib_${ci}$laset( 'U', m-1, m-1, czero, czero, work( il+ldwork ),ldwork ) ie = 1 itauq = il + ldwork*m itaup = itauq + m @@ -8320,17 +8322,17 @@ module stdlib_linalg_lapack_w ! bidiagonalize l in work(il) ! (cworkspace: need m*m+4*m, prefer m*m+3*m+2*m*nb) ! (rworkspace: need m) - call stdlib_wgebrd( m, m, work( il ), ldwork, s, rwork( ie ),work( itauq ), work( & + call stdlib_${ci}$gebrd( m, m, work( il ), ldwork, s, rwork( ie ),work( itauq ), work( & itaup ), work( iwork ),lwork-iwork+1, info ) ! multiply b by transpose of left bidiagonalizing vectors of l ! (cworkspace: need m*m+3*m+nrhs, prefer m*m+3*m+nrhs*nb) ! (rworkspace: none) - call stdlib_wunmbr( 'Q', 'L', 'C', m, nrhs, m, work( il ), ldwork,work( itauq ), b, & + call stdlib_${ci}$unmbr( 'Q', 'L', 'C', m, nrhs, m, work( il ), ldwork,work( itauq ), b, & ldb, work( iwork ),lwork-iwork+1, info ) ! generate right bidiagonalizing vectors of r in work(il) ! (cworkspace: need m*m+4*m-1, prefer m*m+3*m+(m-1)*nb) ! (rworkspace: none) - call stdlib_wungbr( 'P', m, m, m, work( il ), ldwork, work( itaup ),work( iwork ), & + call stdlib_${ci}$ungbr( 'P', m, m, m, work( il ), ldwork, work( itaup ),work( iwork ), & lwork-iwork+1, info ) irwork = ie + m ! perform bidiagonal qr iteration, computing right singular @@ -8338,7 +8340,7 @@ module stdlib_linalg_lapack_w ! left singular vectors ! (cworkspace: need m*m) ! (rworkspace: need bdspac) - call stdlib_wbdsqr( 'U', m, m, 0, nrhs, s, rwork( ie ), work( il ),ldwork, a, lda, & + call stdlib_${ci}$bdsqr( 'U', m, m, 0, nrhs, s, rwork( ie ), work( il ),ldwork, a, lda, & b, ldb, rwork( irwork ), info ) if( info/=0 )go to 70 ! multiply b by reciprocals of singular values @@ -8347,10 +8349,10 @@ module stdlib_linalg_lapack_w rank = 0 do i = 1, m if( s( i )>thr ) then - call stdlib_wdrscl( nrhs, s( i ), b( i, 1 ), ldb ) + call stdlib_${ci}$drscl( nrhs, s( i ), b( i, 1 ), ldb ) rank = rank + 1 else - call stdlib_wlaset( 'F', 1, nrhs, czero, czero, b( i, 1 ), ldb ) + call stdlib_${ci}$laset( 'F', 1, nrhs, czero, czero, b( i, 1 ), ldb ) end if end do iwork = il + m*ldwork @@ -8358,29 +8360,29 @@ module stdlib_linalg_lapack_w ! (cworkspace: need m*m+2*m, prefer m*m+m+m*nrhs) ! (rworkspace: none) if( lwork>=ldb*nrhs+iwork-1 .and. nrhs>1 ) then - call stdlib_wgemm( 'C', 'N', m, nrhs, m, cone, work( il ), ldwork,b, ldb, czero, & + call stdlib_${ci}$gemm( 'C', 'N', m, nrhs, m, cone, work( il ), ldwork,b, ldb, czero, & work( iwork ), ldb ) - call stdlib_wlacpy( 'G', m, nrhs, work( iwork ), ldb, b, ldb ) + call stdlib_${ci}$lacpy( 'G', m, nrhs, work( iwork ), ldb, b, ldb ) else if( nrhs>1 ) then chunk = ( lwork-iwork+1 ) / m do i = 1, nrhs, chunk bl = min( nrhs-i+1, chunk ) - call stdlib_wgemm( 'C', 'N', m, bl, m, cone, work( il ), ldwork,b( 1, i ), & + call stdlib_${ci}$gemm( 'C', 'N', m, bl, m, cone, work( il ), ldwork,b( 1, i ), & ldb, czero, work( iwork ), m ) - call stdlib_wlacpy( 'G', m, bl, work( iwork ), m, b( 1, i ),ldb ) + call stdlib_${ci}$lacpy( 'G', m, bl, work( iwork ), m, b( 1, i ),ldb ) end do else - call stdlib_wgemv( 'C', m, m, cone, work( il ), ldwork, b( 1, 1 ),1, czero, work(& + call stdlib_${ci}$gemv( 'C', m, m, cone, work( il ), ldwork, b( 1, 1 ),1, czero, work(& iwork ), 1 ) - call stdlib_wcopy( m, work( iwork ), 1, b( 1, 1 ), 1 ) + call stdlib_${ci}$copy( m, work( iwork ), 1, b( 1, 1 ), 1 ) end if ! zero out below first m rows of b - call stdlib_wlaset( 'F', n-m, nrhs, czero, czero, b( m+1, 1 ), ldb ) + call stdlib_${ci}$laset( 'F', n-m, nrhs, czero, czero, b( m+1, 1 ), ldb ) iwork = itau + m ! multiply transpose(q) by b ! (cworkspace: need m+nrhs, prefer m+nhrs*nb) ! (rworkspace: none) - call stdlib_wunmlq( 'L', 'C', n, nrhs, m, a, lda, work( itau ), b,ldb, work( iwork )& + call stdlib_${ci}$unmlq( 'L', 'C', n, nrhs, m, a, lda, work( itau ), b,ldb, work( iwork )& , lwork-iwork+1, info ) else ! path 2 - remaining underdetermined cases @@ -8391,17 +8393,17 @@ module stdlib_linalg_lapack_w ! bidiagonalize a ! (cworkspace: need 3*m, prefer 2*m+(m+n)*nb) ! (rworkspace: need n) - call stdlib_wgebrd( m, n, a, lda, s, rwork( ie ), work( itauq ),work( itaup ), work(& + call stdlib_${ci}$gebrd( m, n, a, lda, s, rwork( ie ), work( itauq ),work( itaup ), work(& iwork ), lwork-iwork+1,info ) ! multiply b by transpose of left bidiagonalizing vectors ! (cworkspace: need 2*m+nrhs, prefer 2*m+nrhs*nb) ! (rworkspace: none) - call stdlib_wunmbr( 'Q', 'L', 'C', m, nrhs, n, a, lda, work( itauq ),b, ldb, work( & + call stdlib_${ci}$unmbr( 'Q', 'L', 'C', m, nrhs, n, a, lda, work( itauq ),b, ldb, work( & iwork ), lwork-iwork+1, info ) ! generate right bidiagonalizing vectors in a ! (cworkspace: need 3*m, prefer 2*m+m*nb) ! (rworkspace: none) - call stdlib_wungbr( 'P', m, n, m, a, lda, work( itaup ),work( iwork ), lwork-iwork+& + call stdlib_${ci}$ungbr( 'P', m, n, m, a, lda, work( itaup ),work( iwork ), lwork-iwork+& 1, info ) irwork = ie + m ! perform bidiagonal qr iteration, @@ -8409,7 +8411,7 @@ module stdlib_linalg_lapack_w ! multiplying b by transpose of left singular vectors ! (cworkspace: none) ! (rworkspace: need bdspac) - call stdlib_wbdsqr( 'L', m, n, 0, nrhs, s, rwork( ie ), a, lda, dum,1, b, ldb, & + call stdlib_${ci}$bdsqr( 'L', m, n, 0, nrhs, s, rwork( ie ), a, lda, dum,1, b, ldb, & rwork( irwork ), info ) if( info/=0 )go to 70 ! multiply b by reciprocals of singular values @@ -8418,52 +8420,52 @@ module stdlib_linalg_lapack_w rank = 0 do i = 1, m if( s( i )>thr ) then - call stdlib_wdrscl( nrhs, s( i ), b( i, 1 ), ldb ) + call stdlib_${ci}$drscl( nrhs, s( i ), b( i, 1 ), ldb ) rank = rank + 1 else - call stdlib_wlaset( 'F', 1, nrhs, czero, czero, b( i, 1 ), ldb ) + call stdlib_${ci}$laset( 'F', 1, nrhs, czero, czero, b( i, 1 ), ldb ) end if end do ! multiply b by right singular vectors of a ! (cworkspace: need n, prefer n*nrhs) ! (rworkspace: none) if( lwork>=ldb*nrhs .and. nrhs>1 ) then - call stdlib_wgemm( 'C', 'N', n, nrhs, m, cone, a, lda, b, ldb,czero, work, ldb ) + call stdlib_${ci}$gemm( 'C', 'N', n, nrhs, m, cone, a, lda, b, ldb,czero, work, ldb ) - call stdlib_wlacpy( 'G', n, nrhs, work, ldb, b, ldb ) + call stdlib_${ci}$lacpy( 'G', n, nrhs, work, ldb, b, ldb ) else if( nrhs>1 ) then chunk = lwork / n do i = 1, nrhs, chunk bl = min( nrhs-i+1, chunk ) - call stdlib_wgemm( 'C', 'N', n, bl, m, cone, a, lda, b( 1, i ),ldb, czero, & + call stdlib_${ci}$gemm( 'C', 'N', n, bl, m, cone, a, lda, b( 1, i ),ldb, czero, & work, n ) - call stdlib_wlacpy( 'F', n, bl, work, n, b( 1, i ), ldb ) + call stdlib_${ci}$lacpy( 'F', n, bl, work, n, b( 1, i ), ldb ) end do else - call stdlib_wgemv( 'C', m, n, cone, a, lda, b, 1, czero, work, 1 ) - call stdlib_wcopy( n, work, 1, b, 1 ) + call stdlib_${ci}$gemv( 'C', m, n, cone, a, lda, b, 1, czero, work, 1 ) + call stdlib_${ci}$copy( n, work, 1, b, 1 ) end if end if ! undo scaling if( iascl==1 ) then - call stdlib_wlascl( 'G', 0, 0, anrm, smlnum, n, nrhs, b, ldb, info ) - call stdlib_qlascl( 'G', 0, 0, smlnum, anrm, minmn, 1, s, minmn,info ) + call stdlib_${ci}$lascl( 'G', 0, 0, anrm, smlnum, n, nrhs, b, ldb, info ) + call stdlib_${c2ri(ci)}$lascl( 'G', 0, 0, smlnum, anrm, minmn, 1, s, minmn,info ) else if( iascl==2 ) then - call stdlib_wlascl( 'G', 0, 0, anrm, bignum, n, nrhs, b, ldb, info ) - call stdlib_qlascl( 'G', 0, 0, bignum, anrm, minmn, 1, s, minmn,info ) + call stdlib_${ci}$lascl( 'G', 0, 0, anrm, bignum, n, nrhs, b, ldb, info ) + call stdlib_${c2ri(ci)}$lascl( 'G', 0, 0, bignum, anrm, minmn, 1, s, minmn,info ) end if if( ibscl==1 ) then - call stdlib_wlascl( 'G', 0, 0, smlnum, bnrm, n, nrhs, b, ldb, info ) + call stdlib_${ci}$lascl( 'G', 0, 0, smlnum, bnrm, n, nrhs, b, ldb, info ) else if( ibscl==2 ) then - call stdlib_wlascl( 'G', 0, 0, bignum, bnrm, n, nrhs, b, ldb, info ) + call stdlib_${ci}$lascl( 'G', 0, 0, bignum, bnrm, n, nrhs, b, ldb, info ) end if 70 continue work( 1 ) = maxwrk return - end subroutine stdlib_wgelss + end subroutine stdlib_${ci}$gelss - subroutine stdlib_wgelsy( m, n, nrhs, a, lda, b, ldb, jpvt, rcond, rank,work, lwork, rwork, & + subroutine stdlib_${ci}$gelsy( m, n, nrhs, a, lda, b, ldb, jpvt, rcond, rank,work, lwork, rwork, & !! ZGELSY: computes the minimum-norm solution to a complex linear least !! squares problem: !! minimize || A * X - B || @@ -8503,12 +8505,12 @@ module stdlib_linalg_lapack_w ! Scalar Arguments integer(ilp), intent(out) :: info, rank integer(ilp), intent(in) :: lda, ldb, lwork, m, n, nrhs - real(qp), intent(in) :: rcond + real(${ck}$), intent(in) :: rcond ! Array Arguments integer(ilp), intent(inout) :: jpvt(*) - real(qp), intent(out) :: rwork(*) - complex(qp), intent(inout) :: a(lda,*), b(ldb,*) - complex(qp), intent(out) :: work(*) + real(${ck}$), intent(out) :: rwork(*) + complex(${ck}$), intent(inout) :: a(lda,*), b(ldb,*) + complex(${ck}$), intent(out) :: work(*) ! ===================================================================== ! Parameters integer(ilp), parameter :: imax = 1 @@ -8520,8 +8522,8 @@ module stdlib_linalg_lapack_w logical(lk) :: lquery integer(ilp) :: i, iascl, ibscl, ismax, ismin, j, lwkopt, mn, nb, nb1, nb2, nb3, & nb4 - real(qp) :: anrm, bignum, bnrm, smax, smaxpr, smin, sminpr, smlnum, wsize - complex(qp) :: c1, c2, s1, s2 + real(${ck}$) :: anrm, bignum, bnrm, smax, smaxpr, smin, sminpr, smlnum, wsize + complex(${ck}$) :: c1, c2, s1, s2 ! Intrinsic Functions intrinsic :: abs,real,cmplx,max,min ! Executable Statements @@ -8536,7 +8538,7 @@ module stdlib_linalg_lapack_w nb4 = stdlib_ilaenv( 1, 'ZUNMRQ', ' ', m, n, nrhs, -1 ) nb = max( nb1, nb2, nb3, nb4 ) lwkopt = max( 1, mn+2*n+nb*( n+1 ), 2*mn+nb*nrhs ) - work( 1 ) = cmplx( lwkopt,KIND=qp) + work( 1 ) = cmplx( lwkopt,KIND=${ck}$) lquery = ( lwork==-1 ) if( m<0 ) then info = -1 @@ -8563,42 +8565,42 @@ module stdlib_linalg_lapack_w return end if ! get machine parameters - smlnum = stdlib_qlamch( 'S' ) / stdlib_qlamch( 'P' ) + smlnum = stdlib_${c2ri(ci)}$lamch( 'S' ) / stdlib_${c2ri(ci)}$lamch( 'P' ) bignum = one / smlnum - call stdlib_qlabad( smlnum, bignum ) + call stdlib_${c2ri(ci)}$labad( smlnum, bignum ) ! scale a, b if max entries outside range [smlnum,bignum] - anrm = stdlib_wlange( 'M', m, n, a, lda, rwork ) + anrm = stdlib_${ci}$lange( 'M', m, n, a, lda, rwork ) iascl = 0 if( anrm>zero .and. anrmbignum ) then ! scale matrix norm down to bignum - call stdlib_wlascl( 'G', 0, 0, anrm, bignum, m, n, a, lda, info ) + call stdlib_${ci}$lascl( 'G', 0, 0, anrm, bignum, m, n, a, lda, info ) iascl = 2 else if( anrm==zero ) then ! matrix all zero. return zero solution. - call stdlib_wlaset( 'F', max( m, n ), nrhs, czero, czero, b, ldb ) + call stdlib_${ci}$laset( 'F', max( m, n ), nrhs, czero, czero, b, ldb ) rank = 0 go to 70 end if - bnrm = stdlib_wlange( 'M', m, nrhs, b, ldb, rwork ) + bnrm = stdlib_${ci}$lange( 'M', m, nrhs, b, ldb, rwork ) ibscl = 0 if( bnrm>zero .and. bnrmbignum ) then ! scale matrix norm down to bignum - call stdlib_wlascl( 'G', 0, 0, bnrm, bignum, m, nrhs, b, ldb, info ) + call stdlib_${ci}$lascl( 'G', 0, 0, bnrm, bignum, m, nrhs, b, ldb, info ) ibscl = 2 end if ! compute qr factorization with column pivoting of a: ! a * p = q * r - call stdlib_wgeqp3( m, n, a, lda, jpvt, work( 1 ), work( mn+1 ),lwork-mn, rwork, info ) + call stdlib_${ci}$geqp3( m, n, a, lda, jpvt, work( 1 ), work( mn+1 ),lwork-mn, rwork, info ) - wsize = mn + real( work( mn+1 ),KIND=qp) + wsize = mn + real( work( mn+1 ),KIND=${ck}$) ! complex workspace: mn+nb*(n+1). real workspace 2*n. ! details of householder rotations stored in work(1:mn). ! determine rank using incremental condition estimation @@ -8608,7 +8610,7 @@ module stdlib_linalg_lapack_w smin = smax if( abs( a( 1, 1 ) )==zero ) then rank = 0 - call stdlib_wlaset( 'F', max( m, n ), nrhs, czero, czero, b, ldb ) + call stdlib_${ci}$laset( 'F', max( m, n ), nrhs, czero, czero, b, ldb ) go to 70 else rank = 1 @@ -8616,9 +8618,9 @@ module stdlib_linalg_lapack_w 10 continue if( rank=max( m, n, & k ) ) ) then - call stdlib_wgemlqt( side, trans, m, n, k, mb, a, lda,t( 6 ), mb, c, ldc, work, info & + call stdlib_${ci}$gemlqt( side, trans, m, n, k, mb, a, lda,t( 6 ), mb, c, ldc, work, info & ) else - call stdlib_wlamswlq( side, trans, m, n, k, mb, nb, a, lda, t( 6 ),mb, c, ldc, work, & + call stdlib_${ci}$lamswlq( side, trans, m, n, k, mb, nb, a, lda, t( 6 ),mb, c, ldc, work, & lwork, info ) end if work( 1 ) = lw return - end subroutine stdlib_wgemlq + end subroutine stdlib_${ci}$gemlq - pure subroutine stdlib_wgemlqt( side, trans, m, n, k, mb, v, ldv, t, ldt,c, ldc, work, info ) + pure subroutine stdlib_${ci}$gemlqt( side, trans, m, n, k, mb, v, ldv, t, ldt,c, ldc, work, info ) !! ZGEMLQT: overwrites the general complex M-by-N matrix C with !! SIDE = 'L' SIDE = 'R' !! TRANS = 'N': Q C C Q @@ -8804,9 +8806,9 @@ module stdlib_linalg_lapack_w integer(ilp), intent(out) :: info integer(ilp), intent(in) :: k, ldv, ldc, m, n, mb, ldt ! Array Arguments - complex(qp), intent(in) :: v(ldv,*), t(ldt,*) - complex(qp), intent(inout) :: c(ldc,*) - complex(qp), intent(out) :: work(*) + complex(${ck}$), intent(in) :: v(ldv,*), t(ldt,*) + complex(${ck}$), intent(inout) :: c(ldc,*) + complex(${ck}$), intent(out) :: work(*) ! ===================================================================== ! Local Scalars logical(lk) :: left, right, tran, notran @@ -8855,35 +8857,35 @@ module stdlib_linalg_lapack_w if( left .and. notran ) then do i = 1, k, mb ib = min( mb, k-i+1 ) - call stdlib_wlarfb( 'L', 'C', 'F', 'R', m-i+1, n, ib,v( i, i ), ldv, t( 1, i ), & + call stdlib_${ci}$larfb( 'L', 'C', 'F', 'R', m-i+1, n, ib,v( i, i ), ldv, t( 1, i ), & ldt,c( i, 1 ), ldc, work, ldwork ) end do else if( right .and. tran ) then do i = 1, k, mb ib = min( mb, k-i+1 ) - call stdlib_wlarfb( 'R', 'N', 'F', 'R', m, n-i+1, ib,v( i, i ), ldv, t( 1, i ), & + call stdlib_${ci}$larfb( 'R', 'N', 'F', 'R', m, n-i+1, ib,v( i, i ), ldv, t( 1, i ), & ldt,c( 1, i ), ldc, work, ldwork ) end do else if( left .and. tran ) then kf = ((k-1)/mb)*mb+1 do i = kf, 1, -mb ib = min( mb, k-i+1 ) - call stdlib_wlarfb( 'L', 'N', 'F', 'R', m-i+1, n, ib,v( i, i ), ldv, t( 1, i ), & + call stdlib_${ci}$larfb( 'L', 'N', 'F', 'R', m-i+1, n, ib,v( i, i ), ldv, t( 1, i ), & ldt,c( i, 1 ), ldc, work, ldwork ) end do else if( right .and. notran ) then kf = ((k-1)/mb)*mb+1 do i = kf, 1, -mb ib = min( mb, k-i+1 ) - call stdlib_wlarfb( 'R', 'C', 'F', 'R', m, n-i+1, ib,v( i, i ), ldv, t( 1, i ), & + call stdlib_${ci}$larfb( 'R', 'C', 'F', 'R', m, n-i+1, ib,v( i, i ), ldv, t( 1, i ), & ldt,c( 1, i ), ldc, work, ldwork ) end do end if return - end subroutine stdlib_wgemlqt + end subroutine stdlib_${ci}$gemlqt - pure subroutine stdlib_wgemqr( side, trans, m, n, k, a, lda, t, tsize,c, ldc, work, lwork, & + pure subroutine stdlib_${ci}$gemqr( side, trans, m, n, k, a, lda, t, tsize,c, ldc, work, lwork, & !! ZGEMQR: overwrites the general real M-by-N matrix C with !! SIDE = 'L' SIDE = 'R' !! TRANS = 'N': Q * C C * Q @@ -8900,9 +8902,9 @@ module stdlib_linalg_lapack_w integer(ilp), intent(out) :: info integer(ilp), intent(in) :: lda, m, n, k, tsize, lwork, ldc ! Array Arguments - complex(qp), intent(in) :: a(lda,*), t(*) - complex(qp), intent(inout) :: c(ldc,*) - complex(qp), intent(out) :: work(*) + complex(${ck}$), intent(in) :: a(lda,*), t(*) + complex(${ck}$), intent(inout) :: c(ldc,*) + complex(${ck}$), intent(out) :: work(*) ! ===================================================================== ! Local Scalars logical(lk) :: left, right, tran, notran, lquery @@ -8969,18 +8971,18 @@ module stdlib_linalg_lapack_w end if if( ( left .and. m<=k ) .or. ( right .and. n<=k ).or. ( mb<=k ) .or. ( mb>=max( m, n, & k ) ) ) then - call stdlib_wgemqrt( side, trans, m, n, k, nb, a, lda, t( 6 ),nb, c, ldc, work, info & + call stdlib_${ci}$gemqrt( side, trans, m, n, k, nb, a, lda, t( 6 ),nb, c, ldc, work, info & ) else - call stdlib_wlamtsqr( side, trans, m, n, k, mb, nb, a, lda, t( 6 ),nb, c, ldc, work, & + call stdlib_${ci}$lamtsqr( side, trans, m, n, k, mb, nb, a, lda, t( 6 ),nb, c, ldc, work, & lwork, info ) end if work( 1 ) = lw return - end subroutine stdlib_wgemqr + end subroutine stdlib_${ci}$gemqr - pure subroutine stdlib_wgemqrt( side, trans, m, n, k, nb, v, ldv, t, ldt,c, ldc, work, info ) + pure subroutine stdlib_${ci}$gemqrt( side, trans, m, n, k, nb, v, ldv, t, ldt,c, ldc, work, info ) !! ZGEMQRT: overwrites the general complex M-by-N matrix C with !! SIDE = 'L' SIDE = 'R' !! TRANS = 'N': Q C C Q @@ -8999,9 +9001,9 @@ module stdlib_linalg_lapack_w integer(ilp), intent(out) :: info integer(ilp), intent(in) :: k, ldv, ldc, m, n, nb, ldt ! Array Arguments - complex(qp), intent(in) :: v(ldv,*), t(ldt,*) - complex(qp), intent(inout) :: c(ldc,*) - complex(qp), intent(out) :: work(*) + complex(${ck}$), intent(in) :: v(ldv,*), t(ldt,*) + complex(${ck}$), intent(inout) :: c(ldc,*) + complex(${ck}$), intent(out) :: work(*) ! ===================================================================== ! Local Scalars logical(lk) :: left, right, tran, notran @@ -9050,35 +9052,35 @@ module stdlib_linalg_lapack_w if( left .and. tran ) then do i = 1, k, nb ib = min( nb, k-i+1 ) - call stdlib_wlarfb( 'L', 'C', 'F', 'C', m-i+1, n, ib,v( i, i ), ldv, t( 1, i ), & + call stdlib_${ci}$larfb( 'L', 'C', 'F', 'C', m-i+1, n, ib,v( i, i ), ldv, t( 1, i ), & ldt,c( i, 1 ), ldc, work, ldwork ) end do else if( right .and. notran ) then do i = 1, k, nb ib = min( nb, k-i+1 ) - call stdlib_wlarfb( 'R', 'N', 'F', 'C', m, n-i+1, ib,v( i, i ), ldv, t( 1, i ), & + call stdlib_${ci}$larfb( 'R', 'N', 'F', 'C', m, n-i+1, ib,v( i, i ), ldv, t( 1, i ), & ldt,c( 1, i ), ldc, work, ldwork ) end do else if( left .and. notran ) then kf = ((k-1)/nb)*nb+1 do i = kf, 1, -nb ib = min( nb, k-i+1 ) - call stdlib_wlarfb( 'L', 'N', 'F', 'C', m-i+1, n, ib,v( i, i ), ldv, t( 1, i ), & + call stdlib_${ci}$larfb( 'L', 'N', 'F', 'C', m-i+1, n, ib,v( i, i ), ldv, t( 1, i ), & ldt,c( i, 1 ), ldc, work, ldwork ) end do else if( right .and. tran ) then kf = ((k-1)/nb)*nb+1 do i = kf, 1, -nb ib = min( nb, k-i+1 ) - call stdlib_wlarfb( 'R', 'C', 'F', 'C', m, n-i+1, ib,v( i, i ), ldv, t( 1, i ), & + call stdlib_${ci}$larfb( 'R', 'C', 'F', 'C', m, n-i+1, ib,v( i, i ), ldv, t( 1, i ), & ldt,c( 1, i ), ldc, work, ldwork ) end do end if return - end subroutine stdlib_wgemqrt + end subroutine stdlib_${ci}$gemqrt - pure subroutine stdlib_wgeql2( m, n, a, lda, tau, work, info ) + pure subroutine stdlib_${ci}$geql2( m, n, a, lda, tau, work, info ) !! ZGEQL2: computes a QL factorization of a complex m by n matrix A: !! A = Q * L. ! -- lapack computational routine -- @@ -9088,13 +9090,13 @@ module stdlib_linalg_lapack_w integer(ilp), intent(out) :: info integer(ilp), intent(in) :: lda, m, n ! Array Arguments - complex(qp), intent(inout) :: a(lda,*) - complex(qp), intent(out) :: tau(*), work(*) + complex(${ck}$), intent(inout) :: a(lda,*) + complex(${ck}$), intent(out) :: tau(*), work(*) ! ===================================================================== ! Local Scalars integer(ilp) :: i, k - complex(qp) :: alpha + complex(${ck}$) :: alpha ! Intrinsic Functions intrinsic :: conjg,max,min ! Executable Statements @@ -9116,18 +9118,18 @@ module stdlib_linalg_lapack_w ! generate elementary reflector h(i) to annihilate ! a(1:m-k+i-1,n-k+i) alpha = a( m-k+i, n-k+i ) - call stdlib_wlarfg( m-k+i, alpha, a( 1, n-k+i ), 1, tau( i ) ) + call stdlib_${ci}$larfg( m-k+i, alpha, a( 1, n-k+i ), 1, tau( i ) ) ! apply h(i)**h to a(1:m-k+i,1:n-k+i-1) from the left a( m-k+i, n-k+i ) = cone - call stdlib_wlarf( 'LEFT', m-k+i, n-k+i-1, a( 1, n-k+i ), 1,conjg( tau( i ) ), a, & + call stdlib_${ci}$larf( 'LEFT', m-k+i, n-k+i-1, a( 1, n-k+i ), 1,conjg( tau( i ) ), a, & lda, work ) a( m-k+i, n-k+i ) = alpha end do return - end subroutine stdlib_wgeql2 + end subroutine stdlib_${ci}$geql2 - pure subroutine stdlib_wgeqlf( m, n, a, lda, tau, work, lwork, info ) + pure subroutine stdlib_${ci}$geqlf( m, n, a, lda, tau, work, lwork, info ) !! ZGEQLF: computes a QL factorization of a complex M-by-N matrix A: !! A = Q * L. ! -- lapack computational routine -- @@ -9137,8 +9139,8 @@ module stdlib_linalg_lapack_w integer(ilp), intent(out) :: info integer(ilp), intent(in) :: lda, lwork, m, n ! Array Arguments - complex(qp), intent(inout) :: a(lda,*) - complex(qp), intent(out) :: tau(*), work(*) + complex(${ck}$), intent(inout) :: a(lda,*) + complex(${ck}$), intent(out) :: tau(*), work(*) ! ===================================================================== ! Local Scalars logical(lk) :: lquery @@ -9207,15 +9209,15 @@ module stdlib_linalg_lapack_w ib = min( k-i+1, nb ) ! compute the ql factorization of the current block ! a(1:m-k+i+ib-1,n-k+i:n-k+i+ib-1) - call stdlib_wgeql2( m-k+i+ib-1, ib, a( 1, n-k+i ), lda, tau( i ),work, iinfo ) + call stdlib_${ci}$geql2( m-k+i+ib-1, ib, a( 1, n-k+i ), lda, tau( i ),work, iinfo ) if( n-k+i>1 ) then ! form the triangular factor of the block reflector ! h = h(i+ib-1) . . . h(i+1) h(i) - call stdlib_wlarft( 'BACKWARD', 'COLUMNWISE', m-k+i+ib-1, ib,a( 1, n-k+i ), & + call stdlib_${ci}$larft( 'BACKWARD', 'COLUMNWISE', m-k+i+ib-1, ib,a( 1, n-k+i ), & lda, tau( i ), work, ldwork ) ! apply h**h to a(1:m-k+i+ib-1,1:n-k+i-1) from the left - call stdlib_wlarfb( 'LEFT', 'CONJUGATE TRANSPOSE', 'BACKWARD','COLUMNWISE', m-& + call stdlib_${ci}$larfb( 'LEFT', 'CONJUGATE TRANSPOSE', 'BACKWARD','COLUMNWISE', m-& k+i+ib-1, n-k+i-1, ib,a( 1, n-k+i ), lda, work, ldwork, a, lda,work( ib+1 ), & ldwork ) end if @@ -9227,13 +9229,13 @@ module stdlib_linalg_lapack_w nu = n end if ! use unblocked code to factor the last or only block - if( mu>0 .and. nu>0 )call stdlib_wgeql2( mu, nu, a, lda, tau, work, iinfo ) + if( mu>0 .and. nu>0 )call stdlib_${ci}$geql2( mu, nu, a, lda, tau, work, iinfo ) work( 1 ) = iws return - end subroutine stdlib_wgeqlf + end subroutine stdlib_${ci}$geqlf - pure subroutine stdlib_wgeqp3( m, n, a, lda, jpvt, tau, work, lwork, rwork,info ) + pure subroutine stdlib_${ci}$geqp3( m, n, a, lda, jpvt, tau, work, lwork, rwork,info ) !! ZGEQP3: computes a QR factorization with column pivoting of a !! matrix A: A*P = Q*R using Level 3 BLAS. ! -- lapack computational routine -- @@ -9244,9 +9246,9 @@ module stdlib_linalg_lapack_w integer(ilp), intent(in) :: lda, lwork, m, n ! Array Arguments integer(ilp), intent(inout) :: jpvt(*) - real(qp), intent(out) :: rwork(*) - complex(qp), intent(inout) :: a(lda,*) - complex(qp), intent(out) :: tau(*), work(*) + real(${ck}$), intent(out) :: rwork(*) + complex(${ck}$), intent(inout) :: a(lda,*) + complex(${ck}$), intent(out) :: tau(*), work(*) ! ===================================================================== ! Parameters integer(ilp), parameter :: inb = 1 @@ -9281,7 +9283,7 @@ module stdlib_linalg_lapack_w nb = stdlib_ilaenv( inb, 'ZGEQRF', ' ', m, n, -1, -1 ) lwkopt = ( n + 1 )*nb end if - work( 1 ) = cmplx( lwkopt,KIND=qp) + work( 1 ) = cmplx( lwkopt,KIND=${ck}$) if( ( lwork0 ) then na = min( m, nfxd ) - ! cc call stdlib_wgeqr2( m, na, a, lda, tau, work, info ) - call stdlib_wgeqrf( m, na, a, lda, tau, work, lwork, info ) + ! cc call stdlib_${ci}$geqr2( m, na, a, lda, tau, work, info ) + call stdlib_${ci}$geqrf( m, na, a, lda, tau, work, lwork, info ) iws = max( iws, int( work( 1 ),KIND=ilp) ) if( na=nbmin ) .and. ( nb=m ) ) then - call stdlib_wgeqrt( m, n, nb, a, lda, t( 6 ), nb, work, info ) + call stdlib_${ci}$geqrt( m, n, nb, a, lda, t( 6 ), nb, work, info ) else - call stdlib_wlatsqr( m, n, mb, nb, a, lda, t( 6 ), nb, work,lwork, info ) + call stdlib_${ci}$latsqr( m, n, mb, nb, a, lda, t( 6 ), nb, work,lwork, info ) end if work( 1 ) = max( 1, nb*n ) return - end subroutine stdlib_wgeqr + end subroutine stdlib_${ci}$geqr - pure subroutine stdlib_wgeqr2( m, n, a, lda, tau, work, info ) + pure subroutine stdlib_${ci}$geqr2( m, n, a, lda, tau, work, info ) !! ZGEQR2: computes a QR factorization of a complex m-by-n matrix A: !! A = Q * ( R ), !! ( 0 ) @@ -9515,13 +9517,13 @@ module stdlib_linalg_lapack_w integer(ilp), intent(out) :: info integer(ilp), intent(in) :: lda, m, n ! Array Arguments - complex(qp), intent(inout) :: a(lda,*) - complex(qp), intent(out) :: tau(*), work(*) + complex(${ck}$), intent(inout) :: a(lda,*) + complex(${ck}$), intent(out) :: tau(*), work(*) ! ===================================================================== ! Local Scalars integer(ilp) :: i, k - complex(qp) :: alpha + complex(${ck}$) :: alpha ! Intrinsic Functions intrinsic :: conjg,max,min ! Executable Statements @@ -9541,21 +9543,21 @@ module stdlib_linalg_lapack_w k = min( m, n ) do i = 1, k ! generate elementary reflector h(i) to annihilate a(i+1:m,i) - call stdlib_wlarfg( m-i+1, a( i, i ), a( min( i+1, m ), i ), 1,tau( i ) ) + call stdlib_${ci}$larfg( m-i+1, a( i, i ), a( min( i+1, m ), i ), 1,tau( i ) ) if( i t(i,1) - call stdlib_wlarfg( m-i+1, a( i, i ), a( min( i+1, m ), i ), 1,t( i, 1 ) ) + call stdlib_${ci}$larfg( m-i+1, a( i, i ), a( min( i+1, m ), i ), 1,t( i, 1 ) ) if( ieps .and. two*berr( j )<=lstres .and.count<=itmax ) then ! update solution and try again. - call stdlib_wgetrs( trans, n, 1, af, ldaf, ipiv, work, n, info ) - call stdlib_waxpy( n, cone, work, 1, x( 1, j ), 1 ) + call stdlib_${ci}$getrs( trans, n, 1, af, ldaf, ipiv, work, n, info ) + call stdlib_${ci}$axpy( n, cone, work, 1, x( 1, j ), 1 ) lstres = berr( j ) count = count + 1 go to 20 @@ -10182,7 +10184,7 @@ module stdlib_linalg_lapack_w ! the i-th component of abs(r)+nz*eps*(abs(op(a))*abs(x)+abs(b)) ! is incremented by safe1 if the i-th component of ! abs(op(a))*abs(x) + abs(b) is less than safe2. - ! use stdlib_wlacn2 to estimate the infinity-norm of the matrix + ! use stdlib_${ci}$lacn2 to estimate the infinity-norm of the matrix ! inv(op(a)) * diag(w), ! where w = abs(r) + nz*eps*( abs(op(a))*abs(x)+abs(b) ))) do i = 1, n @@ -10194,11 +10196,11 @@ module stdlib_linalg_lapack_w end do kase = 0 100 continue - call stdlib_wlacn2( n, work( n+1 ), work, ferr( j ), kase, isave ) + call stdlib_${ci}$lacn2( n, work( n+1 ), work, ferr( j ), kase, isave ) if( kase/=0 ) then if( kase==1 ) then ! multiply by diag(w)*inv(op(a)**h). - call stdlib_wgetrs( transt, n, 1, af, ldaf, ipiv, work, n,info ) + call stdlib_${ci}$getrs( transt, n, 1, af, ldaf, ipiv, work, n,info ) do i = 1, n work( i ) = rwork( i )*work( i ) end do @@ -10207,7 +10209,7 @@ module stdlib_linalg_lapack_w do i = 1, n work( i ) = rwork( i )*work( i ) end do - call stdlib_wgetrs( transn, n, 1, af, ldaf, ipiv, work, n,info ) + call stdlib_${ci}$getrs( transn, n, 1, af, ldaf, ipiv, work, n,info ) end if go to 100 end if @@ -10219,10 +10221,10 @@ module stdlib_linalg_lapack_w if( lstres/=zero )ferr( j ) = ferr( j ) / lstres end do loop_140 return - end subroutine stdlib_wgerfs + end subroutine stdlib_${ci}$gerfs - pure subroutine stdlib_wgerq2( m, n, a, lda, tau, work, info ) + pure subroutine stdlib_${ci}$gerq2( m, n, a, lda, tau, work, info ) !! ZGERQ2: computes an RQ factorization of a complex m by n matrix A: !! A = R * Q. ! -- lapack computational routine -- @@ -10232,13 +10234,13 @@ module stdlib_linalg_lapack_w integer(ilp), intent(out) :: info integer(ilp), intent(in) :: lda, m, n ! Array Arguments - complex(qp), intent(inout) :: a(lda,*) - complex(qp), intent(out) :: tau(*), work(*) + complex(${ck}$), intent(inout) :: a(lda,*) + complex(${ck}$), intent(out) :: tau(*), work(*) ! ===================================================================== ! Local Scalars integer(ilp) :: i, k - complex(qp) :: alpha + complex(${ck}$) :: alpha ! Intrinsic Functions intrinsic :: max,min ! Executable Statements @@ -10259,21 +10261,21 @@ module stdlib_linalg_lapack_w do i = k, 1, -1 ! generate elementary reflector h(i) to annihilate ! a(m-k+i,1:n-k+i-1) - call stdlib_wlacgv( n-k+i, a( m-k+i, 1 ), lda ) + call stdlib_${ci}$lacgv( n-k+i, a( m-k+i, 1 ), lda ) alpha = a( m-k+i, n-k+i ) - call stdlib_wlarfg( n-k+i, alpha, a( m-k+i, 1 ), lda, tau( i ) ) + call stdlib_${ci}$larfg( n-k+i, alpha, a( m-k+i, 1 ), lda, tau( i ) ) ! apply h(i) to a(1:m-k+i-1,1:n-k+i) from the right a( m-k+i, n-k+i ) = cone - call stdlib_wlarf( 'RIGHT', m-k+i-1, n-k+i, a( m-k+i, 1 ), lda,tau( i ), a, lda, & + call stdlib_${ci}$larf( 'RIGHT', m-k+i-1, n-k+i, a( m-k+i, 1 ), lda,tau( i ), a, lda, & work ) a( m-k+i, n-k+i ) = alpha - call stdlib_wlacgv( n-k+i-1, a( m-k+i, 1 ), lda ) + call stdlib_${ci}$lacgv( n-k+i-1, a( m-k+i, 1 ), lda ) end do return - end subroutine stdlib_wgerq2 + end subroutine stdlib_${ci}$gerq2 - pure subroutine stdlib_wgerqf( m, n, a, lda, tau, work, lwork, info ) + pure subroutine stdlib_${ci}$gerqf( m, n, a, lda, tau, work, lwork, info ) !! ZGERQF: computes an RQ factorization of a complex M-by-N matrix A: !! A = R * Q. ! -- lapack computational routine -- @@ -10283,8 +10285,8 @@ module stdlib_linalg_lapack_w integer(ilp), intent(out) :: info integer(ilp), intent(in) :: lda, lwork, m, n ! Array Arguments - complex(qp), intent(inout) :: a(lda,*) - complex(qp), intent(out) :: tau(*), work(*) + complex(${ck}$), intent(inout) :: a(lda,*) + complex(${ck}$), intent(out) :: tau(*), work(*) ! ===================================================================== ! Local Scalars logical(lk) :: lquery @@ -10353,15 +10355,15 @@ module stdlib_linalg_lapack_w ib = min( k-i+1, nb ) ! compute the rq factorization of the current block ! a(m-k+i:m-k+i+ib-1,1:n-k+i+ib-1) - call stdlib_wgerq2( ib, n-k+i+ib-1, a( m-k+i, 1 ), lda, tau( i ),work, iinfo ) + call stdlib_${ci}$gerq2( ib, n-k+i+ib-1, a( m-k+i, 1 ), lda, tau( i ),work, iinfo ) if( m-k+i>1 ) then ! form the triangular factor of the block reflector ! h = h(i+ib-1) . . . h(i+1) h(i) - call stdlib_wlarft( 'BACKWARD', 'ROWWISE', n-k+i+ib-1, ib,a( m-k+i, 1 ), lda, & + call stdlib_${ci}$larft( 'BACKWARD', 'ROWWISE', n-k+i+ib-1, ib,a( m-k+i, 1 ), lda, & tau( i ), work, ldwork ) ! apply h to a(1:m-k+i-1,1:n-k+i+ib-1) from the right - call stdlib_wlarfb( 'RIGHT', 'NO TRANSPOSE', 'BACKWARD','ROWWISE', m-k+i-1, n-& + call stdlib_${ci}$larfb( 'RIGHT', 'NO TRANSPOSE', 'BACKWARD','ROWWISE', m-k+i-1, n-& k+i+ib-1, ib,a( m-k+i, 1 ), lda, work, ldwork, a, lda,work( ib+1 ), ldwork ) end if @@ -10373,13 +10375,13 @@ module stdlib_linalg_lapack_w nu = n end if ! use unblocked code to factor the last or only block - if( mu>0 .and. nu>0 )call stdlib_wgerq2( mu, nu, a, lda, tau, work, iinfo ) + if( mu>0 .and. nu>0 )call stdlib_${ci}$gerq2( mu, nu, a, lda, tau, work, iinfo ) work( 1 ) = iws return - end subroutine stdlib_wgerqf + end subroutine stdlib_${ci}$gerqf - pure subroutine stdlib_wgesc2( n, a, lda, rhs, ipiv, jpiv, scale ) + pure subroutine stdlib_${ci}$gesc2( n, a, lda, rhs, ipiv, jpiv, scale ) !! ZGESC2: solves a system of linear equations !! A * X = scale* RHS !! with a general N-by-N matrix A using the LU factorization with @@ -10389,27 +10391,27 @@ module stdlib_linalg_lapack_w ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments integer(ilp), intent(in) :: lda, n - real(qp), intent(out) :: scale + real(${ck}$), intent(out) :: scale ! Array Arguments integer(ilp), intent(in) :: ipiv(*), jpiv(*) - complex(qp), intent(in) :: a(lda,*) - complex(qp), intent(inout) :: rhs(*) + complex(${ck}$), intent(in) :: a(lda,*) + complex(${ck}$), intent(inout) :: rhs(*) ! ===================================================================== ! Local Scalars integer(ilp) :: i, j - real(qp) :: bignum, eps, smlnum - complex(qp) :: temp + real(${ck}$) :: bignum, eps, smlnum + complex(${ck}$) :: temp ! Intrinsic Functions intrinsic :: abs,real,cmplx ! Executable Statements ! set constant to control overflow - eps = stdlib_qlamch( 'P' ) - smlnum = stdlib_qlamch( 'S' ) / eps + eps = stdlib_${c2ri(ci)}$lamch( 'P' ) + smlnum = stdlib_${c2ri(ci)}$lamch( 'S' ) / eps bignum = one / smlnum - call stdlib_qlabad( smlnum, bignum ) + call stdlib_${c2ri(ci)}$labad( smlnum, bignum ) ! apply permutations ipiv to rhs - call stdlib_wlaswp( 1, rhs, lda, 1, n-1, ipiv, 1 ) + call stdlib_${ci}$laswp( 1, rhs, lda, 1, n-1, ipiv, 1 ) ! solve for l part do i = 1, n - 1 do j = i + 1, n @@ -10419,26 +10421,26 @@ module stdlib_linalg_lapack_w ! solve for u part scale = one ! check for scaling - i = stdlib_iwamax( n, rhs, 1 ) + i = stdlib_i${ci}$amax( n, rhs, 1 ) if( two*smlnum*abs( rhs( i ) )>abs( a( n, n ) ) ) then - temp = cmplx( one / two, zero,KIND=qp) / abs( rhs( i ) ) - call stdlib_wscal( n, temp, rhs( 1 ), 1 ) - scale = scale*real( temp,KIND=qp) + temp = cmplx( one / two, zero,KIND=${ck}$) / abs( rhs( i ) ) + call stdlib_${ci}$scal( n, temp, rhs( 1 ), 1 ) + scale = scale*real( temp,KIND=${ck}$) end if do i = n, 1, -1 - temp = cmplx( one, zero,KIND=qp) / a( i, i ) + temp = cmplx( one, zero,KIND=${ck}$) / a( i, i ) rhs( i ) = rhs( i )*temp do j = i + 1, n rhs( i ) = rhs( i ) - rhs( j )*( a( i, j )*temp ) end do end do ! apply permutations jpiv to the solution (rhs) - call stdlib_wlaswp( 1, rhs, lda, 1, n-1, jpiv, -1 ) + call stdlib_${ci}$laswp( 1, rhs, lda, 1, n-1, jpiv, -1 ) return - end subroutine stdlib_wgesc2 + end subroutine stdlib_${ci}$gesc2 - subroutine stdlib_wgesdd( jobz, m, n, a, lda, s, u, ldu, vt, ldvt,work, lwork, rwork, iwork, & + subroutine stdlib_${ci}$gesdd( jobz, m, n, a, lda, s, u, ldu, vt, ldvt,work, lwork, rwork, iwork, & !! ZGESDD: computes the singular value decomposition (SVD) of a complex !! M-by-N matrix A, optionally computing the left and/or right singular !! vectors, by using divide-and-conquer method. The SVD is written @@ -10466,9 +10468,9 @@ module stdlib_linalg_lapack_w integer(ilp), intent(in) :: lda, ldu, ldvt, lwork, m, n ! Array Arguments integer(ilp), intent(out) :: iwork(*) - real(qp), intent(out) :: rwork(*), s(*) - complex(qp), intent(inout) :: a(lda,*) - complex(qp), intent(out) :: u(ldu,*), vt(ldvt,*), work(*) + real(${ck}$), intent(out) :: rwork(*), s(*) + complex(${ck}$), intent(inout) :: a(lda,*) + complex(${ck}$), intent(out) :: u(ldu,*), vt(ldvt,*), work(*) ! ===================================================================== @@ -10482,19 +10484,19 @@ module stdlib_linalg_lapack_w lwork_wungbr_q_mm, lwork_wunglq_mn, lwork_wunglq_nn, lwork_wungqr_mm, lwork_wungqr_mn, & lwork_wunmbr_prc_mm, lwork_wunmbr_qln_mm, lwork_wunmbr_prc_mn, lwork_wunmbr_qln_mn, & lwork_wunmbr_prc_nn, lwork_wunmbr_qln_nn - real(qp) :: anrm, bignum, eps, smlnum + real(${ck}$) :: anrm, bignum, eps, smlnum ! Local Arrays integer(ilp) :: idum(1) - real(qp) :: dum(1) - complex(qp) :: cdum(1) + real(${ck}$) :: dum(1) + complex(${ck}$) :: cdum(1) ! Intrinsic Functions intrinsic :: int,max,min,sqrt ! Executable Statements ! test the input arguments info = 0 minmn = min( m, n ) - mnthr1 = int( minmn*17.0_qp / 9.0_qp,KIND=ilp) - mnthr2 = int( minmn*5.0_qp / 3.0_qp,KIND=ilp) + mnthr1 = int( minmn*17.0_${ck}$ / 9.0_${ck}$,KIND=ilp) + mnthr2 = int( minmn*5.0_${ck}$ / 3.0_${ck}$,KIND=ilp) wntqa = stdlib_lsame( jobz, 'A' ) wntqs = stdlib_lsame( jobz, 'S' ) wntqas = wntqa .or. wntqs @@ -10530,39 +10532,39 @@ module stdlib_linalg_lapack_w maxwrk = 1 if( m>=n .and. minmn>0 ) then ! there is no complex work space needed for bidiagonal svd - ! the realwork space needed for bidiagonal svd (stdlib_qbdsdc,KIND=qp) is + ! the realwork space needed for bidiagonal svd (stdlib_${c2ri(ci)}$bdsdc,KIND=${ck}$) is ! bdspac = 3*n*n + 4*n for singular values and vectors; ! bdspac = 4*n for singular values only; ! not including e, ru, and rvt matrices. ! compute space preferred for each routine - call stdlib_wgebrd( m, n, cdum(1), m, dum(1), dum(1), cdum(1),cdum(1), cdum(1), -& + call stdlib_${ci}$gebrd( m, n, cdum(1), m, dum(1), dum(1), cdum(1),cdum(1), cdum(1), -& 1, ierr ) lwork_wgebrd_mn = int( cdum(1),KIND=ilp) - call stdlib_wgebrd( n, n, cdum(1), n, dum(1), dum(1), cdum(1),cdum(1), cdum(1), -& + call stdlib_${ci}$gebrd( n, n, cdum(1), n, dum(1), dum(1), cdum(1),cdum(1), cdum(1), -& 1, ierr ) lwork_wgebrd_nn = int( cdum(1),KIND=ilp) - call stdlib_wgeqrf( m, n, cdum(1), m, cdum(1), cdum(1), -1, ierr ) + call stdlib_${ci}$geqrf( m, n, cdum(1), m, cdum(1), cdum(1), -1, ierr ) lwork_wgeqrf_mn = int( cdum(1),KIND=ilp) - call stdlib_wungbr( 'P', n, n, n, cdum(1), n, cdum(1), cdum(1),-1, ierr ) + call stdlib_${ci}$ungbr( 'P', n, n, n, cdum(1), n, cdum(1), cdum(1),-1, ierr ) lwork_wungbr_p_nn = int( cdum(1),KIND=ilp) - call stdlib_wungbr( 'Q', m, m, n, cdum(1), m, cdum(1), cdum(1),-1, ierr ) + call stdlib_${ci}$ungbr( 'Q', m, m, n, cdum(1), m, cdum(1), cdum(1),-1, ierr ) lwork_wungbr_q_mm = int( cdum(1),KIND=ilp) - call stdlib_wungbr( 'Q', m, n, n, cdum(1), m, cdum(1), cdum(1),-1, ierr ) + call stdlib_${ci}$ungbr( 'Q', m, n, n, cdum(1), m, cdum(1), cdum(1),-1, ierr ) lwork_wungbr_q_mn = int( cdum(1),KIND=ilp) - call stdlib_wungqr( m, m, n, cdum(1), m, cdum(1), cdum(1),-1, ierr ) + call stdlib_${ci}$ungqr( m, m, n, cdum(1), m, cdum(1), cdum(1),-1, ierr ) lwork_wungqr_mm = int( cdum(1),KIND=ilp) - call stdlib_wungqr( m, n, n, cdum(1), m, cdum(1), cdum(1),-1, ierr ) + call stdlib_${ci}$ungqr( m, n, n, cdum(1), m, cdum(1), cdum(1),-1, ierr ) lwork_wungqr_mn = int( cdum(1),KIND=ilp) - call stdlib_wunmbr( 'P', 'R', 'C', n, n, n, cdum(1), n, cdum(1),cdum(1), n, cdum(& + call stdlib_${ci}$unmbr( 'P', 'R', 'C', n, n, n, cdum(1), n, cdum(1),cdum(1), n, cdum(& 1), -1, ierr ) lwork_wunmbr_prc_nn = int( cdum(1),KIND=ilp) - call stdlib_wunmbr( 'Q', 'L', 'N', m, m, n, cdum(1), m, cdum(1),cdum(1), m, cdum(& + call stdlib_${ci}$unmbr( 'Q', 'L', 'N', m, m, n, cdum(1), m, cdum(1),cdum(1), m, cdum(& 1), -1, ierr ) lwork_wunmbr_qln_mm = int( cdum(1),KIND=ilp) - call stdlib_wunmbr( 'Q', 'L', 'N', m, n, n, cdum(1), m, cdum(1),cdum(1), m, cdum(& + call stdlib_${ci}$unmbr( 'Q', 'L', 'N', m, n, n, cdum(1), m, cdum(1),cdum(1), m, cdum(& 1), -1, ierr ) lwork_wunmbr_qln_mn = int( cdum(1),KIND=ilp) - call stdlib_wunmbr( 'Q', 'L', 'N', n, n, n, cdum(1), n, cdum(1),cdum(1), n, cdum(& + call stdlib_${ci}$unmbr( 'Q', 'L', 'N', n, n, n, cdum(1), n, cdum(1),cdum(1), n, cdum(& 1), -1, ierr ) lwork_wunmbr_qln_nn = int( cdum(1),KIND=ilp) if( m>=mnthr1 ) then @@ -10640,39 +10642,39 @@ module stdlib_linalg_lapack_w end if else if( minmn>0 ) then ! there is no complex work space needed for bidiagonal svd - ! the realwork space needed for bidiagonal svd (stdlib_qbdsdc,KIND=qp) is + ! the realwork space needed for bidiagonal svd (stdlib_${c2ri(ci)}$bdsdc,KIND=${ck}$) is ! bdspac = 3*m*m + 4*m for singular values and vectors; ! bdspac = 4*m for singular values only; ! not including e, ru, and rvt matrices. ! compute space preferred for each routine - call stdlib_wgebrd( m, n, cdum(1), m, dum(1), dum(1), cdum(1),cdum(1), cdum(1), -& + call stdlib_${ci}$gebrd( m, n, cdum(1), m, dum(1), dum(1), cdum(1),cdum(1), cdum(1), -& 1, ierr ) lwork_wgebrd_mn = int( cdum(1),KIND=ilp) - call stdlib_wgebrd( m, m, cdum(1), m, dum(1), dum(1), cdum(1),cdum(1), cdum(1), -& + call stdlib_${ci}$gebrd( m, m, cdum(1), m, dum(1), dum(1), cdum(1),cdum(1), cdum(1), -& 1, ierr ) lwork_wgebrd_mm = int( cdum(1),KIND=ilp) - call stdlib_wgelqf( m, n, cdum(1), m, cdum(1), cdum(1), -1, ierr ) + call stdlib_${ci}$gelqf( m, n, cdum(1), m, cdum(1), cdum(1), -1, ierr ) lwork_wgelqf_mn = int( cdum(1),KIND=ilp) - call stdlib_wungbr( 'P', m, n, m, cdum(1), m, cdum(1), cdum(1),-1, ierr ) + call stdlib_${ci}$ungbr( 'P', m, n, m, cdum(1), m, cdum(1), cdum(1),-1, ierr ) lwork_wungbr_p_mn = int( cdum(1),KIND=ilp) - call stdlib_wungbr( 'P', n, n, m, cdum(1), n, cdum(1), cdum(1),-1, ierr ) + call stdlib_${ci}$ungbr( 'P', n, n, m, cdum(1), n, cdum(1), cdum(1),-1, ierr ) lwork_wungbr_p_nn = int( cdum(1),KIND=ilp) - call stdlib_wungbr( 'Q', m, m, n, cdum(1), m, cdum(1), cdum(1),-1, ierr ) + call stdlib_${ci}$ungbr( 'Q', m, m, n, cdum(1), m, cdum(1), cdum(1),-1, ierr ) lwork_wungbr_q_mm = int( cdum(1),KIND=ilp) - call stdlib_wunglq( m, n, m, cdum(1), m, cdum(1), cdum(1),-1, ierr ) + call stdlib_${ci}$unglq( m, n, m, cdum(1), m, cdum(1), cdum(1),-1, ierr ) lwork_wunglq_mn = int( cdum(1),KIND=ilp) - call stdlib_wunglq( n, n, m, cdum(1), n, cdum(1), cdum(1),-1, ierr ) + call stdlib_${ci}$unglq( n, n, m, cdum(1), n, cdum(1), cdum(1),-1, ierr ) lwork_wunglq_nn = int( cdum(1),KIND=ilp) - call stdlib_wunmbr( 'P', 'R', 'C', m, m, m, cdum(1), m, cdum(1),cdum(1), m, cdum(& + call stdlib_${ci}$unmbr( 'P', 'R', 'C', m, m, m, cdum(1), m, cdum(1),cdum(1), m, cdum(& 1), -1, ierr ) lwork_wunmbr_prc_mm = int( cdum(1),KIND=ilp) - call stdlib_wunmbr( 'P', 'R', 'C', m, n, m, cdum(1), m, cdum(1),cdum(1), m, cdum(& + call stdlib_${ci}$unmbr( 'P', 'R', 'C', m, n, m, cdum(1), m, cdum(1),cdum(1), m, cdum(& 1), -1, ierr ) lwork_wunmbr_prc_mn = int( cdum(1),KIND=ilp) - call stdlib_wunmbr( 'P', 'R', 'C', n, n, m, cdum(1), n, cdum(1),cdum(1), n, cdum(& + call stdlib_${ci}$unmbr( 'P', 'R', 'C', n, n, m, cdum(1), n, cdum(1),cdum(1), n, cdum(& 1), -1, ierr ) lwork_wunmbr_prc_nn = int( cdum(1),KIND=ilp) - call stdlib_wunmbr( 'Q', 'L', 'N', m, m, m, cdum(1), m, cdum(1),cdum(1), m, cdum(& + call stdlib_${ci}$unmbr( 'Q', 'L', 'N', m, m, m, cdum(1), m, cdum(1),cdum(1), m, cdum(& 1), -1, ierr ) lwork_wunmbr_qln_mm = int( cdum(1),KIND=ilp) if( n>=mnthr1 ) then @@ -10752,7 +10754,7 @@ module stdlib_linalg_lapack_w maxwrk = max( maxwrk, minwrk ) end if if( info==0 ) then - work( 1 ) = stdlib_qroundup_lwork( maxwrk ) + work( 1 ) = stdlib_${c2ri(ci)}$roundup_lwork( maxwrk ) if( lworkzero .and. anrmbignum ) then iscl = 1 - call stdlib_wlascl( 'G', 0, 0, anrm, bignum, m, n, a, lda, ierr ) + call stdlib_${ci}$lascl( 'G', 0, 0, anrm, bignum, m, n, a, lda, ierr ) end if if( m>=n ) then ! a has at least as many rows as columns. if a has sufficiently @@ -10799,10 +10801,10 @@ module stdlib_linalg_lapack_w ! cworkspace: need n [tau] + n [work] ! cworkspace: prefer n [tau] + n*nb [work] ! rworkspace: need 0 - call stdlib_wgeqrf( m, n, a, lda, work( itau ), work( nwork ),lwork-nwork+1, & + call stdlib_${ci}$geqrf( m, n, a, lda, work( itau ), work( nwork ),lwork-nwork+1, & ierr ) ! zero out below r - if (n>1) call stdlib_wlaset( 'L', n-1, n-1, czero, czero, a( 2, 1 ),lda ) + if (n>1) call stdlib_${ci}$laset( 'L', n-1, n-1, czero, czero, a( 2, 1 ),lda ) ie = 1 itauq = 1 itaup = itauq + n @@ -10811,13 +10813,13 @@ module stdlib_linalg_lapack_w ! cworkspace: need 2*n [tauq, taup] + n [work] ! cworkspace: prefer 2*n [tauq, taup] + 2*n*nb [work] ! rworkspace: need n [e] - call stdlib_wgebrd( n, n, a, lda, s, rwork( ie ), work( itauq ),work( itaup ),& + call stdlib_${ci}$gebrd( n, n, a, lda, s, rwork( ie ), work( itauq ),work( itaup ),& work( nwork ), lwork-nwork+1,ierr ) nrwork = ie + n ! perform bidiagonal svd, compute singular values only ! cworkspace: need 0 ! rworkspace: need n [e] + bdspac - call stdlib_qbdsdc( 'U', 'N', n, s, rwork( ie ), dum,1,dum,1,dum, idum, rwork(& + call stdlib_${c2ri(ci)}$bdsdc( 'U', 'N', n, s, rwork( ie ), dum,1,dum,1,dum, idum, rwork(& nrwork ), iwork, info ) else if( wntqo ) then ! path 2 (m >> n, jobz='o') @@ -10839,16 +10841,16 @@ module stdlib_linalg_lapack_w ! cworkspace: need n*n [u] + n*n [r] + n [tau] + n [work] ! cworkspace: prefer n*n [u] + n*n [r] + n [tau] + n*nb [work] ! rworkspace: need 0 - call stdlib_wgeqrf( m, n, a, lda, work( itau ), work( nwork ),lwork-nwork+1, & + call stdlib_${ci}$geqrf( m, n, a, lda, work( itau ), work( nwork ),lwork-nwork+1, & ierr ) ! copy r to work( ir ), zeroing out below it - call stdlib_wlacpy( 'U', n, n, a, lda, work( ir ), ldwrkr ) - call stdlib_wlaset( 'L', n-1, n-1, czero, czero, work( ir+1 ),ldwrkr ) + call stdlib_${ci}$lacpy( 'U', n, n, a, lda, work( ir ), ldwrkr ) + call stdlib_${ci}$laset( 'L', n-1, n-1, czero, czero, work( ir+1 ),ldwrkr ) ! generate q in a ! cworkspace: need n*n [u] + n*n [r] + n [tau] + n [work] ! cworkspace: prefer n*n [u] + n*n [r] + n [tau] + n*nb [work] ! rworkspace: need 0 - call stdlib_wungqr( m, n, n, a, lda, work( itau ),work( nwork ), lwork-nwork+& + call stdlib_${ci}$ungqr( m, n, n, a, lda, work( itau ),work( nwork ), lwork-nwork+& 1, ierr ) ie = 1 itauq = itau @@ -10858,7 +10860,7 @@ module stdlib_linalg_lapack_w ! cworkspace: need n*n [u] + n*n [r] + 2*n [tauq, taup] + n [work] ! cworkspace: prefer n*n [u] + n*n [r] + 2*n [tauq, taup] + 2*n*nb [work] ! rworkspace: need n [e] - call stdlib_wgebrd( n, n, work( ir ), ldwrkr, s, rwork( ie ),work( itauq ), & + call stdlib_${ci}$gebrd( n, n, work( ir ), ldwrkr, s, rwork( ie ),work( itauq ), & work( itaup ), work( nwork ),lwork-nwork+1, ierr ) ! perform bidiagonal svd, computing left singular vectors ! of r in work(iru) and computing right singular vectors @@ -10868,23 +10870,23 @@ module stdlib_linalg_lapack_w iru = ie + n irvt = iru + n*n nrwork = irvt + n*n - call stdlib_qbdsdc( 'U', 'I', n, s, rwork( ie ), rwork( iru ),n, rwork( irvt )& + call stdlib_${c2ri(ci)}$bdsdc( 'U', 'I', n, s, rwork( ie ), rwork( iru ),n, rwork( irvt )& , n, dum, idum,rwork( nrwork ), iwork, info ) - ! copy realmatrix rwork(iru,KIND=qp) to complex matrix work(iu) + ! copy realmatrix rwork(iru,KIND=${ck}$) to complex matrix work(iu) ! overwrite work(iu) by the left singular vectors of r ! cworkspace: need n*n [u] + n*n [r] + 2*n [tauq, taup] + n [work] ! cworkspace: prefer n*n [u] + n*n [r] + 2*n [tauq, taup] + n*nb [work] ! rworkspace: need 0 - call stdlib_wlacp2( 'F', n, n, rwork( iru ), n, work( iu ),ldwrku ) - call stdlib_wunmbr( 'Q', 'L', 'N', n, n, n, work( ir ), ldwrkr,work( itauq ), & + call stdlib_${ci}$lacp2( 'F', n, n, rwork( iru ), n, work( iu ),ldwrku ) + call stdlib_${ci}$unmbr( 'Q', 'L', 'N', n, n, n, work( ir ), ldwrkr,work( itauq ), & work( iu ), ldwrku,work( nwork ), lwork-nwork+1, ierr ) - ! copy realmatrix rwork(irvt,KIND=qp) to complex matrix vt + ! copy realmatrix rwork(irvt,KIND=${ck}$) to complex matrix vt ! overwrite vt by the right singular vectors of r ! cworkspace: need n*n [u] + n*n [r] + 2*n [tauq, taup] + n [work] ! cworkspace: prefer n*n [u] + n*n [r] + 2*n [tauq, taup] + n*nb [work] ! rworkspace: need 0 - call stdlib_wlacp2( 'F', n, n, rwork( irvt ), n, vt, ldvt ) - call stdlib_wunmbr( 'P', 'R', 'C', n, n, n, work( ir ), ldwrkr,work( itaup ), & + call stdlib_${ci}$lacp2( 'F', n, n, rwork( irvt ), n, vt, ldvt ) + call stdlib_${ci}$unmbr( 'P', 'R', 'C', n, n, n, work( ir ), ldwrkr,work( itaup ), & vt, ldvt, work( nwork ),lwork-nwork+1, ierr ) ! multiply q in a by left singular vectors of r in ! work(iu), storing result in work(ir) and copying to a @@ -10893,9 +10895,9 @@ module stdlib_linalg_lapack_w ! rworkspace: need 0 do i = 1, m, ldwrkr chunk = min( m-i+1, ldwrkr ) - call stdlib_wgemm( 'N', 'N', chunk, n, n, cone, a( i, 1 ),lda, work( iu ), & + call stdlib_${ci}$gemm( 'N', 'N', chunk, n, n, cone, a( i, 1 ),lda, work( iu ), & ldwrku, czero,work( ir ), ldwrkr ) - call stdlib_wlacpy( 'F', chunk, n, work( ir ), ldwrkr,a( i, 1 ), lda ) + call stdlib_${ci}$lacpy( 'F', chunk, n, work( ir ), ldwrkr,a( i, 1 ), lda ) end do else if( wntqs ) then @@ -10911,16 +10913,16 @@ module stdlib_linalg_lapack_w ! cworkspace: need n*n [r] + n [tau] + n [work] ! cworkspace: prefer n*n [r] + n [tau] + n*nb [work] ! rworkspace: need 0 - call stdlib_wgeqrf( m, n, a, lda, work( itau ), work( nwork ),lwork-nwork+1, & + call stdlib_${ci}$geqrf( m, n, a, lda, work( itau ), work( nwork ),lwork-nwork+1, & ierr ) ! copy r to work(ir), zeroing out below it - call stdlib_wlacpy( 'U', n, n, a, lda, work( ir ), ldwrkr ) - call stdlib_wlaset( 'L', n-1, n-1, czero, czero, work( ir+1 ),ldwrkr ) + call stdlib_${ci}$lacpy( 'U', n, n, a, lda, work( ir ), ldwrkr ) + call stdlib_${ci}$laset( 'L', n-1, n-1, czero, czero, work( ir+1 ),ldwrkr ) ! generate q in a ! cworkspace: need n*n [r] + n [tau] + n [work] ! cworkspace: prefer n*n [r] + n [tau] + n*nb [work] ! rworkspace: need 0 - call stdlib_wungqr( m, n, n, a, lda, work( itau ),work( nwork ), lwork-nwork+& + call stdlib_${ci}$ungqr( m, n, n, a, lda, work( itau ),work( nwork ), lwork-nwork+& 1, ierr ) ie = 1 itauq = itau @@ -10930,7 +10932,7 @@ module stdlib_linalg_lapack_w ! cworkspace: need n*n [r] + 2*n [tauq, taup] + n [work] ! cworkspace: prefer n*n [r] + 2*n [tauq, taup] + 2*n*nb [work] ! rworkspace: need n [e] - call stdlib_wgebrd( n, n, work( ir ), ldwrkr, s, rwork( ie ),work( itauq ), & + call stdlib_${ci}$gebrd( n, n, work( ir ), ldwrkr, s, rwork( ie ),work( itauq ), & work( itaup ), work( nwork ),lwork-nwork+1, ierr ) ! perform bidiagonal svd, computing left singular vectors ! of bidiagonal matrix in rwork(iru) and computing right @@ -10940,30 +10942,30 @@ module stdlib_linalg_lapack_w iru = ie + n irvt = iru + n*n nrwork = irvt + n*n - call stdlib_qbdsdc( 'U', 'I', n, s, rwork( ie ), rwork( iru ),n, rwork( irvt )& + call stdlib_${c2ri(ci)}$bdsdc( 'U', 'I', n, s, rwork( ie ), rwork( iru ),n, rwork( irvt )& , n, dum, idum,rwork( nrwork ), iwork, info ) - ! copy realmatrix rwork(iru,KIND=qp) to complex matrix u + ! copy realmatrix rwork(iru,KIND=${ck}$) to complex matrix u ! overwrite u by left singular vectors of r ! cworkspace: need n*n [r] + 2*n [tauq, taup] + n [work] ! cworkspace: prefer n*n [r] + 2*n [tauq, taup] + n*nb [work] ! rworkspace: need 0 - call stdlib_wlacp2( 'F', n, n, rwork( iru ), n, u, ldu ) - call stdlib_wunmbr( 'Q', 'L', 'N', n, n, n, work( ir ), ldwrkr,work( itauq ), & + call stdlib_${ci}$lacp2( 'F', n, n, rwork( iru ), n, u, ldu ) + call stdlib_${ci}$unmbr( 'Q', 'L', 'N', n, n, n, work( ir ), ldwrkr,work( itauq ), & u, ldu, work( nwork ),lwork-nwork+1, ierr ) - ! copy realmatrix rwork(irvt,KIND=qp) to complex matrix vt + ! copy realmatrix rwork(irvt,KIND=${ck}$) to complex matrix vt ! overwrite vt by right singular vectors of r ! cworkspace: need n*n [r] + 2*n [tauq, taup] + n [work] ! cworkspace: prefer n*n [r] + 2*n [tauq, taup] + n*nb [work] ! rworkspace: need 0 - call stdlib_wlacp2( 'F', n, n, rwork( irvt ), n, vt, ldvt ) - call stdlib_wunmbr( 'P', 'R', 'C', n, n, n, work( ir ), ldwrkr,work( itaup ), & + call stdlib_${ci}$lacp2( 'F', n, n, rwork( irvt ), n, vt, ldvt ) + call stdlib_${ci}$unmbr( 'P', 'R', 'C', n, n, n, work( ir ), ldwrkr,work( itaup ), & vt, ldvt, work( nwork ),lwork-nwork+1, ierr ) ! multiply q in a by left singular vectors of r in ! work(ir), storing result in u ! cworkspace: need n*n [r] ! rworkspace: need 0 - call stdlib_wlacpy( 'F', n, n, u, ldu, work( ir ), ldwrkr ) - call stdlib_wgemm( 'N', 'N', m, n, n, cone, a, lda, work( ir ),ldwrkr, czero, & + call stdlib_${ci}$lacpy( 'F', n, n, u, ldu, work( ir ), ldwrkr ) + call stdlib_${ci}$gemm( 'N', 'N', m, n, n, cone, a, lda, work( ir ),ldwrkr, czero, & u, ldu ) else if( wntqa ) then ! path 4 (m >> n, jobz='a') @@ -10978,17 +10980,17 @@ module stdlib_linalg_lapack_w ! cworkspace: need n*n [u] + n [tau] + n [work] ! cworkspace: prefer n*n [u] + n [tau] + n*nb [work] ! rworkspace: need 0 - call stdlib_wgeqrf( m, n, a, lda, work( itau ), work( nwork ),lwork-nwork+1, & + call stdlib_${ci}$geqrf( m, n, a, lda, work( itau ), work( nwork ),lwork-nwork+1, & ierr ) - call stdlib_wlacpy( 'L', m, n, a, lda, u, ldu ) + call stdlib_${ci}$lacpy( 'L', m, n, a, lda, u, ldu ) ! generate q in u ! cworkspace: need n*n [u] + n [tau] + m [work] ! cworkspace: prefer n*n [u] + n [tau] + m*nb [work] ! rworkspace: need 0 - call stdlib_wungqr( m, m, n, u, ldu, work( itau ),work( nwork ), lwork-nwork+& + call stdlib_${ci}$ungqr( m, m, n, u, ldu, work( itau ),work( nwork ), lwork-nwork+& 1, ierr ) ! produce r in a, zeroing out below it - if (n>1) call stdlib_wlaset( 'L', n-1, n-1, czero, czero, a( 2, 1 ),lda ) + if (n>1) call stdlib_${ci}$laset( 'L', n-1, n-1, czero, czero, a( 2, 1 ),lda ) ie = 1 itauq = itau itaup = itauq + n @@ -10997,7 +10999,7 @@ module stdlib_linalg_lapack_w ! cworkspace: need n*n [u] + 2*n [tauq, taup] + n [work] ! cworkspace: prefer n*n [u] + 2*n [tauq, taup] + 2*n*nb [work] ! rworkspace: need n [e] - call stdlib_wgebrd( n, n, a, lda, s, rwork( ie ), work( itauq ),work( itaup ),& + call stdlib_${ci}$gebrd( n, n, a, lda, s, rwork( ie ), work( itauq ),work( itaup ),& work( nwork ), lwork-nwork+1,ierr ) iru = ie + n irvt = iru + n*n @@ -11007,38 +11009,38 @@ module stdlib_linalg_lapack_w ! singular vectors of bidiagonal matrix in rwork(irvt) ! cworkspace: need 0 ! rworkspace: need n [e] + n*n [ru] + n*n [rvt] + bdspac - call stdlib_qbdsdc( 'U', 'I', n, s, rwork( ie ), rwork( iru ),n, rwork( irvt )& + call stdlib_${c2ri(ci)}$bdsdc( 'U', 'I', n, s, rwork( ie ), rwork( iru ),n, rwork( irvt )& , n, dum, idum,rwork( nrwork ), iwork, info ) - ! copy realmatrix rwork(iru,KIND=qp) to complex matrix work(iu) + ! copy realmatrix rwork(iru,KIND=${ck}$) to complex matrix work(iu) ! overwrite work(iu) by left singular vectors of r ! cworkspace: need n*n [u] + 2*n [tauq, taup] + n [work] ! cworkspace: prefer n*n [u] + 2*n [tauq, taup] + n*nb [work] ! rworkspace: need 0 - call stdlib_wlacp2( 'F', n, n, rwork( iru ), n, work( iu ),ldwrku ) - call stdlib_wunmbr( 'Q', 'L', 'N', n, n, n, a, lda,work( itauq ), work( iu ), & + call stdlib_${ci}$lacp2( 'F', n, n, rwork( iru ), n, work( iu ),ldwrku ) + call stdlib_${ci}$unmbr( 'Q', 'L', 'N', n, n, n, a, lda,work( itauq ), work( iu ), & ldwrku,work( nwork ), lwork-nwork+1, ierr ) - ! copy realmatrix rwork(irvt,KIND=qp) to complex matrix vt + ! copy realmatrix rwork(irvt,KIND=${ck}$) to complex matrix vt ! overwrite vt by right singular vectors of r ! cworkspace: need n*n [u] + 2*n [tauq, taup] + n [work] ! cworkspace: prefer n*n [u] + 2*n [tauq, taup] + n*nb [work] ! rworkspace: need 0 - call stdlib_wlacp2( 'F', n, n, rwork( irvt ), n, vt, ldvt ) - call stdlib_wunmbr( 'P', 'R', 'C', n, n, n, a, lda,work( itaup ), vt, ldvt, & + call stdlib_${ci}$lacp2( 'F', n, n, rwork( irvt ), n, vt, ldvt ) + call stdlib_${ci}$unmbr( 'P', 'R', 'C', n, n, n, a, lda,work( itaup ), vt, ldvt, & work( nwork ),lwork-nwork+1, ierr ) ! multiply q in u by left singular vectors of r in ! work(iu), storing result in a ! cworkspace: need n*n [u] ! rworkspace: need 0 - call stdlib_wgemm( 'N', 'N', m, n, n, cone, u, ldu, work( iu ),ldwrku, czero, & + call stdlib_${ci}$gemm( 'N', 'N', m, n, n, cone, u, ldu, work( iu ),ldwrku, czero, & a, lda ) ! copy left singular vectors of a from a to u - call stdlib_wlacpy( 'F', m, n, a, lda, u, ldu ) + call stdlib_${ci}$lacpy( 'F', m, n, a, lda, u, ldu ) end if else if( m>=mnthr2 ) then ! mnthr2 <= m < mnthr1 ! path 5 (m >> n, but not as much as mnthr1) ! reduce to bidiagonal form without qr decomposition, use - ! stdlib_wungbr and matrix multiplication to compute singular vectors + ! stdlib_${ci}$ungbr and matrix multiplication to compute singular vectors ie = 1 nrwork = ie + n itauq = 1 @@ -11048,14 +11050,14 @@ module stdlib_linalg_lapack_w ! cworkspace: need 2*n [tauq, taup] + m [work] ! cworkspace: prefer 2*n [tauq, taup] + (m+n)*nb [work] ! rworkspace: need n [e] - call stdlib_wgebrd( m, n, a, lda, s, rwork( ie ), work( itauq ),work( itaup ), & + call stdlib_${ci}$gebrd( m, n, a, lda, s, rwork( ie ), work( itauq ),work( itaup ), & work( nwork ), lwork-nwork+1,ierr ) if( wntqn ) then ! path 5n (m >> n, jobz='n') ! compute singular values only ! cworkspace: need 0 ! rworkspace: need n [e] + bdspac - call stdlib_qbdsdc( 'U', 'N', n, s, rwork( ie ), dum, 1,dum,1,dum, idum, & + call stdlib_${c2ri(ci)}$bdsdc( 'U', 'N', n, s, rwork( ie ), dum, 1,dum,1,dum, idum, & rwork( nrwork ), iwork, info ) else if( wntqo ) then iu = nwork @@ -11067,14 +11069,14 @@ module stdlib_linalg_lapack_w ! cworkspace: need 2*n [tauq, taup] + n [work] ! cworkspace: prefer 2*n [tauq, taup] + n*nb [work] ! rworkspace: need 0 - call stdlib_wlacpy( 'U', n, n, a, lda, vt, ldvt ) - call stdlib_wungbr( 'P', n, n, n, vt, ldvt, work( itaup ),work( nwork ), & + call stdlib_${ci}$lacpy( 'U', n, n, a, lda, vt, ldvt ) + call stdlib_${ci}$ungbr( 'P', n, n, n, vt, ldvt, work( itaup ),work( nwork ), & lwork-nwork+1, ierr ) ! generate q in a ! cworkspace: need 2*n [tauq, taup] + n [work] ! cworkspace: prefer 2*n [tauq, taup] + n*nb [work] ! rworkspace: need 0 - call stdlib_wungbr( 'Q', m, n, n, a, lda, work( itauq ),work( nwork ), lwork-& + call stdlib_${ci}$ungbr( 'Q', m, n, n, a, lda, work( itauq ),work( nwork ), lwork-& nwork+1, ierr ) if( lwork >= m*n + 3*n ) then ! work( iu ) is m by n @@ -11089,16 +11091,16 @@ module stdlib_linalg_lapack_w ! singular vectors of bidiagonal matrix in rwork(irvt) ! cworkspace: need 0 ! rworkspace: need n [e] + n*n [ru] + n*n [rvt] + bdspac - call stdlib_qbdsdc( 'U', 'I', n, s, rwork( ie ), rwork( iru ),n, rwork( irvt )& + call stdlib_${c2ri(ci)}$bdsdc( 'U', 'I', n, s, rwork( ie ), rwork( iru ),n, rwork( irvt )& , n, dum, idum,rwork( nrwork ), iwork, info ) - ! multiply realmatrix rwork(irvt,KIND=qp) by p**h in vt, + ! multiply realmatrix rwork(irvt,KIND=${ck}$) by p**h in vt, ! storing the result in work(iu), copying to vt ! cworkspace: need 2*n [tauq, taup] + n*n [u] ! rworkspace: need n [e] + n*n [ru] + n*n [rvt] + 2*n*n [rwork] - call stdlib_wlarcm( n, n, rwork( irvt ), n, vt, ldvt,work( iu ), ldwrku, & + call stdlib_${ci}$larcm( n, n, rwork( irvt ), n, vt, ldvt,work( iu ), ldwrku, & rwork( nrwork ) ) - call stdlib_wlacpy( 'F', n, n, work( iu ), ldwrku, vt, ldvt ) - ! multiply q in a by realmatrix rwork(iru,KIND=qp), storing the + call stdlib_${ci}$lacpy( 'F', n, n, work( iu ), ldwrku, vt, ldvt ) + ! multiply q in a by realmatrix rwork(iru,KIND=${ck}$), storing the ! result in work(iu), copying to a ! cworkspace: need 2*n [tauq, taup] + n*n [u] ! cworkspace: prefer 2*n [tauq, taup] + m*n [u] @@ -11107,9 +11109,9 @@ module stdlib_linalg_lapack_w nrwork = irvt do i = 1, m, ldwrku chunk = min( m-i+1, ldwrku ) - call stdlib_wlacrm( chunk, n, a( i, 1 ), lda, rwork( iru ),n, work( iu ), & + call stdlib_${ci}$lacrm( chunk, n, a( i, 1 ), lda, rwork( iru ),n, work( iu ), & ldwrku, rwork( nrwork ) ) - call stdlib_wlacpy( 'F', chunk, n, work( iu ), ldwrku,a( i, 1 ), lda ) + call stdlib_${ci}$lacpy( 'F', chunk, n, work( iu ), ldwrku,a( i, 1 ), lda ) end do else if( wntqs ) then @@ -11118,15 +11120,15 @@ module stdlib_linalg_lapack_w ! cworkspace: need 2*n [tauq, taup] + n [work] ! cworkspace: prefer 2*n [tauq, taup] + n*nb [work] ! rworkspace: need 0 - call stdlib_wlacpy( 'U', n, n, a, lda, vt, ldvt ) - call stdlib_wungbr( 'P', n, n, n, vt, ldvt, work( itaup ),work( nwork ), & + call stdlib_${ci}$lacpy( 'U', n, n, a, lda, vt, ldvt ) + call stdlib_${ci}$ungbr( 'P', n, n, n, vt, ldvt, work( itaup ),work( nwork ), & lwork-nwork+1, ierr ) ! copy a to u, generate q ! cworkspace: need 2*n [tauq, taup] + n [work] ! cworkspace: prefer 2*n [tauq, taup] + n*nb [work] ! rworkspace: need 0 - call stdlib_wlacpy( 'L', m, n, a, lda, u, ldu ) - call stdlib_wungbr( 'Q', m, n, n, u, ldu, work( itauq ),work( nwork ), lwork-& + call stdlib_${ci}$lacpy( 'L', m, n, a, lda, u, ldu ) + call stdlib_${ci}$ungbr( 'Q', m, n, n, u, ldu, work( itauq ),work( nwork ), lwork-& nwork+1, ierr ) ! perform bidiagonal svd, computing left singular vectors ! of bidiagonal matrix in rwork(iru) and computing right @@ -11136,38 +11138,38 @@ module stdlib_linalg_lapack_w iru = nrwork irvt = iru + n*n nrwork = irvt + n*n - call stdlib_qbdsdc( 'U', 'I', n, s, rwork( ie ), rwork( iru ),n, rwork( irvt )& + call stdlib_${c2ri(ci)}$bdsdc( 'U', 'I', n, s, rwork( ie ), rwork( iru ),n, rwork( irvt )& , n, dum, idum,rwork( nrwork ), iwork, info ) - ! multiply realmatrix rwork(irvt,KIND=qp) by p**h in vt, + ! multiply realmatrix rwork(irvt,KIND=${ck}$) by p**h in vt, ! storing the result in a, copying to vt ! cworkspace: need 0 ! rworkspace: need n [e] + n*n [ru] + n*n [rvt] + 2*n*n [rwork] - call stdlib_wlarcm( n, n, rwork( irvt ), n, vt, ldvt, a, lda,rwork( nrwork ) ) + call stdlib_${ci}$larcm( n, n, rwork( irvt ), n, vt, ldvt, a, lda,rwork( nrwork ) ) - call stdlib_wlacpy( 'F', n, n, a, lda, vt, ldvt ) - ! multiply q in u by realmatrix rwork(iru,KIND=qp), storing the + call stdlib_${ci}$lacpy( 'F', n, n, a, lda, vt, ldvt ) + ! multiply q in u by realmatrix rwork(iru,KIND=${ck}$), storing the ! result in a, copying to u ! cworkspace: need 0 ! rworkspace: need n [e] + n*n [ru] + 2*m*n [rwork] < n + 5*n*n since m < 2*n here nrwork = irvt - call stdlib_wlacrm( m, n, u, ldu, rwork( iru ), n, a, lda,rwork( nrwork ) ) + call stdlib_${ci}$lacrm( m, n, u, ldu, rwork( iru ), n, a, lda,rwork( nrwork ) ) - call stdlib_wlacpy( 'F', m, n, a, lda, u, ldu ) + call stdlib_${ci}$lacpy( 'F', m, n, a, lda, u, ldu ) else ! path 5a (m >> n, jobz='a') ! copy a to vt, generate p**h ! cworkspace: need 2*n [tauq, taup] + n [work] ! cworkspace: prefer 2*n [tauq, taup] + n*nb [work] ! rworkspace: need 0 - call stdlib_wlacpy( 'U', n, n, a, lda, vt, ldvt ) - call stdlib_wungbr( 'P', n, n, n, vt, ldvt, work( itaup ),work( nwork ), & + call stdlib_${ci}$lacpy( 'U', n, n, a, lda, vt, ldvt ) + call stdlib_${ci}$ungbr( 'P', n, n, n, vt, ldvt, work( itaup ),work( nwork ), & lwork-nwork+1, ierr ) ! copy a to u, generate q ! cworkspace: need 2*n [tauq, taup] + m [work] ! cworkspace: prefer 2*n [tauq, taup] + m*nb [work] ! rworkspace: need 0 - call stdlib_wlacpy( 'L', m, n, a, lda, u, ldu ) - call stdlib_wungbr( 'Q', m, m, n, u, ldu, work( itauq ),work( nwork ), lwork-& + call stdlib_${ci}$lacpy( 'L', m, n, a, lda, u, ldu ) + call stdlib_${ci}$ungbr( 'Q', m, m, n, u, ldu, work( itauq ),work( nwork ), lwork-& nwork+1, ierr ) ! perform bidiagonal svd, computing left singular vectors ! of bidiagonal matrix in rwork(iru) and computing right @@ -11177,29 +11179,29 @@ module stdlib_linalg_lapack_w iru = nrwork irvt = iru + n*n nrwork = irvt + n*n - call stdlib_qbdsdc( 'U', 'I', n, s, rwork( ie ), rwork( iru ),n, rwork( irvt )& + call stdlib_${c2ri(ci)}$bdsdc( 'U', 'I', n, s, rwork( ie ), rwork( iru ),n, rwork( irvt )& , n, dum, idum,rwork( nrwork ), iwork, info ) - ! multiply realmatrix rwork(irvt,KIND=qp) by p**h in vt, + ! multiply realmatrix rwork(irvt,KIND=${ck}$) by p**h in vt, ! storing the result in a, copying to vt ! cworkspace: need 0 ! rworkspace: need n [e] + n*n [ru] + n*n [rvt] + 2*n*n [rwork] - call stdlib_wlarcm( n, n, rwork( irvt ), n, vt, ldvt, a, lda,rwork( nrwork ) ) + call stdlib_${ci}$larcm( n, n, rwork( irvt ), n, vt, ldvt, a, lda,rwork( nrwork ) ) - call stdlib_wlacpy( 'F', n, n, a, lda, vt, ldvt ) - ! multiply q in u by realmatrix rwork(iru,KIND=qp), storing the + call stdlib_${ci}$lacpy( 'F', n, n, a, lda, vt, ldvt ) + ! multiply q in u by realmatrix rwork(iru,KIND=${ck}$), storing the ! result in a, copying to u ! cworkspace: need 0 ! rworkspace: need n [e] + n*n [ru] + 2*m*n [rwork] < n + 5*n*n since m < 2*n here nrwork = irvt - call stdlib_wlacrm( m, n, u, ldu, rwork( iru ), n, a, lda,rwork( nrwork ) ) + call stdlib_${ci}$lacrm( m, n, u, ldu, rwork( iru ), n, a, lda,rwork( nrwork ) ) - call stdlib_wlacpy( 'F', m, n, a, lda, u, ldu ) + call stdlib_${ci}$lacpy( 'F', m, n, a, lda, u, ldu ) end if else ! m < mnthr2 ! path 6 (m >= n, but not much larger) ! reduce to bidiagonal form without qr decomposition - ! use stdlib_wunmbr to compute singular vectors + ! use stdlib_${ci}$unmbr to compute singular vectors ie = 1 nrwork = ie + n itauq = 1 @@ -11209,14 +11211,14 @@ module stdlib_linalg_lapack_w ! cworkspace: need 2*n [tauq, taup] + m [work] ! cworkspace: prefer 2*n [tauq, taup] + (m+n)*nb [work] ! rworkspace: need n [e] - call stdlib_wgebrd( m, n, a, lda, s, rwork( ie ), work( itauq ),work( itaup ), & + call stdlib_${ci}$gebrd( m, n, a, lda, s, rwork( ie ), work( itauq ),work( itaup ), & work( nwork ), lwork-nwork+1,ierr ) if( wntqn ) then ! path 6n (m >= n, jobz='n') ! compute singular values only ! cworkspace: need 0 ! rworkspace: need n [e] + bdspac - call stdlib_qbdsdc( 'U', 'N', n, s, rwork( ie ), dum,1,dum,1,dum, idum, rwork(& + call stdlib_${c2ri(ci)}$bdsdc( 'U', 'N', n, s, rwork( ie ), dum,1,dum,1,dum, idum, rwork(& nrwork ), iwork, info ) else if( wntqo ) then iu = nwork @@ -11237,38 +11239,38 @@ module stdlib_linalg_lapack_w ! singular vectors of bidiagonal matrix in rwork(irvt) ! cworkspace: need 0 ! rworkspace: need n [e] + n*n [ru] + n*n [rvt] + bdspac - call stdlib_qbdsdc( 'U', 'I', n, s, rwork( ie ), rwork( iru ),n, rwork( irvt )& + call stdlib_${c2ri(ci)}$bdsdc( 'U', 'I', n, s, rwork( ie ), rwork( iru ),n, rwork( irvt )& , n, dum, idum,rwork( nrwork ), iwork, info ) - ! copy realmatrix rwork(irvt,KIND=qp) to complex matrix vt + ! copy realmatrix rwork(irvt,KIND=${ck}$) to complex matrix vt ! overwrite vt by right singular vectors of a ! cworkspace: need 2*n [tauq, taup] + n*n [u] + n [work] ! cworkspace: prefer 2*n [tauq, taup] + n*n [u] + n*nb [work] ! rworkspace: need n [e] + n*n [ru] + n*n [rvt] - call stdlib_wlacp2( 'F', n, n, rwork( irvt ), n, vt, ldvt ) - call stdlib_wunmbr( 'P', 'R', 'C', n, n, n, a, lda,work( itaup ), vt, ldvt, & + call stdlib_${ci}$lacp2( 'F', n, n, rwork( irvt ), n, vt, ldvt ) + call stdlib_${ci}$unmbr( 'P', 'R', 'C', n, n, n, a, lda,work( itaup ), vt, ldvt, & work( nwork ),lwork-nwork+1, ierr ) if( lwork >= m*n + 3*n ) then ! path 6o-fast - ! copy realmatrix rwork(iru,KIND=qp) to complex matrix work(iu) + ! copy realmatrix rwork(iru,KIND=${ck}$) to complex matrix work(iu) ! overwrite work(iu) by left singular vectors of a, copying ! to a ! cworkspace: need 2*n [tauq, taup] + m*n [u] + n [work] ! cworkspace: prefer 2*n [tauq, taup] + m*n [u] + n*nb [work] ! rworkspace: need n [e] + n*n [ru] - call stdlib_wlaset( 'F', m, n, czero, czero, work( iu ),ldwrku ) - call stdlib_wlacp2( 'F', n, n, rwork( iru ), n, work( iu ),ldwrku ) - call stdlib_wunmbr( 'Q', 'L', 'N', m, n, n, a, lda,work( itauq ), work( iu & + call stdlib_${ci}$laset( 'F', m, n, czero, czero, work( iu ),ldwrku ) + call stdlib_${ci}$lacp2( 'F', n, n, rwork( iru ), n, work( iu ),ldwrku ) + call stdlib_${ci}$unmbr( 'Q', 'L', 'N', m, n, n, a, lda,work( itauq ), work( iu & ), ldwrku,work( nwork ), lwork-nwork+1, ierr ) - call stdlib_wlacpy( 'F', m, n, work( iu ), ldwrku, a, lda ) + call stdlib_${ci}$lacpy( 'F', m, n, work( iu ), ldwrku, a, lda ) else ! path 6o-slow ! generate q in a ! cworkspace: need 2*n [tauq, taup] + n*n [u] + n [work] ! cworkspace: prefer 2*n [tauq, taup] + n*n [u] + n*nb [work] ! rworkspace: need 0 - call stdlib_wungbr( 'Q', m, n, n, a, lda, work( itauq ),work( nwork ), & + call stdlib_${ci}$ungbr( 'Q', m, n, n, a, lda, work( itauq ),work( nwork ), & lwork-nwork+1, ierr ) - ! multiply q in a by realmatrix rwork(iru,KIND=qp), storing the + ! multiply q in a by realmatrix rwork(iru,KIND=${ck}$), storing the ! result in work(iu), copying to a ! cworkspace: need 2*n [tauq, taup] + n*n [u] ! cworkspace: prefer 2*n [tauq, taup] + m*n [u] @@ -11277,9 +11279,9 @@ module stdlib_linalg_lapack_w nrwork = irvt do i = 1, m, ldwrku chunk = min( m-i+1, ldwrku ) - call stdlib_wlacrm( chunk, n, a( i, 1 ), lda,rwork( iru ), n, work( iu )& + call stdlib_${ci}$lacrm( chunk, n, a( i, 1 ), lda,rwork( iru ), n, work( iu )& , ldwrku,rwork( nrwork ) ) - call stdlib_wlacpy( 'F', chunk, n, work( iu ), ldwrku,a( i, 1 ), lda ) + call stdlib_${ci}$lacpy( 'F', chunk, n, work( iu ), ldwrku,a( i, 1 ), lda ) end do end if @@ -11293,24 +11295,24 @@ module stdlib_linalg_lapack_w iru = nrwork irvt = iru + n*n nrwork = irvt + n*n - call stdlib_qbdsdc( 'U', 'I', n, s, rwork( ie ), rwork( iru ),n, rwork( irvt )& + call stdlib_${c2ri(ci)}$bdsdc( 'U', 'I', n, s, rwork( ie ), rwork( iru ),n, rwork( irvt )& , n, dum, idum,rwork( nrwork ), iwork, info ) - ! copy realmatrix rwork(iru,KIND=qp) to complex matrix u + ! copy realmatrix rwork(iru,KIND=${ck}$) to complex matrix u ! overwrite u by left singular vectors of a ! cworkspace: need 2*n [tauq, taup] + n [work] ! cworkspace: prefer 2*n [tauq, taup] + n*nb [work] ! rworkspace: need n [e] + n*n [ru] + n*n [rvt] - call stdlib_wlaset( 'F', m, n, czero, czero, u, ldu ) - call stdlib_wlacp2( 'F', n, n, rwork( iru ), n, u, ldu ) - call stdlib_wunmbr( 'Q', 'L', 'N', m, n, n, a, lda,work( itauq ), u, ldu, & + call stdlib_${ci}$laset( 'F', m, n, czero, czero, u, ldu ) + call stdlib_${ci}$lacp2( 'F', n, n, rwork( iru ), n, u, ldu ) + call stdlib_${ci}$unmbr( 'Q', 'L', 'N', m, n, n, a, lda,work( itauq ), u, ldu, & work( nwork ),lwork-nwork+1, ierr ) - ! copy realmatrix rwork(irvt,KIND=qp) to complex matrix vt + ! copy realmatrix rwork(irvt,KIND=${ck}$) to complex matrix vt ! overwrite vt by right singular vectors of a ! cworkspace: need 2*n [tauq, taup] + n [work] ! cworkspace: prefer 2*n [tauq, taup] + n*nb [work] ! rworkspace: need n [e] + n*n [ru] + n*n [rvt] - call stdlib_wlacp2( 'F', n, n, rwork( irvt ), n, vt, ldvt ) - call stdlib_wunmbr( 'P', 'R', 'C', n, n, n, a, lda,work( itaup ), vt, ldvt, & + call stdlib_${ci}$lacp2( 'F', n, n, rwork( irvt ), n, vt, ldvt ) + call stdlib_${ci}$unmbr( 'P', 'R', 'C', n, n, n, a, lda,work( itaup ), vt, ldvt, & work( nwork ),lwork-nwork+1, ierr ) else ! path 6a (m >= n, jobz='a') @@ -11322,28 +11324,28 @@ module stdlib_linalg_lapack_w iru = nrwork irvt = iru + n*n nrwork = irvt + n*n - call stdlib_qbdsdc( 'U', 'I', n, s, rwork( ie ), rwork( iru ),n, rwork( irvt )& + call stdlib_${c2ri(ci)}$bdsdc( 'U', 'I', n, s, rwork( ie ), rwork( iru ),n, rwork( irvt )& , n, dum, idum,rwork( nrwork ), iwork, info ) ! set the right corner of u to identity matrix - call stdlib_wlaset( 'F', m, m, czero, czero, u, ldu ) + call stdlib_${ci}$laset( 'F', m, m, czero, czero, u, ldu ) if( m>n ) then - call stdlib_wlaset( 'F', m-n, m-n, czero, cone,u( n+1, n+1 ), ldu ) + call stdlib_${ci}$laset( 'F', m-n, m-n, czero, cone,u( n+1, n+1 ), ldu ) end if - ! copy realmatrix rwork(iru,KIND=qp) to complex matrix u + ! copy realmatrix rwork(iru,KIND=${ck}$) to complex matrix u ! overwrite u by left singular vectors of a ! cworkspace: need 2*n [tauq, taup] + m [work] ! cworkspace: prefer 2*n [tauq, taup] + m*nb [work] ! rworkspace: need n [e] + n*n [ru] + n*n [rvt] - call stdlib_wlacp2( 'F', n, n, rwork( iru ), n, u, ldu ) - call stdlib_wunmbr( 'Q', 'L', 'N', m, m, n, a, lda,work( itauq ), u, ldu, & + call stdlib_${ci}$lacp2( 'F', n, n, rwork( iru ), n, u, ldu ) + call stdlib_${ci}$unmbr( 'Q', 'L', 'N', m, m, n, a, lda,work( itauq ), u, ldu, & work( nwork ),lwork-nwork+1, ierr ) - ! copy realmatrix rwork(irvt,KIND=qp) to complex matrix vt + ! copy realmatrix rwork(irvt,KIND=${ck}$) to complex matrix vt ! overwrite vt by right singular vectors of a ! cworkspace: need 2*n [tauq, taup] + n [work] ! cworkspace: prefer 2*n [tauq, taup] + n*nb [work] ! rworkspace: need n [e] + n*n [ru] + n*n [rvt] - call stdlib_wlacp2( 'F', n, n, rwork( irvt ), n, vt, ldvt ) - call stdlib_wunmbr( 'P', 'R', 'C', n, n, n, a, lda,work( itaup ), vt, ldvt, & + call stdlib_${ci}$lacp2( 'F', n, n, rwork( irvt ), n, vt, ldvt ) + call stdlib_${ci}$unmbr( 'P', 'R', 'C', n, n, n, a, lda,work( itaup ), vt, ldvt, & work( nwork ),lwork-nwork+1, ierr ) end if end if @@ -11361,10 +11363,10 @@ module stdlib_linalg_lapack_w ! cworkspace: need m [tau] + m [work] ! cworkspace: prefer m [tau] + m*nb [work] ! rworkspace: need 0 - call stdlib_wgelqf( m, n, a, lda, work( itau ), work( nwork ),lwork-nwork+1, & + call stdlib_${ci}$gelqf( m, n, a, lda, work( itau ), work( nwork ),lwork-nwork+1, & ierr ) ! zero out above l - if (m>1) call stdlib_wlaset( 'U', m-1, m-1, czero, czero, a( 1, 2 ),lda ) + if (m>1) call stdlib_${ci}$laset( 'U', m-1, m-1, czero, czero, a( 1, 2 ),lda ) ie = 1 itauq = 1 itaup = itauq + m @@ -11373,13 +11375,13 @@ module stdlib_linalg_lapack_w ! cworkspace: need 2*m [tauq, taup] + m [work] ! cworkspace: prefer 2*m [tauq, taup] + 2*m*nb [work] ! rworkspace: need m [e] - call stdlib_wgebrd( m, m, a, lda, s, rwork( ie ), work( itauq ),work( itaup ),& + call stdlib_${ci}$gebrd( m, m, a, lda, s, rwork( ie ), work( itauq ),work( itaup ),& work( nwork ), lwork-nwork+1,ierr ) nrwork = ie + m ! perform bidiagonal svd, compute singular values only ! cworkspace: need 0 ! rworkspace: need m [e] + bdspac - call stdlib_qbdsdc( 'U', 'N', m, s, rwork( ie ), dum,1,dum,1,dum, idum, rwork(& + call stdlib_${c2ri(ci)}$bdsdc( 'U', 'N', m, s, rwork( ie ), dum,1,dum,1,dum, idum, rwork(& nrwork ), iwork, info ) else if( wntqo ) then ! path 2t (n >> m, jobz='o') @@ -11404,17 +11406,17 @@ module stdlib_linalg_lapack_w ! cworkspace: need m*m [vt] + m*m [l] + m [tau] + m [work] ! cworkspace: prefer m*m [vt] + m*m [l] + m [tau] + m*nb [work] ! rworkspace: need 0 - call stdlib_wgelqf( m, n, a, lda, work( itau ), work( nwork ),lwork-nwork+1, & + call stdlib_${ci}$gelqf( m, n, a, lda, work( itau ), work( nwork ),lwork-nwork+1, & ierr ) ! copy l to work(il), zeroing about above it - call stdlib_wlacpy( 'L', m, m, a, lda, work( il ), ldwrkl ) - call stdlib_wlaset( 'U', m-1, m-1, czero, czero,work( il+ldwrkl ), ldwrkl ) + call stdlib_${ci}$lacpy( 'L', m, m, a, lda, work( il ), ldwrkl ) + call stdlib_${ci}$laset( 'U', m-1, m-1, czero, czero,work( il+ldwrkl ), ldwrkl ) ! generate q in a ! cworkspace: need m*m [vt] + m*m [l] + m [tau] + m [work] ! cworkspace: prefer m*m [vt] + m*m [l] + m [tau] + m*nb [work] ! rworkspace: need 0 - call stdlib_wunglq( m, n, m, a, lda, work( itau ),work( nwork ), lwork-nwork+& + call stdlib_${ci}$unglq( m, n, m, a, lda, work( itau ),work( nwork ), lwork-nwork+& 1, ierr ) ie = 1 itauq = itau @@ -11424,7 +11426,7 @@ module stdlib_linalg_lapack_w ! cworkspace: need m*m [vt] + m*m [l] + 2*m [tauq, taup] + m [work] ! cworkspace: prefer m*m [vt] + m*m [l] + 2*m [tauq, taup] + 2*m*nb [work] ! rworkspace: need m [e] - call stdlib_wgebrd( m, m, work( il ), ldwrkl, s, rwork( ie ),work( itauq ), & + call stdlib_${ci}$gebrd( m, m, work( il ), ldwrkl, s, rwork( ie ),work( itauq ), & work( itaup ), work( nwork ),lwork-nwork+1, ierr ) ! perform bidiagonal svd, computing left singular vectors ! of bidiagonal matrix in rwork(iru) and computing right @@ -11434,23 +11436,23 @@ module stdlib_linalg_lapack_w iru = ie + m irvt = iru + m*m nrwork = irvt + m*m - call stdlib_qbdsdc( 'U', 'I', m, s, rwork( ie ), rwork( iru ),m, rwork( irvt )& + call stdlib_${c2ri(ci)}$bdsdc( 'U', 'I', m, s, rwork( ie ), rwork( iru ),m, rwork( irvt )& , m, dum, idum,rwork( nrwork ), iwork, info ) - ! copy realmatrix rwork(iru,KIND=qp) to complex matrix work(iu) + ! copy realmatrix rwork(iru,KIND=${ck}$) to complex matrix work(iu) ! overwrite work(iu) by the left singular vectors of l ! cworkspace: need m*m [vt] + m*m [l] + 2*m [tauq, taup] + m [work] ! cworkspace: prefer m*m [vt] + m*m [l] + 2*m [tauq, taup] + m*nb [work] ! rworkspace: need 0 - call stdlib_wlacp2( 'F', m, m, rwork( iru ), m, u, ldu ) - call stdlib_wunmbr( 'Q', 'L', 'N', m, m, m, work( il ), ldwrkl,work( itauq ), & + call stdlib_${ci}$lacp2( 'F', m, m, rwork( iru ), m, u, ldu ) + call stdlib_${ci}$unmbr( 'Q', 'L', 'N', m, m, m, work( il ), ldwrkl,work( itauq ), & u, ldu, work( nwork ),lwork-nwork+1, ierr ) - ! copy realmatrix rwork(irvt,KIND=qp) to complex matrix work(ivt) + ! copy realmatrix rwork(irvt,KIND=${ck}$) to complex matrix work(ivt) ! overwrite work(ivt) by the right singular vectors of l ! cworkspace: need m*m [vt] + m*m [l] + 2*m [tauq, taup] + m [work] ! cworkspace: prefer m*m [vt] + m*m [l] + 2*m [tauq, taup] + m*nb [work] ! rworkspace: need 0 - call stdlib_wlacp2( 'F', m, m, rwork( irvt ), m, work( ivt ),ldwkvt ) - call stdlib_wunmbr( 'P', 'R', 'C', m, m, m, work( il ), ldwrkl,work( itaup ), & + call stdlib_${ci}$lacp2( 'F', m, m, rwork( irvt ), m, work( ivt ),ldwkvt ) + call stdlib_${ci}$unmbr( 'P', 'R', 'C', m, m, m, work( il ), ldwrkl,work( itaup ), & work( ivt ), ldwkvt,work( nwork ), lwork-nwork+1, ierr ) ! multiply right singular vectors of l in work(il) by q ! in a, storing result in work(il) and copying to a @@ -11459,9 +11461,9 @@ module stdlib_linalg_lapack_w ! rworkspace: need 0 do i = 1, n, chunk blk = min( n-i+1, chunk ) - call stdlib_wgemm( 'N', 'N', m, blk, m, cone, work( ivt ), m,a( 1, i ), & + call stdlib_${ci}$gemm( 'N', 'N', m, blk, m, cone, work( ivt ), m,a( 1, i ), & lda, czero, work( il ),ldwrkl ) - call stdlib_wlacpy( 'F', m, blk, work( il ), ldwrkl,a( 1, i ), lda ) + call stdlib_${ci}$lacpy( 'F', m, blk, work( il ), ldwrkl,a( 1, i ), lda ) end do else if( wntqs ) then @@ -11477,17 +11479,17 @@ module stdlib_linalg_lapack_w ! cworkspace: need m*m [l] + m [tau] + m [work] ! cworkspace: prefer m*m [l] + m [tau] + m*nb [work] ! rworkspace: need 0 - call stdlib_wgelqf( m, n, a, lda, work( itau ), work( nwork ),lwork-nwork+1, & + call stdlib_${ci}$gelqf( m, n, a, lda, work( itau ), work( nwork ),lwork-nwork+1, & ierr ) ! copy l to work(il), zeroing out above it - call stdlib_wlacpy( 'L', m, m, a, lda, work( il ), ldwrkl ) - call stdlib_wlaset( 'U', m-1, m-1, czero, czero,work( il+ldwrkl ), ldwrkl ) + call stdlib_${ci}$lacpy( 'L', m, m, a, lda, work( il ), ldwrkl ) + call stdlib_${ci}$laset( 'U', m-1, m-1, czero, czero,work( il+ldwrkl ), ldwrkl ) ! generate q in a ! cworkspace: need m*m [l] + m [tau] + m [work] ! cworkspace: prefer m*m [l] + m [tau] + m*nb [work] ! rworkspace: need 0 - call stdlib_wunglq( m, n, m, a, lda, work( itau ),work( nwork ), lwork-nwork+& + call stdlib_${ci}$unglq( m, n, m, a, lda, work( itau ),work( nwork ), lwork-nwork+& 1, ierr ) ie = 1 itauq = itau @@ -11497,7 +11499,7 @@ module stdlib_linalg_lapack_w ! cworkspace: need m*m [l] + 2*m [tauq, taup] + m [work] ! cworkspace: prefer m*m [l] + 2*m [tauq, taup] + 2*m*nb [work] ! rworkspace: need m [e] - call stdlib_wgebrd( m, m, work( il ), ldwrkl, s, rwork( ie ),work( itauq ), & + call stdlib_${ci}$gebrd( m, m, work( il ), ldwrkl, s, rwork( ie ),work( itauq ), & work( itaup ), work( nwork ),lwork-nwork+1, ierr ) ! perform bidiagonal svd, computing left singular vectors ! of bidiagonal matrix in rwork(iru) and computing right @@ -11507,30 +11509,30 @@ module stdlib_linalg_lapack_w iru = ie + m irvt = iru + m*m nrwork = irvt + m*m - call stdlib_qbdsdc( 'U', 'I', m, s, rwork( ie ), rwork( iru ),m, rwork( irvt )& + call stdlib_${c2ri(ci)}$bdsdc( 'U', 'I', m, s, rwork( ie ), rwork( iru ),m, rwork( irvt )& , m, dum, idum,rwork( nrwork ), iwork, info ) - ! copy realmatrix rwork(iru,KIND=qp) to complex matrix u + ! copy realmatrix rwork(iru,KIND=${ck}$) to complex matrix u ! overwrite u by left singular vectors of l ! cworkspace: need m*m [l] + 2*m [tauq, taup] + m [work] ! cworkspace: prefer m*m [l] + 2*m [tauq, taup] + m*nb [work] ! rworkspace: need 0 - call stdlib_wlacp2( 'F', m, m, rwork( iru ), m, u, ldu ) - call stdlib_wunmbr( 'Q', 'L', 'N', m, m, m, work( il ), ldwrkl,work( itauq ), & + call stdlib_${ci}$lacp2( 'F', m, m, rwork( iru ), m, u, ldu ) + call stdlib_${ci}$unmbr( 'Q', 'L', 'N', m, m, m, work( il ), ldwrkl,work( itauq ), & u, ldu, work( nwork ),lwork-nwork+1, ierr ) - ! copy realmatrix rwork(irvt,KIND=qp) to complex matrix vt + ! copy realmatrix rwork(irvt,KIND=${ck}$) to complex matrix vt ! overwrite vt by left singular vectors of l ! cworkspace: need m*m [l] + 2*m [tauq, taup] + m [work] ! cworkspace: prefer m*m [l] + 2*m [tauq, taup] + m*nb [work] ! rworkspace: need 0 - call stdlib_wlacp2( 'F', m, m, rwork( irvt ), m, vt, ldvt ) - call stdlib_wunmbr( 'P', 'R', 'C', m, m, m, work( il ), ldwrkl,work( itaup ), & + call stdlib_${ci}$lacp2( 'F', m, m, rwork( irvt ), m, vt, ldvt ) + call stdlib_${ci}$unmbr( 'P', 'R', 'C', m, m, m, work( il ), ldwrkl,work( itaup ), & vt, ldvt, work( nwork ),lwork-nwork+1, ierr ) ! copy vt to work(il), multiply right singular vectors of l ! in work(il) by q in a, storing result in vt ! cworkspace: need m*m [l] ! rworkspace: need 0 - call stdlib_wlacpy( 'F', m, m, vt, ldvt, work( il ), ldwrkl ) - call stdlib_wgemm( 'N', 'N', m, n, m, cone, work( il ), ldwrkl,a, lda, czero, & + call stdlib_${ci}$lacpy( 'F', m, m, vt, ldvt, work( il ), ldwrkl ) + call stdlib_${ci}$gemm( 'N', 'N', m, n, m, cone, work( il ), ldwrkl,a, lda, czero, & vt, ldvt ) else if( wntqa ) then ! path 4t (n >> m, jobz='a') @@ -11545,17 +11547,17 @@ module stdlib_linalg_lapack_w ! cworkspace: need m*m [vt] + m [tau] + m [work] ! cworkspace: prefer m*m [vt] + m [tau] + m*nb [work] ! rworkspace: need 0 - call stdlib_wgelqf( m, n, a, lda, work( itau ), work( nwork ),lwork-nwork+1, & + call stdlib_${ci}$gelqf( m, n, a, lda, work( itau ), work( nwork ),lwork-nwork+1, & ierr ) - call stdlib_wlacpy( 'U', m, n, a, lda, vt, ldvt ) + call stdlib_${ci}$lacpy( 'U', m, n, a, lda, vt, ldvt ) ! generate q in vt ! cworkspace: need m*m [vt] + m [tau] + n [work] ! cworkspace: prefer m*m [vt] + m [tau] + n*nb [work] ! rworkspace: need 0 - call stdlib_wunglq( n, n, m, vt, ldvt, work( itau ),work( nwork ), lwork-& + call stdlib_${ci}$unglq( n, n, m, vt, ldvt, work( itau ),work( nwork ), lwork-& nwork+1, ierr ) ! produce l in a, zeroing out above it - if (m>1) call stdlib_wlaset( 'U', m-1, m-1, czero, czero, a( 1, 2 ),lda ) + if (m>1) call stdlib_${ci}$laset( 'U', m-1, m-1, czero, czero, a( 1, 2 ),lda ) ie = 1 itauq = itau itaup = itauq + m @@ -11564,7 +11566,7 @@ module stdlib_linalg_lapack_w ! cworkspace: need m*m [vt] + 2*m [tauq, taup] + m [work] ! cworkspace: prefer m*m [vt] + 2*m [tauq, taup] + 2*m*nb [work] ! rworkspace: need m [e] - call stdlib_wgebrd( m, m, a, lda, s, rwork( ie ), work( itauq ),work( itaup ),& + call stdlib_${ci}$gebrd( m, m, a, lda, s, rwork( ie ), work( itauq ),work( itaup ),& work( nwork ), lwork-nwork+1,ierr ) ! perform bidiagonal svd, computing left singular vectors ! of bidiagonal matrix in rwork(iru) and computing right @@ -11574,38 +11576,38 @@ module stdlib_linalg_lapack_w iru = ie + m irvt = iru + m*m nrwork = irvt + m*m - call stdlib_qbdsdc( 'U', 'I', m, s, rwork( ie ), rwork( iru ),m, rwork( irvt )& + call stdlib_${c2ri(ci)}$bdsdc( 'U', 'I', m, s, rwork( ie ), rwork( iru ),m, rwork( irvt )& , m, dum, idum,rwork( nrwork ), iwork, info ) - ! copy realmatrix rwork(iru,KIND=qp) to complex matrix u + ! copy realmatrix rwork(iru,KIND=${ck}$) to complex matrix u ! overwrite u by left singular vectors of l ! cworkspace: need m*m [vt] + 2*m [tauq, taup] + m [work] ! cworkspace: prefer m*m [vt] + 2*m [tauq, taup] + m*nb [work] ! rworkspace: need 0 - call stdlib_wlacp2( 'F', m, m, rwork( iru ), m, u, ldu ) - call stdlib_wunmbr( 'Q', 'L', 'N', m, m, m, a, lda,work( itauq ), u, ldu, & + call stdlib_${ci}$lacp2( 'F', m, m, rwork( iru ), m, u, ldu ) + call stdlib_${ci}$unmbr( 'Q', 'L', 'N', m, m, m, a, lda,work( itauq ), u, ldu, & work( nwork ),lwork-nwork+1, ierr ) - ! copy realmatrix rwork(irvt,KIND=qp) to complex matrix work(ivt) + ! copy realmatrix rwork(irvt,KIND=${ck}$) to complex matrix work(ivt) ! overwrite work(ivt) by right singular vectors of l ! cworkspace: need m*m [vt] + 2*m [tauq, taup] + m [work] ! cworkspace: prefer m*m [vt] + 2*m [tauq, taup] + m*nb [work] ! rworkspace: need 0 - call stdlib_wlacp2( 'F', m, m, rwork( irvt ), m, work( ivt ),ldwkvt ) - call stdlib_wunmbr( 'P', 'R', 'C', m, m, m, a, lda,work( itaup ), work( ivt ),& + call stdlib_${ci}$lacp2( 'F', m, m, rwork( irvt ), m, work( ivt ),ldwkvt ) + call stdlib_${ci}$unmbr( 'P', 'R', 'C', m, m, m, a, lda,work( itaup ), work( ivt ),& ldwkvt,work( nwork ), lwork-nwork+1, ierr ) ! multiply right singular vectors of l in work(ivt) by ! q in vt, storing result in a ! cworkspace: need m*m [vt] ! rworkspace: need 0 - call stdlib_wgemm( 'N', 'N', m, n, m, cone, work( ivt ), ldwkvt,vt, ldvt, & + call stdlib_${ci}$gemm( 'N', 'N', m, n, m, cone, work( ivt ), ldwkvt,vt, ldvt, & czero, a, lda ) ! copy right singular vectors of a from a to vt - call stdlib_wlacpy( 'F', m, n, a, lda, vt, ldvt ) + call stdlib_${ci}$lacpy( 'F', m, n, a, lda, vt, ldvt ) end if else if( n>=mnthr2 ) then ! mnthr2 <= n < mnthr1 ! path 5t (n >> m, but not as much as mnthr1) ! reduce to bidiagonal form without qr decomposition, use - ! stdlib_wungbr and matrix multiplication to compute singular vectors + ! stdlib_${ci}$ungbr and matrix multiplication to compute singular vectors ie = 1 nrwork = ie + m itauq = 1 @@ -11615,14 +11617,14 @@ module stdlib_linalg_lapack_w ! cworkspace: need 2*m [tauq, taup] + n [work] ! cworkspace: prefer 2*m [tauq, taup] + (m+n)*nb [work] ! rworkspace: need m [e] - call stdlib_wgebrd( m, n, a, lda, s, rwork( ie ), work( itauq ),work( itaup ), & + call stdlib_${ci}$gebrd( m, n, a, lda, s, rwork( ie ), work( itauq ),work( itaup ), & work( nwork ), lwork-nwork+1,ierr ) if( wntqn ) then ! path 5tn (n >> m, jobz='n') ! compute singular values only ! cworkspace: need 0 ! rworkspace: need m [e] + bdspac - call stdlib_qbdsdc( 'L', 'N', m, s, rwork( ie ), dum,1,dum,1,dum, idum, rwork(& + call stdlib_${c2ri(ci)}$bdsdc( 'L', 'N', m, s, rwork( ie ), dum,1,dum,1,dum, idum, rwork(& nrwork ), iwork, info ) else if( wntqo ) then irvt = nrwork @@ -11634,14 +11636,14 @@ module stdlib_linalg_lapack_w ! cworkspace: need 2*m [tauq, taup] + m [work] ! cworkspace: prefer 2*m [tauq, taup] + m*nb [work] ! rworkspace: need 0 - call stdlib_wlacpy( 'L', m, m, a, lda, u, ldu ) - call stdlib_wungbr( 'Q', m, m, n, u, ldu, work( itauq ),work( nwork ), lwork-& + call stdlib_${ci}$lacpy( 'L', m, m, a, lda, u, ldu ) + call stdlib_${ci}$ungbr( 'Q', m, m, n, u, ldu, work( itauq ),work( nwork ), lwork-& nwork+1, ierr ) ! generate p**h in a ! cworkspace: need 2*m [tauq, taup] + m [work] ! cworkspace: prefer 2*m [tauq, taup] + m*nb [work] ! rworkspace: need 0 - call stdlib_wungbr( 'P', m, n, m, a, lda, work( itaup ),work( nwork ), lwork-& + call stdlib_${ci}$ungbr( 'P', m, n, m, a, lda, work( itaup ),work( nwork ), lwork-& nwork+1, ierr ) ldwkvt = m if( lwork >= m*n + 3*m ) then @@ -11658,15 +11660,15 @@ module stdlib_linalg_lapack_w ! singular vectors of bidiagonal matrix in rwork(irvt) ! cworkspace: need 0 ! rworkspace: need m [e] + m*m [rvt] + m*m [ru] + bdspac - call stdlib_qbdsdc( 'L', 'I', m, s, rwork( ie ), rwork( iru ),m, rwork( irvt )& + call stdlib_${c2ri(ci)}$bdsdc( 'L', 'I', m, s, rwork( ie ), rwork( iru ),m, rwork( irvt )& , m, dum, idum,rwork( nrwork ), iwork, info ) - ! multiply q in u by realmatrix rwork(irvt,KIND=qp) + ! multiply q in u by realmatrix rwork(irvt,KIND=${ck}$) ! storing the result in work(ivt), copying to u ! cworkspace: need 2*m [tauq, taup] + m*m [vt] ! rworkspace: need m [e] + m*m [rvt] + m*m [ru] + 2*m*m [rwork] - call stdlib_wlacrm( m, m, u, ldu, rwork( iru ), m, work( ivt ),ldwkvt, rwork( & + call stdlib_${ci}$lacrm( m, m, u, ldu, rwork( iru ), m, work( ivt ),ldwkvt, rwork( & nrwork ) ) - call stdlib_wlacpy( 'F', m, m, work( ivt ), ldwkvt, u, ldu ) + call stdlib_${ci}$lacpy( 'F', m, m, work( ivt ), ldwkvt, u, ldu ) ! multiply rwork(irvt) by p**h in a, storing the ! result in work(ivt), copying to a ! cworkspace: need 2*m [tauq, taup] + m*m [vt] @@ -11676,9 +11678,9 @@ module stdlib_linalg_lapack_w nrwork = iru do i = 1, n, chunk blk = min( n-i+1, chunk ) - call stdlib_wlarcm( m, blk, rwork( irvt ), m, a( 1, i ), lda,work( ivt ), & + call stdlib_${ci}$larcm( m, blk, rwork( irvt ), m, a( 1, i ), lda,work( ivt ), & ldwkvt, rwork( nrwork ) ) - call stdlib_wlacpy( 'F', m, blk, work( ivt ), ldwkvt,a( 1, i ), lda ) + call stdlib_${ci}$lacpy( 'F', m, blk, work( ivt ), ldwkvt,a( 1, i ), lda ) end do else if( wntqs ) then @@ -11687,15 +11689,15 @@ module stdlib_linalg_lapack_w ! cworkspace: need 2*m [tauq, taup] + m [work] ! cworkspace: prefer 2*m [tauq, taup] + m*nb [work] ! rworkspace: need 0 - call stdlib_wlacpy( 'L', m, m, a, lda, u, ldu ) - call stdlib_wungbr( 'Q', m, m, n, u, ldu, work( itauq ),work( nwork ), lwork-& + call stdlib_${ci}$lacpy( 'L', m, m, a, lda, u, ldu ) + call stdlib_${ci}$ungbr( 'Q', m, m, n, u, ldu, work( itauq ),work( nwork ), lwork-& nwork+1, ierr ) ! copy a to vt, generate p**h ! cworkspace: need 2*m [tauq, taup] + m [work] ! cworkspace: prefer 2*m [tauq, taup] + m*nb [work] ! rworkspace: need 0 - call stdlib_wlacpy( 'U', m, n, a, lda, vt, ldvt ) - call stdlib_wungbr( 'P', m, n, m, vt, ldvt, work( itaup ),work( nwork ), & + call stdlib_${ci}$lacpy( 'U', m, n, a, lda, vt, ldvt ) + call stdlib_${ci}$ungbr( 'P', m, n, m, vt, ldvt, work( itaup ),work( nwork ), & lwork-nwork+1, ierr ) ! perform bidiagonal svd, computing left singular vectors ! of bidiagonal matrix in rwork(iru) and computing right @@ -11705,38 +11707,38 @@ module stdlib_linalg_lapack_w irvt = nrwork iru = irvt + m*m nrwork = iru + m*m - call stdlib_qbdsdc( 'L', 'I', m, s, rwork( ie ), rwork( iru ),m, rwork( irvt )& + call stdlib_${c2ri(ci)}$bdsdc( 'L', 'I', m, s, rwork( ie ), rwork( iru ),m, rwork( irvt )& , m, dum, idum,rwork( nrwork ), iwork, info ) - ! multiply q in u by realmatrix rwork(iru,KIND=qp), storing the + ! multiply q in u by realmatrix rwork(iru,KIND=${ck}$), storing the ! result in a, copying to u ! cworkspace: need 0 ! rworkspace: need m [e] + m*m [rvt] + m*m [ru] + 2*m*m [rwork] - call stdlib_wlacrm( m, m, u, ldu, rwork( iru ), m, a, lda,rwork( nrwork ) ) + call stdlib_${ci}$lacrm( m, m, u, ldu, rwork( iru ), m, a, lda,rwork( nrwork ) ) - call stdlib_wlacpy( 'F', m, m, a, lda, u, ldu ) - ! multiply realmatrix rwork(irvt,KIND=qp) by p**h in vt, + call stdlib_${ci}$lacpy( 'F', m, m, a, lda, u, ldu ) + ! multiply realmatrix rwork(irvt,KIND=${ck}$) by p**h in vt, ! storing the result in a, copying to vt ! cworkspace: need 0 ! rworkspace: need m [e] + m*m [rvt] + 2*m*n [rwork] < m + 5*m*m since n < 2*m here nrwork = iru - call stdlib_wlarcm( m, n, rwork( irvt ), m, vt, ldvt, a, lda,rwork( nrwork ) ) + call stdlib_${ci}$larcm( m, n, rwork( irvt ), m, vt, ldvt, a, lda,rwork( nrwork ) ) - call stdlib_wlacpy( 'F', m, n, a, lda, vt, ldvt ) + call stdlib_${ci}$lacpy( 'F', m, n, a, lda, vt, ldvt ) else ! path 5ta (n >> m, jobz='a') ! copy a to u, generate q ! cworkspace: need 2*m [tauq, taup] + m [work] ! cworkspace: prefer 2*m [tauq, taup] + m*nb [work] ! rworkspace: need 0 - call stdlib_wlacpy( 'L', m, m, a, lda, u, ldu ) - call stdlib_wungbr( 'Q', m, m, n, u, ldu, work( itauq ),work( nwork ), lwork-& + call stdlib_${ci}$lacpy( 'L', m, m, a, lda, u, ldu ) + call stdlib_${ci}$ungbr( 'Q', m, m, n, u, ldu, work( itauq ),work( nwork ), lwork-& nwork+1, ierr ) ! copy a to vt, generate p**h ! cworkspace: need 2*m [tauq, taup] + n [work] ! cworkspace: prefer 2*m [tauq, taup] + n*nb [work] ! rworkspace: need 0 - call stdlib_wlacpy( 'U', m, n, a, lda, vt, ldvt ) - call stdlib_wungbr( 'P', n, n, m, vt, ldvt, work( itaup ),work( nwork ), & + call stdlib_${ci}$lacpy( 'U', m, n, a, lda, vt, ldvt ) + call stdlib_${ci}$ungbr( 'P', n, n, m, vt, ldvt, work( itaup ),work( nwork ), & lwork-nwork+1, ierr ) ! perform bidiagonal svd, computing left singular vectors ! of bidiagonal matrix in rwork(iru) and computing right @@ -11746,29 +11748,29 @@ module stdlib_linalg_lapack_w irvt = nrwork iru = irvt + m*m nrwork = iru + m*m - call stdlib_qbdsdc( 'L', 'I', m, s, rwork( ie ), rwork( iru ),m, rwork( irvt )& + call stdlib_${c2ri(ci)}$bdsdc( 'L', 'I', m, s, rwork( ie ), rwork( iru ),m, rwork( irvt )& , m, dum, idum,rwork( nrwork ), iwork, info ) - ! multiply q in u by realmatrix rwork(iru,KIND=qp), storing the + ! multiply q in u by realmatrix rwork(iru,KIND=${ck}$), storing the ! result in a, copying to u ! cworkspace: need 0 ! rworkspace: need m [e] + m*m [rvt] + m*m [ru] + 2*m*m [rwork] - call stdlib_wlacrm( m, m, u, ldu, rwork( iru ), m, a, lda,rwork( nrwork ) ) + call stdlib_${ci}$lacrm( m, m, u, ldu, rwork( iru ), m, a, lda,rwork( nrwork ) ) - call stdlib_wlacpy( 'F', m, m, a, lda, u, ldu ) - ! multiply realmatrix rwork(irvt,KIND=qp) by p**h in vt, + call stdlib_${ci}$lacpy( 'F', m, m, a, lda, u, ldu ) + ! multiply realmatrix rwork(irvt,KIND=${ck}$) by p**h in vt, ! storing the result in a, copying to vt ! cworkspace: need 0 ! rworkspace: need m [e] + m*m [rvt] + 2*m*n [rwork] < m + 5*m*m since n < 2*m here nrwork = iru - call stdlib_wlarcm( m, n, rwork( irvt ), m, vt, ldvt, a, lda,rwork( nrwork ) ) + call stdlib_${ci}$larcm( m, n, rwork( irvt ), m, vt, ldvt, a, lda,rwork( nrwork ) ) - call stdlib_wlacpy( 'F', m, n, a, lda, vt, ldvt ) + call stdlib_${ci}$lacpy( 'F', m, n, a, lda, vt, ldvt ) end if else ! n < mnthr2 ! path 6t (n > m, but not much larger) ! reduce to bidiagonal form without lq decomposition - ! use stdlib_wunmbr to compute singular vectors + ! use stdlib_${ci}$unmbr to compute singular vectors ie = 1 nrwork = ie + m itauq = 1 @@ -11778,14 +11780,14 @@ module stdlib_linalg_lapack_w ! cworkspace: need 2*m [tauq, taup] + n [work] ! cworkspace: prefer 2*m [tauq, taup] + (m+n)*nb [work] ! rworkspace: need m [e] - call stdlib_wgebrd( m, n, a, lda, s, rwork( ie ), work( itauq ),work( itaup ), & + call stdlib_${ci}$gebrd( m, n, a, lda, s, rwork( ie ), work( itauq ),work( itaup ), & work( nwork ), lwork-nwork+1,ierr ) if( wntqn ) then ! path 6tn (n > m, jobz='n') ! compute singular values only ! cworkspace: need 0 ! rworkspace: need m [e] + bdspac - call stdlib_qbdsdc( 'L', 'N', m, s, rwork( ie ), dum,1,dum,1,dum, idum, rwork(& + call stdlib_${c2ri(ci)}$bdsdc( 'L', 'N', m, s, rwork( ie ), dum,1,dum,1,dum, idum, rwork(& nrwork ), iwork, info ) else if( wntqo ) then ! path 6to (n > m, jobz='o') @@ -11793,7 +11795,7 @@ module stdlib_linalg_lapack_w ivt = nwork if( lwork >= m*n + 3*m ) then ! work( ivt ) is m by n - call stdlib_wlaset( 'F', m, n, czero, czero, work( ivt ),ldwkvt ) + call stdlib_${ci}$laset( 'F', m, n, czero, czero, work( ivt ),ldwkvt ) nwork = ivt + ldwkvt*n else ! work( ivt ) is m by chunk @@ -11808,38 +11810,38 @@ module stdlib_linalg_lapack_w irvt = nrwork iru = irvt + m*m nrwork = iru + m*m - call stdlib_qbdsdc( 'L', 'I', m, s, rwork( ie ), rwork( iru ),m, rwork( irvt )& + call stdlib_${c2ri(ci)}$bdsdc( 'L', 'I', m, s, rwork( ie ), rwork( iru ),m, rwork( irvt )& , m, dum, idum,rwork( nrwork ), iwork, info ) - ! copy realmatrix rwork(iru,KIND=qp) to complex matrix u + ! copy realmatrix rwork(iru,KIND=${ck}$) to complex matrix u ! overwrite u by left singular vectors of a ! cworkspace: need 2*m [tauq, taup] + m*m [vt] + m [work] ! cworkspace: prefer 2*m [tauq, taup] + m*m [vt] + m*nb [work] ! rworkspace: need m [e] + m*m [rvt] + m*m [ru] - call stdlib_wlacp2( 'F', m, m, rwork( iru ), m, u, ldu ) - call stdlib_wunmbr( 'Q', 'L', 'N', m, m, n, a, lda,work( itauq ), u, ldu, & + call stdlib_${ci}$lacp2( 'F', m, m, rwork( iru ), m, u, ldu ) + call stdlib_${ci}$unmbr( 'Q', 'L', 'N', m, m, n, a, lda,work( itauq ), u, ldu, & work( nwork ),lwork-nwork+1, ierr ) if( lwork >= m*n + 3*m ) then ! path 6to-fast - ! copy realmatrix rwork(irvt,KIND=qp) to complex matrix work(ivt) + ! copy realmatrix rwork(irvt,KIND=${ck}$) to complex matrix work(ivt) ! overwrite work(ivt) by right singular vectors of a, ! copying to a ! cworkspace: need 2*m [tauq, taup] + m*n [vt] + m [work] ! cworkspace: prefer 2*m [tauq, taup] + m*n [vt] + m*nb [work] ! rworkspace: need m [e] + m*m [rvt] - call stdlib_wlacp2( 'F', m, m, rwork( irvt ), m, work( ivt ),ldwkvt ) + call stdlib_${ci}$lacp2( 'F', m, m, rwork( irvt ), m, work( ivt ),ldwkvt ) - call stdlib_wunmbr( 'P', 'R', 'C', m, n, m, a, lda,work( itaup ), work( & + call stdlib_${ci}$unmbr( 'P', 'R', 'C', m, n, m, a, lda,work( itaup ), work( & ivt ), ldwkvt,work( nwork ), lwork-nwork+1, ierr ) - call stdlib_wlacpy( 'F', m, n, work( ivt ), ldwkvt, a, lda ) + call stdlib_${ci}$lacpy( 'F', m, n, work( ivt ), ldwkvt, a, lda ) else ! path 6to-slow ! generate p**h in a ! cworkspace: need 2*m [tauq, taup] + m*m [vt] + m [work] ! cworkspace: prefer 2*m [tauq, taup] + m*m [vt] + m*nb [work] ! rworkspace: need 0 - call stdlib_wungbr( 'P', m, n, m, a, lda, work( itaup ),work( nwork ), & + call stdlib_${ci}$ungbr( 'P', m, n, m, a, lda, work( itaup ),work( nwork ), & lwork-nwork+1, ierr ) - ! multiply q in a by realmatrix rwork(iru,KIND=qp), storing the + ! multiply q in a by realmatrix rwork(iru,KIND=${ck}$), storing the ! result in work(iu), copying to a ! cworkspace: need 2*m [tauq, taup] + m*m [vt] ! cworkspace: prefer 2*m [tauq, taup] + m*n [vt] @@ -11848,9 +11850,9 @@ module stdlib_linalg_lapack_w nrwork = iru do i = 1, n, chunk blk = min( n-i+1, chunk ) - call stdlib_wlarcm( m, blk, rwork( irvt ), m, a( 1, i ),lda, work( ivt )& + call stdlib_${ci}$larcm( m, blk, rwork( irvt ), m, a( 1, i ),lda, work( ivt )& , ldwkvt,rwork( nrwork ) ) - call stdlib_wlacpy( 'F', m, blk, work( ivt ), ldwkvt,a( 1, i ), lda ) + call stdlib_${ci}$lacpy( 'F', m, blk, work( ivt ), ldwkvt,a( 1, i ), lda ) end do end if @@ -11864,24 +11866,24 @@ module stdlib_linalg_lapack_w irvt = nrwork iru = irvt + m*m nrwork = iru + m*m - call stdlib_qbdsdc( 'L', 'I', m, s, rwork( ie ), rwork( iru ),m, rwork( irvt )& + call stdlib_${c2ri(ci)}$bdsdc( 'L', 'I', m, s, rwork( ie ), rwork( iru ),m, rwork( irvt )& , m, dum, idum,rwork( nrwork ), iwork, info ) - ! copy realmatrix rwork(iru,KIND=qp) to complex matrix u + ! copy realmatrix rwork(iru,KIND=${ck}$) to complex matrix u ! overwrite u by left singular vectors of a ! cworkspace: need 2*m [tauq, taup] + m [work] ! cworkspace: prefer 2*m [tauq, taup] + m*nb [work] ! rworkspace: need m [e] + m*m [rvt] + m*m [ru] - call stdlib_wlacp2( 'F', m, m, rwork( iru ), m, u, ldu ) - call stdlib_wunmbr( 'Q', 'L', 'N', m, m, n, a, lda,work( itauq ), u, ldu, & + call stdlib_${ci}$lacp2( 'F', m, m, rwork( iru ), m, u, ldu ) + call stdlib_${ci}$unmbr( 'Q', 'L', 'N', m, m, n, a, lda,work( itauq ), u, ldu, & work( nwork ),lwork-nwork+1, ierr ) - ! copy realmatrix rwork(irvt,KIND=qp) to complex matrix vt + ! copy realmatrix rwork(irvt,KIND=${ck}$) to complex matrix vt ! overwrite vt by right singular vectors of a ! cworkspace: need 2*m [tauq, taup] + m [work] ! cworkspace: prefer 2*m [tauq, taup] + m*nb [work] ! rworkspace: need m [e] + m*m [rvt] - call stdlib_wlaset( 'F', m, n, czero, czero, vt, ldvt ) - call stdlib_wlacp2( 'F', m, m, rwork( irvt ), m, vt, ldvt ) - call stdlib_wunmbr( 'P', 'R', 'C', m, n, m, a, lda,work( itaup ), vt, ldvt, & + call stdlib_${ci}$laset( 'F', m, n, czero, czero, vt, ldvt ) + call stdlib_${ci}$lacp2( 'F', m, m, rwork( irvt ), m, vt, ldvt ) + call stdlib_${ci}$unmbr( 'P', 'R', 'C', m, n, m, a, lda,work( itaup ), vt, ldvt, & work( nwork ),lwork-nwork+1, ierr ) else ! path 6ta (n > m, jobz='a') @@ -11893,47 +11895,47 @@ module stdlib_linalg_lapack_w irvt = nrwork iru = irvt + m*m nrwork = iru + m*m - call stdlib_qbdsdc( 'L', 'I', m, s, rwork( ie ), rwork( iru ),m, rwork( irvt )& + call stdlib_${c2ri(ci)}$bdsdc( 'L', 'I', m, s, rwork( ie ), rwork( iru ),m, rwork( irvt )& , m, dum, idum,rwork( nrwork ), iwork, info ) - ! copy realmatrix rwork(iru,KIND=qp) to complex matrix u + ! copy realmatrix rwork(iru,KIND=${ck}$) to complex matrix u ! overwrite u by left singular vectors of a ! cworkspace: need 2*m [tauq, taup] + m [work] ! cworkspace: prefer 2*m [tauq, taup] + m*nb [work] ! rworkspace: need m [e] + m*m [rvt] + m*m [ru] - call stdlib_wlacp2( 'F', m, m, rwork( iru ), m, u, ldu ) - call stdlib_wunmbr( 'Q', 'L', 'N', m, m, n, a, lda,work( itauq ), u, ldu, & + call stdlib_${ci}$lacp2( 'F', m, m, rwork( iru ), m, u, ldu ) + call stdlib_${ci}$unmbr( 'Q', 'L', 'N', m, m, n, a, lda,work( itauq ), u, ldu, & work( nwork ),lwork-nwork+1, ierr ) ! set all of vt to identity matrix - call stdlib_wlaset( 'F', n, n, czero, cone, vt, ldvt ) - ! copy realmatrix rwork(irvt,KIND=qp) to complex matrix vt + call stdlib_${ci}$laset( 'F', n, n, czero, cone, vt, ldvt ) + ! copy realmatrix rwork(irvt,KIND=${ck}$) to complex matrix vt ! overwrite vt by right singular vectors of a ! cworkspace: need 2*m [tauq, taup] + n [work] ! cworkspace: prefer 2*m [tauq, taup] + n*nb [work] ! rworkspace: need m [e] + m*m [rvt] - call stdlib_wlacp2( 'F', m, m, rwork( irvt ), m, vt, ldvt ) - call stdlib_wunmbr( 'P', 'R', 'C', n, n, m, a, lda,work( itaup ), vt, ldvt, & + call stdlib_${ci}$lacp2( 'F', m, m, rwork( irvt ), m, vt, ldvt ) + call stdlib_${ci}$unmbr( 'P', 'R', 'C', n, n, m, a, lda,work( itaup ), vt, ldvt, & work( nwork ),lwork-nwork+1, ierr ) end if end if end if ! undo scaling if necessary if( iscl==1 ) then - if( anrm>bignum )call stdlib_qlascl( 'G', 0, 0, bignum, anrm, minmn, 1, s, minmn,& + if( anrm>bignum )call stdlib_${c2ri(ci)}$lascl( 'G', 0, 0, bignum, anrm, minmn, 1, s, minmn,& ierr ) - if( info/=0 .and. anrm>bignum )call stdlib_qlascl( 'G', 0, 0, bignum, anrm, minmn-1,& + if( info/=0 .and. anrm>bignum )call stdlib_${c2ri(ci)}$lascl( 'G', 0, 0, bignum, anrm, minmn-1,& 1,rwork( ie ), minmn, ierr ) - if( anrm=n .and. minmn>0 ) then - ! space needed for stdlib_wbdsqr is bdspac = 5*n + ! space needed for stdlib_${ci}$bdsqr is bdspac = 5*n mnthr = stdlib_ilaenv( 6, 'ZGESVD', jobu // jobvt, m, n, 0, 0 ) - ! compute space needed for stdlib_wgeqrf - call stdlib_wgeqrf( m, n, a, lda, cdum(1), cdum(1), -1, ierr ) + ! compute space needed for stdlib_${ci}$geqrf + call stdlib_${ci}$geqrf( m, n, a, lda, cdum(1), cdum(1), -1, ierr ) lwork_wgeqrf = int( cdum(1),KIND=ilp) - ! compute space needed for stdlib_wungqr - call stdlib_wungqr( m, n, n, a, lda, cdum(1), cdum(1), -1, ierr ) + ! compute space needed for stdlib_${ci}$ungqr + call stdlib_${ci}$ungqr( m, n, n, a, lda, cdum(1), cdum(1), -1, ierr ) lwork_wungqr_n = int( cdum(1),KIND=ilp) - call stdlib_wungqr( m, m, n, a, lda, cdum(1), cdum(1), -1, ierr ) + call stdlib_${ci}$ungqr( m, m, n, a, lda, cdum(1), cdum(1), -1, ierr ) lwork_wungqr_m = int( cdum(1),KIND=ilp) - ! compute space needed for stdlib_wgebrd - call stdlib_wgebrd( n, n, a, lda, s, dum(1), cdum(1),cdum(1), cdum(1), -1, ierr ) + ! compute space needed for stdlib_${ci}$gebrd + call stdlib_${ci}$gebrd( n, n, a, lda, s, dum(1), cdum(1),cdum(1), cdum(1), -1, ierr ) lwork_wgebrd = int( cdum(1),KIND=ilp) - ! compute space needed for stdlib_wungbr - call stdlib_wungbr( 'P', n, n, n, a, lda, cdum(1),cdum(1), -1, ierr ) + ! compute space needed for stdlib_${ci}$ungbr + call stdlib_${ci}$ungbr( 'P', n, n, n, a, lda, cdum(1),cdum(1), -1, ierr ) lwork_wungbr_p = int( cdum(1),KIND=ilp) - call stdlib_wungbr( 'Q', n, n, n, a, lda, cdum(1),cdum(1), -1, ierr ) + call stdlib_${ci}$ungbr( 'Q', n, n, n, a, lda, cdum(1),cdum(1), -1, ierr ) lwork_wungbr_q = int( cdum(1),KIND=ilp) if( m>=mnthr ) then if( wntun ) then @@ -12166,18 +12168,18 @@ module stdlib_linalg_lapack_w end if else ! path 10 (m at least n, but not much larger) - call stdlib_wgebrd( m, n, a, lda, s, dum(1), cdum(1),cdum(1), cdum(1), -1, & + call stdlib_${ci}$gebrd( m, n, a, lda, s, dum(1), cdum(1),cdum(1), cdum(1), -1, & ierr ) lwork_wgebrd = int( cdum(1),KIND=ilp) maxwrk = 2*n + lwork_wgebrd if( wntus .or. wntuo ) then - call stdlib_wungbr( 'Q', m, n, n, a, lda, cdum(1),cdum(1), -1, ierr ) + call stdlib_${ci}$ungbr( 'Q', m, n, n, a, lda, cdum(1),cdum(1), -1, ierr ) lwork_wungbr_q = int( cdum(1),KIND=ilp) maxwrk = max( maxwrk, 2*n+lwork_wungbr_q ) end if if( wntua ) then - call stdlib_wungbr( 'Q', m, m, n, a, lda, cdum(1),cdum(1), -1, ierr ) + call stdlib_${ci}$ungbr( 'Q', m, m, n, a, lda, cdum(1),cdum(1), -1, ierr ) lwork_wungbr_q = int( cdum(1),KIND=ilp) maxwrk = max( maxwrk, 2*n+lwork_wungbr_q ) @@ -12188,25 +12190,25 @@ module stdlib_linalg_lapack_w minwrk = 2*n + m end if else if( minmn>0 ) then - ! space needed for stdlib_wbdsqr is bdspac = 5*m + ! space needed for stdlib_${ci}$bdsqr is bdspac = 5*m mnthr = stdlib_ilaenv( 6, 'ZGESVD', jobu // jobvt, m, n, 0, 0 ) - ! compute space needed for stdlib_wgelqf - call stdlib_wgelqf( m, n, a, lda, cdum(1), cdum(1), -1, ierr ) + ! compute space needed for stdlib_${ci}$gelqf + call stdlib_${ci}$gelqf( m, n, a, lda, cdum(1), cdum(1), -1, ierr ) lwork_wgelqf = int( cdum(1),KIND=ilp) - ! compute space needed for stdlib_wunglq - call stdlib_wunglq( n, n, m, cdum(1), n, cdum(1), cdum(1), -1,ierr ) + ! compute space needed for stdlib_${ci}$unglq + call stdlib_${ci}$unglq( n, n, m, cdum(1), n, cdum(1), cdum(1), -1,ierr ) lwork_wunglq_n = int( cdum(1),KIND=ilp) - call stdlib_wunglq( m, n, m, a, lda, cdum(1), cdum(1), -1, ierr ) + call stdlib_${ci}$unglq( m, n, m, a, lda, cdum(1), cdum(1), -1, ierr ) lwork_wunglq_m = int( cdum(1),KIND=ilp) - ! compute space needed for stdlib_wgebrd - call stdlib_wgebrd( m, m, a, lda, s, dum(1), cdum(1),cdum(1), cdum(1), -1, ierr ) + ! compute space needed for stdlib_${ci}$gebrd + call stdlib_${ci}$gebrd( m, m, a, lda, s, dum(1), cdum(1),cdum(1), cdum(1), -1, ierr ) lwork_wgebrd = int( cdum(1),KIND=ilp) - ! compute space needed for stdlib_wungbr p - call stdlib_wungbr( 'P', m, m, m, a, n, cdum(1),cdum(1), -1, ierr ) + ! compute space needed for stdlib_${ci}$ungbr p + call stdlib_${ci}$ungbr( 'P', m, m, m, a, n, cdum(1),cdum(1), -1, ierr ) lwork_wungbr_p = int( cdum(1),KIND=ilp) - ! compute space needed for stdlib_wungbr q - call stdlib_wungbr( 'Q', m, m, m, a, n, cdum(1),cdum(1), -1, ierr ) + ! compute space needed for stdlib_${ci}$ungbr q + call stdlib_${ci}$ungbr( 'Q', m, m, m, a, n, cdum(1),cdum(1), -1, ierr ) lwork_wungbr_q = int( cdum(1),KIND=ilp) if( n>=mnthr ) then if( wntvn ) then @@ -12290,18 +12292,18 @@ module stdlib_linalg_lapack_w end if else ! path 10t(n greater than m, but not much larger) - call stdlib_wgebrd( m, n, a, lda, s, dum(1), cdum(1),cdum(1), cdum(1), -1, & + call stdlib_${ci}$gebrd( m, n, a, lda, s, dum(1), cdum(1),cdum(1), cdum(1), -1, & ierr ) lwork_wgebrd = int( cdum(1),KIND=ilp) maxwrk = 2*m + lwork_wgebrd if( wntvs .or. wntvo ) then - ! compute space needed for stdlib_wungbr p - call stdlib_wungbr( 'P', m, n, m, a, n, cdum(1),cdum(1), -1, ierr ) + ! compute space needed for stdlib_${ci}$ungbr p + call stdlib_${ci}$ungbr( 'P', m, n, m, a, n, cdum(1),cdum(1), -1, ierr ) lwork_wungbr_p = int( cdum(1),KIND=ilp) maxwrk = max( maxwrk, 2*m+lwork_wungbr_p ) end if if( wntva ) then - call stdlib_wungbr( 'P', n, n, m, a, n, cdum(1),cdum(1), -1, ierr ) + call stdlib_${ci}$ungbr( 'P', n, n, m, a, n, cdum(1),cdum(1), -1, ierr ) lwork_wungbr_p = int( cdum(1),KIND=ilp) maxwrk = max( maxwrk, 2*m+lwork_wungbr_p ) end if @@ -12328,18 +12330,18 @@ module stdlib_linalg_lapack_w return end if ! get machine constants - eps = stdlib_qlamch( 'P' ) - smlnum = sqrt( stdlib_qlamch( 'S' ) ) / eps + eps = stdlib_${c2ri(ci)}$lamch( 'P' ) + smlnum = sqrt( stdlib_${c2ri(ci)}$lamch( 'S' ) ) / eps bignum = one / smlnum ! scale a if max element outside range [smlnum,bignum] - anrm = stdlib_wlange( 'M', m, n, a, lda, dum ) + anrm = stdlib_${ci}$lange( 'M', m, n, a, lda, dum ) iscl = 0 if( anrm>zero .and. anrmbignum ) then iscl = 1 - call stdlib_wlascl( 'G', 0, 0, anrm, bignum, m, n, a, lda, ierr ) + call stdlib_${ci}$lascl( 'G', 0, 0, anrm, bignum, m, n, a, lda, ierr ) end if if( m>=n ) then ! a has at least as many rows as columns. if a has sufficiently @@ -12354,11 +12356,11 @@ module stdlib_linalg_lapack_w ! compute a=q*r ! (cworkspace: need 2*n, prefer n+n*nb) ! (rworkspace: need 0) - call stdlib_wgeqrf( m, n, a, lda, work( itau ), work( iwork ),lwork-iwork+1, & + call stdlib_${ci}$geqrf( m, n, a, lda, work( itau ), work( iwork ),lwork-iwork+1, & ierr ) ! zero out below r if( n > 1 ) then - call stdlib_wlaset( 'L', n-1, n-1, czero, czero, a( 2, 1 ),lda ) + call stdlib_${ci}$laset( 'L', n-1, n-1, czero, czero, a( 2, 1 ),lda ) end if ie = 1 itauq = 1 @@ -12367,14 +12369,14 @@ module stdlib_linalg_lapack_w ! bidiagonalize r in a ! (cworkspace: need 3*n, prefer 2*n+2*n*nb) ! (rworkspace: need n) - call stdlib_wgebrd( n, n, a, lda, s, rwork( ie ), work( itauq ),work( itaup ),& + call stdlib_${ci}$gebrd( n, n, a, lda, s, rwork( ie ), work( itauq ),work( itaup ),& work( iwork ), lwork-iwork+1,ierr ) ncvt = 0 if( wntvo .or. wntvas ) then ! if right singular vectors desired, generate p'. ! (cworkspace: need 3*n-1, prefer 2*n+(n-1)*nb) ! (rworkspace: 0) - call stdlib_wungbr( 'P', n, n, n, a, lda, work( itaup ),work( iwork ), & + call stdlib_${ci}$ungbr( 'P', n, n, n, a, lda, work( itaup ),work( iwork ), & lwork-iwork+1, ierr ) ncvt = n end if @@ -12383,10 +12385,10 @@ module stdlib_linalg_lapack_w ! singular vectors of a in a if desired ! (cworkspace: 0) ! (rworkspace: need bdspac) - call stdlib_wbdsqr( 'U', n, ncvt, 0, 0, s, rwork( ie ), a, lda,cdum, 1, cdum, & + call stdlib_${ci}$bdsqr( 'U', n, ncvt, 0, 0, s, rwork( ie ), a, lda,cdum, 1, cdum, & 1, rwork( irwork ), info ) ! if right singular vectors desired in vt, copy them there - if( wntvas )call stdlib_wlacpy( 'F', n, n, a, lda, vt, ldvt ) + if( wntvas )call stdlib_${ci}$lacpy( 'F', n, n, a, lda, vt, ldvt ) else if( wntuo .and. wntvn ) then ! path 2 (m much larger than n, jobu='o', jobvt='n') ! n left singular vectors to be overwritten on a and @@ -12412,16 +12414,16 @@ module stdlib_linalg_lapack_w ! compute a=q*r ! (cworkspace: need n*n+2*n, prefer n*n+n+n*nb) ! (rworkspace: 0) - call stdlib_wgeqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-iwork+& + call stdlib_${ci}$geqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-iwork+& 1, ierr ) ! copy r to work(ir) and zero out below it - call stdlib_wlacpy( 'U', n, n, a, lda, work( ir ), ldwrkr ) - call stdlib_wlaset( 'L', n-1, n-1, czero, czero,work( ir+1 ), ldwrkr ) + call stdlib_${ci}$lacpy( 'U', n, n, a, lda, work( ir ), ldwrkr ) + call stdlib_${ci}$laset( 'L', n-1, n-1, czero, czero,work( ir+1 ), ldwrkr ) ! generate q in a ! (cworkspace: need n*n+2*n, prefer n*n+n+n*nb) ! (rworkspace: 0) - call stdlib_wungqr( m, n, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib_${ci}$ungqr( m, n, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ie = 1 itauq = itau @@ -12430,19 +12432,19 @@ module stdlib_linalg_lapack_w ! bidiagonalize r in work(ir) ! (cworkspace: need n*n+3*n, prefer n*n+2*n+2*n*nb) ! (rworkspace: need n) - call stdlib_wgebrd( n, n, work( ir ), ldwrkr, s, rwork( ie ),work( itauq ),& + call stdlib_${ci}$gebrd( n, n, work( ir ), ldwrkr, s, rwork( ie ),work( itauq ),& work( itaup ),work( iwork ), lwork-iwork+1, ierr ) ! generate left vectors bidiagonalizing r ! (cworkspace: need n*n+3*n, prefer n*n+2*n+n*nb) ! (rworkspace: need 0) - call stdlib_wungbr( 'Q', n, n, n, work( ir ), ldwrkr,work( itauq ), work( & + call stdlib_${ci}$ungbr( 'Q', n, n, n, work( ir ), ldwrkr,work( itauq ), work( & iwork ),lwork-iwork+1, ierr ) irwork = ie + n ! perform bidiagonal qr iteration, computing left ! singular vectors of r in work(ir) ! (cworkspace: need n*n) ! (rworkspace: need bdspac) - call stdlib_wbdsqr( 'U', n, 0, n, 0, s, rwork( ie ), cdum, 1,work( ir ), & + call stdlib_${ci}$bdsqr( 'U', n, 0, n, 0, s, rwork( ie ), cdum, 1,work( ir ), & ldwrkr, cdum, 1,rwork( irwork ), info ) iu = itauq ! multiply q in a by left singular vectors of r in @@ -12451,9 +12453,9 @@ module stdlib_linalg_lapack_w ! (rworkspace: 0) do i = 1, m, ldwrku chunk = min( m-i+1, ldwrku ) - call stdlib_wgemm( 'N', 'N', chunk, n, n, cone, a( i, 1 ),lda, work( ir & + call stdlib_${ci}$gemm( 'N', 'N', chunk, n, n, cone, a( i, 1 ),lda, work( ir & ), ldwrkr, czero,work( iu ), ldwrku ) - call stdlib_wlacpy( 'F', chunk, n, work( iu ), ldwrku,a( i, 1 ), lda ) + call stdlib_${ci}$lacpy( 'F', chunk, n, work( iu ), ldwrku,a( i, 1 ), lda ) end do else @@ -12465,19 +12467,19 @@ module stdlib_linalg_lapack_w ! bidiagonalize a ! (cworkspace: need 2*n+m, prefer 2*n+(m+n)*nb) ! (rworkspace: n) - call stdlib_wgebrd( m, n, a, lda, s, rwork( ie ),work( itauq ), work( & + call stdlib_${ci}$gebrd( m, n, a, lda, s, rwork( ie ),work( itauq ), work( & itaup ),work( iwork ), lwork-iwork+1, ierr ) ! generate left vectors bidiagonalizing a ! (cworkspace: need 3*n, prefer 2*n+n*nb) ! (rworkspace: 0) - call stdlib_wungbr( 'Q', m, n, n, a, lda, work( itauq ),work( iwork ), & + call stdlib_${ci}$ungbr( 'Q', m, n, n, a, lda, work( itauq ),work( iwork ), & lwork-iwork+1, ierr ) irwork = ie + n ! perform bidiagonal qr iteration, computing left ! singular vectors of a in a ! (cworkspace: need 0) ! (rworkspace: need bdspac) - call stdlib_wbdsqr( 'U', n, 0, m, 0, s, rwork( ie ), cdum, 1,a, lda, cdum, & + call stdlib_${ci}$bdsqr( 'U', n, 0, m, 0, s, rwork( ie ), cdum, 1,a, lda, cdum, & 1, rwork( irwork ), info ) end if else if( wntuo .and. wntvas ) then @@ -12505,16 +12507,16 @@ module stdlib_linalg_lapack_w ! compute a=q*r ! (cworkspace: need n*n+2*n, prefer n*n+n+n*nb) ! (rworkspace: 0) - call stdlib_wgeqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-iwork+& + call stdlib_${ci}$geqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-iwork+& 1, ierr ) ! copy r to vt, zeroing out below it - call stdlib_wlacpy( 'U', n, n, a, lda, vt, ldvt ) - if( n>1 )call stdlib_wlaset( 'L', n-1, n-1, czero, czero,vt( 2, 1 ), ldvt ) + call stdlib_${ci}$lacpy( 'U', n, n, a, lda, vt, ldvt ) + if( n>1 )call stdlib_${ci}$laset( 'L', n-1, n-1, czero, czero,vt( 2, 1 ), ldvt ) ! generate q in a ! (cworkspace: need n*n+2*n, prefer n*n+n+n*nb) ! (rworkspace: 0) - call stdlib_wungqr( m, n, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib_${ci}$ungqr( m, n, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ie = 1 itauq = itau @@ -12523,18 +12525,18 @@ module stdlib_linalg_lapack_w ! bidiagonalize r in vt, copying result to work(ir) ! (cworkspace: need n*n+3*n, prefer n*n+2*n+2*n*nb) ! (rworkspace: need n) - call stdlib_wgebrd( n, n, vt, ldvt, s, rwork( ie ),work( itauq ), work( & + call stdlib_${ci}$gebrd( n, n, vt, ldvt, s, rwork( ie ),work( itauq ), work( & itaup ),work( iwork ), lwork-iwork+1, ierr ) - call stdlib_wlacpy( 'L', n, n, vt, ldvt, work( ir ), ldwrkr ) + call stdlib_${ci}$lacpy( 'L', n, n, vt, ldvt, work( ir ), ldwrkr ) ! generate left vectors bidiagonalizing r in work(ir) ! (cworkspace: need n*n+3*n, prefer n*n+2*n+n*nb) ! (rworkspace: 0) - call stdlib_wungbr( 'Q', n, n, n, work( ir ), ldwrkr,work( itauq ), work( & + call stdlib_${ci}$ungbr( 'Q', n, n, n, work( ir ), ldwrkr,work( itauq ), work( & iwork ),lwork-iwork+1, ierr ) ! generate right vectors bidiagonalizing r in vt ! (cworkspace: need n*n+3*n-1, prefer n*n+2*n+(n-1)*nb) ! (rworkspace: 0) - call stdlib_wungbr( 'P', n, n, n, vt, ldvt, work( itaup ),work( iwork ), & + call stdlib_${ci}$ungbr( 'P', n, n, n, vt, ldvt, work( itaup ),work( iwork ), & lwork-iwork+1, ierr ) irwork = ie + n ! perform bidiagonal qr iteration, computing left @@ -12542,7 +12544,7 @@ module stdlib_linalg_lapack_w ! singular vectors of r in vt ! (cworkspace: need n*n) ! (rworkspace: need bdspac) - call stdlib_wbdsqr( 'U', n, n, n, 0, s, rwork( ie ), vt,ldvt, work( ir ), & + call stdlib_${ci}$bdsqr( 'U', n, n, n, 0, s, rwork( ie ), vt,ldvt, work( ir ), & ldwrkr, cdum, 1,rwork( irwork ), info ) iu = itauq ! multiply q in a by left singular vectors of r in @@ -12551,9 +12553,9 @@ module stdlib_linalg_lapack_w ! (rworkspace: 0) do i = 1, m, ldwrku chunk = min( m-i+1, ldwrku ) - call stdlib_wgemm( 'N', 'N', chunk, n, n, cone, a( i, 1 ),lda, work( ir & + call stdlib_${ci}$gemm( 'N', 'N', chunk, n, n, cone, a( i, 1 ),lda, work( ir & ), ldwrkr, czero,work( iu ), ldwrku ) - call stdlib_wlacpy( 'F', chunk, n, work( iu ), ldwrku,a( i, 1 ), lda ) + call stdlib_${ci}$lacpy( 'F', chunk, n, work( iu ), ldwrku,a( i, 1 ), lda ) end do else @@ -12563,16 +12565,16 @@ module stdlib_linalg_lapack_w ! compute a=q*r ! (cworkspace: need 2*n, prefer n+n*nb) ! (rworkspace: 0) - call stdlib_wgeqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-iwork+& + call stdlib_${ci}$geqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-iwork+& 1, ierr ) ! copy r to vt, zeroing out below it - call stdlib_wlacpy( 'U', n, n, a, lda, vt, ldvt ) - if( n>1 )call stdlib_wlaset( 'L', n-1, n-1, czero, czero,vt( 2, 1 ), ldvt ) + call stdlib_${ci}$lacpy( 'U', n, n, a, lda, vt, ldvt ) + if( n>1 )call stdlib_${ci}$laset( 'L', n-1, n-1, czero, czero,vt( 2, 1 ), ldvt ) ! generate q in a ! (cworkspace: need 2*n, prefer n+n*nb) ! (rworkspace: 0) - call stdlib_wungqr( m, n, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib_${ci}$ungqr( m, n, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ie = 1 itauq = itau @@ -12581,17 +12583,17 @@ module stdlib_linalg_lapack_w ! bidiagonalize r in vt ! (cworkspace: need 3*n, prefer 2*n+2*n*nb) ! (rworkspace: n) - call stdlib_wgebrd( n, n, vt, ldvt, s, rwork( ie ),work( itauq ), work( & + call stdlib_${ci}$gebrd( n, n, vt, ldvt, s, rwork( ie ),work( itauq ), work( & itaup ),work( iwork ), lwork-iwork+1, ierr ) ! multiply q in a by left vectors bidiagonalizing r ! (cworkspace: need 2*n+m, prefer 2*n+m*nb) ! (rworkspace: 0) - call stdlib_wunmbr( 'Q', 'R', 'N', m, n, n, vt, ldvt,work( itauq ), a, lda,& + call stdlib_${ci}$unmbr( 'Q', 'R', 'N', m, n, n, vt, ldvt,work( itauq ), a, lda,& work( iwork ),lwork-iwork+1, ierr ) ! generate right vectors bidiagonalizing r in vt ! (cworkspace: need 3*n-1, prefer 2*n+(n-1)*nb) ! (rworkspace: 0) - call stdlib_wungbr( 'P', n, n, n, vt, ldvt, work( itaup ),work( iwork ), & + call stdlib_${ci}$ungbr( 'P', n, n, n, vt, ldvt, work( itaup ),work( iwork ), & lwork-iwork+1, ierr ) irwork = ie + n ! perform bidiagonal qr iteration, computing left @@ -12599,7 +12601,7 @@ module stdlib_linalg_lapack_w ! singular vectors of a in vt ! (cworkspace: 0) ! (rworkspace: need bdspac) - call stdlib_wbdsqr( 'U', n, n, m, 0, s, rwork( ie ), vt,ldvt, a, lda, cdum,& + call stdlib_${ci}$bdsqr( 'U', n, n, m, 0, s, rwork( ie ), vt,ldvt, a, lda, cdum,& 1, rwork( irwork ),info ) end if else if( wntus ) then @@ -12622,16 +12624,16 @@ module stdlib_linalg_lapack_w ! compute a=q*r ! (cworkspace: need n*n+2*n, prefer n*n+n+n*nb) ! (rworkspace: 0) - call stdlib_wgeqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib_${ci}$geqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ! copy r to work(ir), zeroing out below it - call stdlib_wlacpy( 'U', n, n, a, lda, work( ir ),ldwrkr ) - call stdlib_wlaset( 'L', n-1, n-1, czero, czero,work( ir+1 ), ldwrkr ) + call stdlib_${ci}$lacpy( 'U', n, n, a, lda, work( ir ),ldwrkr ) + call stdlib_${ci}$laset( 'L', n-1, n-1, czero, czero,work( ir+1 ), ldwrkr ) ! generate q in a ! (cworkspace: need n*n+2*n, prefer n*n+n+n*nb) ! (rworkspace: 0) - call stdlib_wungqr( m, n, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib_${ci}$ungqr( m, n, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ie = 1 itauq = itau @@ -12640,25 +12642,25 @@ module stdlib_linalg_lapack_w ! bidiagonalize r in work(ir) ! (cworkspace: need n*n+3*n, prefer n*n+2*n+2*n*nb) ! (rworkspace: need n) - call stdlib_wgebrd( n, n, work( ir ), ldwrkr, s,rwork( ie ), work( & + call stdlib_${ci}$gebrd( n, n, work( ir ), ldwrkr, s,rwork( ie ), work( & itauq ),work( itaup ), work( iwork ),lwork-iwork+1, ierr ) ! generate left vectors bidiagonalizing r in work(ir) ! (cworkspace: need n*n+3*n, prefer n*n+2*n+n*nb) ! (rworkspace: 0) - call stdlib_wungbr( 'Q', n, n, n, work( ir ), ldwrkr,work( itauq ), & + call stdlib_${ci}$ungbr( 'Q', n, n, n, work( ir ), ldwrkr,work( itauq ), & work( iwork ),lwork-iwork+1, ierr ) irwork = ie + n ! perform bidiagonal qr iteration, computing left ! singular vectors of r in work(ir) ! (cworkspace: need n*n) ! (rworkspace: need bdspac) - call stdlib_wbdsqr( 'U', n, 0, n, 0, s, rwork( ie ), cdum,1, work( ir ),& + call stdlib_${ci}$bdsqr( 'U', n, 0, n, 0, s, rwork( ie ), cdum,1, work( ir ),& ldwrkr, cdum, 1,rwork( irwork ), info ) ! multiply q in a by left singular vectors of r in ! work(ir), storing result in u ! (cworkspace: need n*n) ! (rworkspace: 0) - call stdlib_wgemm( 'N', 'N', m, n, n, cone, a, lda,work( ir ), ldwrkr, & + call stdlib_${ci}$gemm( 'N', 'N', m, n, n, cone, a, lda,work( ir ), ldwrkr, & czero, u, ldu ) else ! insufficient workspace for a fast algorithm @@ -12667,13 +12669,13 @@ module stdlib_linalg_lapack_w ! compute a=q*r, copying result to u ! (cworkspace: need 2*n, prefer n+n*nb) ! (rworkspace: 0) - call stdlib_wgeqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib_${ci}$geqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - call stdlib_wlacpy( 'L', m, n, a, lda, u, ldu ) + call stdlib_${ci}$lacpy( 'L', m, n, a, lda, u, ldu ) ! generate q in u ! (cworkspace: need 2*n, prefer n+n*nb) ! (rworkspace: 0) - call stdlib_wungqr( m, n, n, u, ldu, work( itau ),work( iwork ), lwork-& + call stdlib_${ci}$ungqr( m, n, n, u, ldu, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ie = 1 itauq = itau @@ -12681,25 +12683,25 @@ module stdlib_linalg_lapack_w iwork = itaup + n ! zero out below r in a if( n > 1 ) then - call stdlib_wlaset( 'L', n-1, n-1, czero, czero,a( 2, 1 ), lda ) + call stdlib_${ci}$laset( 'L', n-1, n-1, czero, czero,a( 2, 1 ), lda ) end if ! bidiagonalize r in a ! (cworkspace: need 3*n, prefer 2*n+2*n*nb) ! (rworkspace: need n) - call stdlib_wgebrd( n, n, a, lda, s, rwork( ie ),work( itauq ), work( & + call stdlib_${ci}$gebrd( n, n, a, lda, s, rwork( ie ),work( itauq ), work( & itaup ),work( iwork ), lwork-iwork+1, ierr ) ! multiply q in u by left vectors bidiagonalizing r ! (cworkspace: need 2*n+m, prefer 2*n+m*nb) ! (rworkspace: 0) - call stdlib_wunmbr( 'Q', 'R', 'N', m, n, n, a, lda,work( itauq ), u, & + call stdlib_${ci}$unmbr( 'Q', 'R', 'N', m, n, n, a, lda,work( itauq ), u, & ldu, work( iwork ),lwork-iwork+1, ierr ) irwork = ie + n ! perform bidiagonal qr iteration, computing left ! singular vectors of a in u ! (cworkspace: 0) ! (rworkspace: need bdspac) - call stdlib_wbdsqr( 'U', n, 0, m, 0, s, rwork( ie ), cdum,1, u, ldu, & + call stdlib_${ci}$bdsqr( 'U', n, 0, m, 0, s, rwork( ie ), cdum,1, u, ldu, & cdum, 1, rwork( irwork ),info ) end if else if( wntvo ) then @@ -12730,16 +12732,16 @@ module stdlib_linalg_lapack_w ! compute a=q*r ! (cworkspace: need 2*n*n+2*n, prefer 2*n*n+n+n*nb) ! (rworkspace: 0) - call stdlib_wgeqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib_${ci}$geqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ! copy r to work(iu), zeroing out below it - call stdlib_wlacpy( 'U', n, n, a, lda, work( iu ),ldwrku ) - call stdlib_wlaset( 'L', n-1, n-1, czero, czero,work( iu+1 ), ldwrku ) + call stdlib_${ci}$lacpy( 'U', n, n, a, lda, work( iu ),ldwrku ) + call stdlib_${ci}$laset( 'L', n-1, n-1, czero, czero,work( iu+1 ), ldwrku ) ! generate q in a ! (cworkspace: need 2*n*n+2*n, prefer 2*n*n+n+n*nb) ! (rworkspace: 0) - call stdlib_wungqr( m, n, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib_${ci}$ungqr( m, n, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ie = 1 itauq = itau @@ -12750,20 +12752,20 @@ module stdlib_linalg_lapack_w ! (cworkspace: need 2*n*n+3*n, ! prefer 2*n*n+2*n+2*n*nb) ! (rworkspace: need n) - call stdlib_wgebrd( n, n, work( iu ), ldwrku, s,rwork( ie ), work( & + call stdlib_${ci}$gebrd( n, n, work( iu ), ldwrku, s,rwork( ie ), work( & itauq ),work( itaup ), work( iwork ),lwork-iwork+1, ierr ) - call stdlib_wlacpy( 'U', n, n, work( iu ), ldwrku,work( ir ), ldwrkr ) + call stdlib_${ci}$lacpy( 'U', n, n, work( iu ), ldwrku,work( ir ), ldwrkr ) ! generate left bidiagonalizing vectors in work(iu) ! (cworkspace: need 2*n*n+3*n, prefer 2*n*n+2*n+n*nb) ! (rworkspace: 0) - call stdlib_wungbr( 'Q', n, n, n, work( iu ), ldwrku,work( itauq ), & + call stdlib_${ci}$ungbr( 'Q', n, n, n, work( iu ), ldwrku,work( itauq ), & work( iwork ),lwork-iwork+1, ierr ) ! generate right bidiagonalizing vectors in work(ir) ! (cworkspace: need 2*n*n+3*n-1, ! prefer 2*n*n+2*n+(n-1)*nb) ! (rworkspace: 0) - call stdlib_wungbr( 'P', n, n, n, work( ir ), ldwrkr,work( itaup ), & + call stdlib_${ci}$ungbr( 'P', n, n, n, work( ir ), ldwrkr,work( itaup ), & work( iwork ),lwork-iwork+1, ierr ) irwork = ie + n ! perform bidiagonal qr iteration, computing left @@ -12771,18 +12773,18 @@ module stdlib_linalg_lapack_w ! right singular vectors of r in work(ir) ! (cworkspace: need 2*n*n) ! (rworkspace: need bdspac) - call stdlib_wbdsqr( 'U', n, n, n, 0, s, rwork( ie ),work( ir ), ldwrkr, & + call stdlib_${ci}$bdsqr( 'U', n, n, n, 0, s, rwork( ie ),work( ir ), ldwrkr, & work( iu ),ldwrku, cdum, 1, rwork( irwork ),info ) ! multiply q in a by left singular vectors of r in ! work(iu), storing result in u ! (cworkspace: need n*n) ! (rworkspace: 0) - call stdlib_wgemm( 'N', 'N', m, n, n, cone, a, lda,work( iu ), ldwrku, & + call stdlib_${ci}$gemm( 'N', 'N', m, n, n, cone, a, lda,work( iu ), ldwrku, & czero, u, ldu ) ! copy right singular vectors of r to a ! (cworkspace: need n*n) ! (rworkspace: 0) - call stdlib_wlacpy( 'F', n, n, work( ir ), ldwrkr, a,lda ) + call stdlib_${ci}$lacpy( 'F', n, n, work( ir ), ldwrkr, a,lda ) else ! insufficient workspace for a fast algorithm itau = 1 @@ -12790,13 +12792,13 @@ module stdlib_linalg_lapack_w ! compute a=q*r, copying result to u ! (cworkspace: need 2*n, prefer n+n*nb) ! (rworkspace: 0) - call stdlib_wgeqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib_${ci}$geqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - call stdlib_wlacpy( 'L', m, n, a, lda, u, ldu ) + call stdlib_${ci}$lacpy( 'L', m, n, a, lda, u, ldu ) ! generate q in u ! (cworkspace: need 2*n, prefer n+n*nb) ! (rworkspace: 0) - call stdlib_wungqr( m, n, n, u, ldu, work( itau ),work( iwork ), lwork-& + call stdlib_${ci}$ungqr( m, n, n, u, ldu, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ie = 1 itauq = itau @@ -12804,23 +12806,23 @@ module stdlib_linalg_lapack_w iwork = itaup + n ! zero out below r in a if( n > 1 ) then - call stdlib_wlaset( 'L', n-1, n-1, czero, czero,a( 2, 1 ), lda ) + call stdlib_${ci}$laset( 'L', n-1, n-1, czero, czero,a( 2, 1 ), lda ) end if ! bidiagonalize r in a ! (cworkspace: need 3*n, prefer 2*n+2*n*nb) ! (rworkspace: need n) - call stdlib_wgebrd( n, n, a, lda, s, rwork( ie ),work( itauq ), work( & + call stdlib_${ci}$gebrd( n, n, a, lda, s, rwork( ie ),work( itauq ), work( & itaup ),work( iwork ), lwork-iwork+1, ierr ) ! multiply q in u by left vectors bidiagonalizing r ! (cworkspace: need 2*n+m, prefer 2*n+m*nb) ! (rworkspace: 0) - call stdlib_wunmbr( 'Q', 'R', 'N', m, n, n, a, lda,work( itauq ), u, & + call stdlib_${ci}$unmbr( 'Q', 'R', 'N', m, n, n, a, lda,work( itauq ), u, & ldu, work( iwork ),lwork-iwork+1, ierr ) ! generate right vectors bidiagonalizing r in a ! (cworkspace: need 3*n-1, prefer 2*n+(n-1)*nb) ! (rworkspace: 0) - call stdlib_wungbr( 'P', n, n, n, a, lda, work( itaup ),work( iwork ), & + call stdlib_${ci}$ungbr( 'P', n, n, n, a, lda, work( itaup ),work( iwork ), & lwork-iwork+1, ierr ) irwork = ie + n ! perform bidiagonal qr iteration, computing left @@ -12828,7 +12830,7 @@ module stdlib_linalg_lapack_w ! singular vectors of a in a ! (cworkspace: 0) ! (rworkspace: need bdspac) - call stdlib_wbdsqr( 'U', n, n, m, 0, s, rwork( ie ), a,lda, u, ldu, & + call stdlib_${ci}$bdsqr( 'U', n, n, m, 0, s, rwork( ie ), a,lda, u, ldu, & cdum, 1, rwork( irwork ),info ) end if else if( wntvas ) then @@ -12851,16 +12853,16 @@ module stdlib_linalg_lapack_w ! compute a=q*r ! (cworkspace: need n*n+2*n, prefer n*n+n+n*nb) ! (rworkspace: 0) - call stdlib_wgeqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib_${ci}$geqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ! copy r to work(iu), zeroing out below it - call stdlib_wlacpy( 'U', n, n, a, lda, work( iu ),ldwrku ) - call stdlib_wlaset( 'L', n-1, n-1, czero, czero,work( iu+1 ), ldwrku ) + call stdlib_${ci}$lacpy( 'U', n, n, a, lda, work( iu ),ldwrku ) + call stdlib_${ci}$laset( 'L', n-1, n-1, czero, czero,work( iu+1 ), ldwrku ) ! generate q in a ! (cworkspace: need n*n+2*n, prefer n*n+n+n*nb) ! (rworkspace: 0) - call stdlib_wungqr( m, n, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib_${ci}$ungqr( m, n, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ie = 1 itauq = itau @@ -12869,19 +12871,19 @@ module stdlib_linalg_lapack_w ! bidiagonalize r in work(iu), copying result to vt ! (cworkspace: need n*n+3*n, prefer n*n+2*n+2*n*nb) ! (rworkspace: need n) - call stdlib_wgebrd( n, n, work( iu ), ldwrku, s,rwork( ie ), work( & + call stdlib_${ci}$gebrd( n, n, work( iu ), ldwrku, s,rwork( ie ), work( & itauq ),work( itaup ), work( iwork ),lwork-iwork+1, ierr ) - call stdlib_wlacpy( 'U', n, n, work( iu ), ldwrku, vt,ldvt ) + call stdlib_${ci}$lacpy( 'U', n, n, work( iu ), ldwrku, vt,ldvt ) ! generate left bidiagonalizing vectors in work(iu) ! (cworkspace: need n*n+3*n, prefer n*n+2*n+n*nb) ! (rworkspace: 0) - call stdlib_wungbr( 'Q', n, n, n, work( iu ), ldwrku,work( itauq ), & + call stdlib_${ci}$ungbr( 'Q', n, n, n, work( iu ), ldwrku,work( itauq ), & work( iwork ),lwork-iwork+1, ierr ) ! generate right bidiagonalizing vectors in vt ! (cworkspace: need n*n+3*n-1, ! prefer n*n+2*n+(n-1)*nb) ! (rworkspace: 0) - call stdlib_wungbr( 'P', n, n, n, vt, ldvt, work( itaup ),work( iwork ),& + call stdlib_${ci}$ungbr( 'P', n, n, n, vt, ldvt, work( itaup ),work( iwork ),& lwork-iwork+1, ierr ) irwork = ie + n ! perform bidiagonal qr iteration, computing left @@ -12889,13 +12891,13 @@ module stdlib_linalg_lapack_w ! right singular vectors of r in vt ! (cworkspace: need n*n) ! (rworkspace: need bdspac) - call stdlib_wbdsqr( 'U', n, n, n, 0, s, rwork( ie ), vt,ldvt, work( iu )& + call stdlib_${ci}$bdsqr( 'U', n, n, n, 0, s, rwork( ie ), vt,ldvt, work( iu )& , ldwrku, cdum, 1,rwork( irwork ), info ) ! multiply q in a by left singular vectors of r in ! work(iu), storing result in u ! (cworkspace: need n*n) ! (rworkspace: 0) - call stdlib_wgemm( 'N', 'N', m, n, n, cone, a, lda,work( iu ), ldwrku, & + call stdlib_${ci}$gemm( 'N', 'N', m, n, n, cone, a, lda,work( iu ), ldwrku, & czero, u, ldu ) else ! insufficient workspace for a fast algorithm @@ -12904,17 +12906,17 @@ module stdlib_linalg_lapack_w ! compute a=q*r, copying result to u ! (cworkspace: need 2*n, prefer n+n*nb) ! (rworkspace: 0) - call stdlib_wgeqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib_${ci}$geqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - call stdlib_wlacpy( 'L', m, n, a, lda, u, ldu ) + call stdlib_${ci}$lacpy( 'L', m, n, a, lda, u, ldu ) ! generate q in u ! (cworkspace: need 2*n, prefer n+n*nb) ! (rworkspace: 0) - call stdlib_wungqr( m, n, n, u, ldu, work( itau ),work( iwork ), lwork-& + call stdlib_${ci}$ungqr( m, n, n, u, ldu, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ! copy r to vt, zeroing out below it - call stdlib_wlacpy( 'U', n, n, a, lda, vt, ldvt ) - if( n>1 )call stdlib_wlaset( 'L', n-1, n-1, czero, czero,vt( 2, 1 ), & + call stdlib_${ci}$lacpy( 'U', n, n, a, lda, vt, ldvt ) + if( n>1 )call stdlib_${ci}$laset( 'L', n-1, n-1, czero, czero,vt( 2, 1 ), & ldvt ) ie = 1 itauq = itau @@ -12923,18 +12925,18 @@ module stdlib_linalg_lapack_w ! bidiagonalize r in vt ! (cworkspace: need 3*n, prefer 2*n+2*n*nb) ! (rworkspace: need n) - call stdlib_wgebrd( n, n, vt, ldvt, s, rwork( ie ),work( itauq ), work( & + call stdlib_${ci}$gebrd( n, n, vt, ldvt, s, rwork( ie ),work( itauq ), work( & itaup ),work( iwork ), lwork-iwork+1, ierr ) ! multiply q in u by left bidiagonalizing vectors ! in vt ! (cworkspace: need 2*n+m, prefer 2*n+m*nb) ! (rworkspace: 0) - call stdlib_wunmbr( 'Q', 'R', 'N', m, n, n, vt, ldvt,work( itauq ), u, & + call stdlib_${ci}$unmbr( 'Q', 'R', 'N', m, n, n, vt, ldvt,work( itauq ), u, & ldu, work( iwork ),lwork-iwork+1, ierr ) ! generate right bidiagonalizing vectors in vt ! (cworkspace: need 3*n-1, prefer 2*n+(n-1)*nb) ! (rworkspace: 0) - call stdlib_wungbr( 'P', n, n, n, vt, ldvt, work( itaup ),work( iwork ),& + call stdlib_${ci}$ungbr( 'P', n, n, n, vt, ldvt, work( itaup ),work( iwork ),& lwork-iwork+1, ierr ) irwork = ie + n ! perform bidiagonal qr iteration, computing left @@ -12942,7 +12944,7 @@ module stdlib_linalg_lapack_w ! singular vectors of a in vt ! (cworkspace: 0) ! (rworkspace: need bdspac) - call stdlib_wbdsqr( 'U', n, n, m, 0, s, rwork( ie ), vt,ldvt, u, ldu, & + call stdlib_${ci}$bdsqr( 'U', n, n, m, 0, s, rwork( ie ), vt,ldvt, u, ldu, & cdum, 1,rwork( irwork ), info ) end if end if @@ -12966,17 +12968,17 @@ module stdlib_linalg_lapack_w ! compute a=q*r, copying result to u ! (cworkspace: need n*n+2*n, prefer n*n+n+n*nb) ! (rworkspace: 0) - call stdlib_wgeqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib_${ci}$geqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - call stdlib_wlacpy( 'L', m, n, a, lda, u, ldu ) + call stdlib_${ci}$lacpy( 'L', m, n, a, lda, u, ldu ) ! copy r to work(ir), zeroing out below it - call stdlib_wlacpy( 'U', n, n, a, lda, work( ir ),ldwrkr ) - call stdlib_wlaset( 'L', n-1, n-1, czero, czero,work( ir+1 ), ldwrkr ) + call stdlib_${ci}$lacpy( 'U', n, n, a, lda, work( ir ),ldwrkr ) + call stdlib_${ci}$laset( 'L', n-1, n-1, czero, czero,work( ir+1 ), ldwrkr ) ! generate q in u ! (cworkspace: need n*n+n+m, prefer n*n+n+m*nb) ! (rworkspace: 0) - call stdlib_wungqr( m, m, n, u, ldu, work( itau ),work( iwork ), lwork-& + call stdlib_${ci}$ungqr( m, m, n, u, ldu, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ie = 1 itauq = itau @@ -12985,28 +12987,28 @@ module stdlib_linalg_lapack_w ! bidiagonalize r in work(ir) ! (cworkspace: need n*n+3*n, prefer n*n+2*n+2*n*nb) ! (rworkspace: need n) - call stdlib_wgebrd( n, n, work( ir ), ldwrkr, s,rwork( ie ), work( & + call stdlib_${ci}$gebrd( n, n, work( ir ), ldwrkr, s,rwork( ie ), work( & itauq ),work( itaup ), work( iwork ),lwork-iwork+1, ierr ) ! generate left bidiagonalizing vectors in work(ir) ! (cworkspace: need n*n+3*n, prefer n*n+2*n+n*nb) ! (rworkspace: 0) - call stdlib_wungbr( 'Q', n, n, n, work( ir ), ldwrkr,work( itauq ), & + call stdlib_${ci}$ungbr( 'Q', n, n, n, work( ir ), ldwrkr,work( itauq ), & work( iwork ),lwork-iwork+1, ierr ) irwork = ie + n ! perform bidiagonal qr iteration, computing left ! singular vectors of r in work(ir) ! (cworkspace: need n*n) ! (rworkspace: need bdspac) - call stdlib_wbdsqr( 'U', n, 0, n, 0, s, rwork( ie ), cdum,1, work( ir ),& + call stdlib_${ci}$bdsqr( 'U', n, 0, n, 0, s, rwork( ie ), cdum,1, work( ir ),& ldwrkr, cdum, 1,rwork( irwork ), info ) ! multiply q in u by left singular vectors of r in ! work(ir), storing result in a ! (cworkspace: need n*n) ! (rworkspace: 0) - call stdlib_wgemm( 'N', 'N', m, n, n, cone, u, ldu,work( ir ), ldwrkr, & + call stdlib_${ci}$gemm( 'N', 'N', m, n, n, cone, u, ldu,work( ir ), ldwrkr, & czero, a, lda ) ! copy left singular vectors of a from a to u - call stdlib_wlacpy( 'F', m, n, a, lda, u, ldu ) + call stdlib_${ci}$lacpy( 'F', m, n, a, lda, u, ldu ) else ! insufficient workspace for a fast algorithm itau = 1 @@ -13014,13 +13016,13 @@ module stdlib_linalg_lapack_w ! compute a=q*r, copying result to u ! (cworkspace: need 2*n, prefer n+n*nb) ! (rworkspace: 0) - call stdlib_wgeqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib_${ci}$geqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - call stdlib_wlacpy( 'L', m, n, a, lda, u, ldu ) + call stdlib_${ci}$lacpy( 'L', m, n, a, lda, u, ldu ) ! generate q in u ! (cworkspace: need n+m, prefer n+m*nb) ! (rworkspace: 0) - call stdlib_wungqr( m, m, n, u, ldu, work( itau ),work( iwork ), lwork-& + call stdlib_${ci}$ungqr( m, m, n, u, ldu, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ie = 1 itauq = itau @@ -13028,26 +13030,26 @@ module stdlib_linalg_lapack_w iwork = itaup + n ! zero out below r in a if( n > 1 ) then - call stdlib_wlaset( 'L', n-1, n-1, czero, czero,a( 2, 1 ), lda ) + call stdlib_${ci}$laset( 'L', n-1, n-1, czero, czero,a( 2, 1 ), lda ) end if ! bidiagonalize r in a ! (cworkspace: need 3*n, prefer 2*n+2*n*nb) ! (rworkspace: need n) - call stdlib_wgebrd( n, n, a, lda, s, rwork( ie ),work( itauq ), work( & + call stdlib_${ci}$gebrd( n, n, a, lda, s, rwork( ie ),work( itauq ), work( & itaup ),work( iwork ), lwork-iwork+1, ierr ) ! multiply q in u by left bidiagonalizing vectors ! in a ! (cworkspace: need 2*n+m, prefer 2*n+m*nb) ! (rworkspace: 0) - call stdlib_wunmbr( 'Q', 'R', 'N', m, n, n, a, lda,work( itauq ), u, & + call stdlib_${ci}$unmbr( 'Q', 'R', 'N', m, n, n, a, lda,work( itauq ), u, & ldu, work( iwork ),lwork-iwork+1, ierr ) irwork = ie + n ! perform bidiagonal qr iteration, computing left ! singular vectors of a in u ! (cworkspace: 0) ! (rworkspace: need bdspac) - call stdlib_wbdsqr( 'U', n, 0, m, 0, s, rwork( ie ), cdum,1, u, ldu, & + call stdlib_${ci}$bdsqr( 'U', n, 0, m, 0, s, rwork( ie ), cdum,1, u, ldu, & cdum, 1, rwork( irwork ),info ) end if else if( wntvo ) then @@ -13078,17 +13080,17 @@ module stdlib_linalg_lapack_w ! compute a=q*r, copying result to u ! (cworkspace: need 2*n*n+2*n, prefer 2*n*n+n+n*nb) ! (rworkspace: 0) - call stdlib_wgeqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib_${ci}$geqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - call stdlib_wlacpy( 'L', m, n, a, lda, u, ldu ) + call stdlib_${ci}$lacpy( 'L', m, n, a, lda, u, ldu ) ! generate q in u ! (cworkspace: need 2*n*n+n+m, prefer 2*n*n+n+m*nb) ! (rworkspace: 0) - call stdlib_wungqr( m, m, n, u, ldu, work( itau ),work( iwork ), lwork-& + call stdlib_${ci}$ungqr( m, m, n, u, ldu, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ! copy r to work(iu), zeroing out below it - call stdlib_wlacpy( 'U', n, n, a, lda, work( iu ),ldwrku ) - call stdlib_wlaset( 'L', n-1, n-1, czero, czero,work( iu+1 ), ldwrku ) + call stdlib_${ci}$lacpy( 'U', n, n, a, lda, work( iu ),ldwrku ) + call stdlib_${ci}$laset( 'L', n-1, n-1, czero, czero,work( iu+1 ), ldwrku ) ie = 1 itauq = itau @@ -13099,20 +13101,20 @@ module stdlib_linalg_lapack_w ! (cworkspace: need 2*n*n+3*n, ! prefer 2*n*n+2*n+2*n*nb) ! (rworkspace: need n) - call stdlib_wgebrd( n, n, work( iu ), ldwrku, s,rwork( ie ), work( & + call stdlib_${ci}$gebrd( n, n, work( iu ), ldwrku, s,rwork( ie ), work( & itauq ),work( itaup ), work( iwork ),lwork-iwork+1, ierr ) - call stdlib_wlacpy( 'U', n, n, work( iu ), ldwrku,work( ir ), ldwrkr ) + call stdlib_${ci}$lacpy( 'U', n, n, work( iu ), ldwrku,work( ir ), ldwrkr ) ! generate left bidiagonalizing vectors in work(iu) ! (cworkspace: need 2*n*n+3*n, prefer 2*n*n+2*n+n*nb) ! (rworkspace: 0) - call stdlib_wungbr( 'Q', n, n, n, work( iu ), ldwrku,work( itauq ), & + call stdlib_${ci}$ungbr( 'Q', n, n, n, work( iu ), ldwrku,work( itauq ), & work( iwork ),lwork-iwork+1, ierr ) ! generate right bidiagonalizing vectors in work(ir) ! (cworkspace: need 2*n*n+3*n-1, ! prefer 2*n*n+2*n+(n-1)*nb) ! (rworkspace: 0) - call stdlib_wungbr( 'P', n, n, n, work( ir ), ldwrkr,work( itaup ), & + call stdlib_${ci}$ungbr( 'P', n, n, n, work( ir ), ldwrkr,work( itaup ), & work( iwork ),lwork-iwork+1, ierr ) irwork = ie + n ! perform bidiagonal qr iteration, computing left @@ -13120,18 +13122,18 @@ module stdlib_linalg_lapack_w ! right singular vectors of r in work(ir) ! (cworkspace: need 2*n*n) ! (rworkspace: need bdspac) - call stdlib_wbdsqr( 'U', n, n, n, 0, s, rwork( ie ),work( ir ), ldwrkr, & + call stdlib_${ci}$bdsqr( 'U', n, n, n, 0, s, rwork( ie ),work( ir ), ldwrkr, & work( iu ),ldwrku, cdum, 1, rwork( irwork ),info ) ! multiply q in u by left singular vectors of r in ! work(iu), storing result in a ! (cworkspace: need n*n) ! (rworkspace: 0) - call stdlib_wgemm( 'N', 'N', m, n, n, cone, u, ldu,work( iu ), ldwrku, & + call stdlib_${ci}$gemm( 'N', 'N', m, n, n, cone, u, ldu,work( iu ), ldwrku, & czero, a, lda ) ! copy left singular vectors of a from a to u - call stdlib_wlacpy( 'F', m, n, a, lda, u, ldu ) + call stdlib_${ci}$lacpy( 'F', m, n, a, lda, u, ldu ) ! copy right singular vectors of r from work(ir) to a - call stdlib_wlacpy( 'F', n, n, work( ir ), ldwrkr, a,lda ) + call stdlib_${ci}$lacpy( 'F', n, n, work( ir ), ldwrkr, a,lda ) else ! insufficient workspace for a fast algorithm itau = 1 @@ -13139,13 +13141,13 @@ module stdlib_linalg_lapack_w ! compute a=q*r, copying result to u ! (cworkspace: need 2*n, prefer n+n*nb) ! (rworkspace: 0) - call stdlib_wgeqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib_${ci}$geqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - call stdlib_wlacpy( 'L', m, n, a, lda, u, ldu ) + call stdlib_${ci}$lacpy( 'L', m, n, a, lda, u, ldu ) ! generate q in u ! (cworkspace: need n+m, prefer n+m*nb) ! (rworkspace: 0) - call stdlib_wungqr( m, m, n, u, ldu, work( itau ),work( iwork ), lwork-& + call stdlib_${ci}$ungqr( m, m, n, u, ldu, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ie = 1 itauq = itau @@ -13153,24 +13155,24 @@ module stdlib_linalg_lapack_w iwork = itaup + n ! zero out below r in a if( n > 1 ) then - call stdlib_wlaset( 'L', n-1, n-1, czero, czero,a( 2, 1 ), lda ) + call stdlib_${ci}$laset( 'L', n-1, n-1, czero, czero,a( 2, 1 ), lda ) end if ! bidiagonalize r in a ! (cworkspace: need 3*n, prefer 2*n+2*n*nb) ! (rworkspace: need n) - call stdlib_wgebrd( n, n, a, lda, s, rwork( ie ),work( itauq ), work( & + call stdlib_${ci}$gebrd( n, n, a, lda, s, rwork( ie ),work( itauq ), work( & itaup ),work( iwork ), lwork-iwork+1, ierr ) ! multiply q in u by left bidiagonalizing vectors ! in a ! (cworkspace: need 2*n+m, prefer 2*n+m*nb) ! (rworkspace: 0) - call stdlib_wunmbr( 'Q', 'R', 'N', m, n, n, a, lda,work( itauq ), u, & + call stdlib_${ci}$unmbr( 'Q', 'R', 'N', m, n, n, a, lda,work( itauq ), u, & ldu, work( iwork ),lwork-iwork+1, ierr ) ! generate right bidiagonalizing vectors in a ! (cworkspace: need 3*n-1, prefer 2*n+(n-1)*nb) ! (rworkspace: 0) - call stdlib_wungbr( 'P', n, n, n, a, lda, work( itaup ),work( iwork ), & + call stdlib_${ci}$ungbr( 'P', n, n, n, a, lda, work( itaup ),work( iwork ), & lwork-iwork+1, ierr ) irwork = ie + n ! perform bidiagonal qr iteration, computing left @@ -13178,7 +13180,7 @@ module stdlib_linalg_lapack_w ! singular vectors of a in a ! (cworkspace: 0) ! (rworkspace: need bdspac) - call stdlib_wbdsqr( 'U', n, n, m, 0, s, rwork( ie ), a,lda, u, ldu, & + call stdlib_${ci}$bdsqr( 'U', n, n, m, 0, s, rwork( ie ), a,lda, u, ldu, & cdum, 1, rwork( irwork ),info ) end if else if( wntvas ) then @@ -13201,17 +13203,17 @@ module stdlib_linalg_lapack_w ! compute a=q*r, copying result to u ! (cworkspace: need n*n+2*n, prefer n*n+n+n*nb) ! (rworkspace: 0) - call stdlib_wgeqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib_${ci}$geqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - call stdlib_wlacpy( 'L', m, n, a, lda, u, ldu ) + call stdlib_${ci}$lacpy( 'L', m, n, a, lda, u, ldu ) ! generate q in u ! (cworkspace: need n*n+n+m, prefer n*n+n+m*nb) ! (rworkspace: 0) - call stdlib_wungqr( m, m, n, u, ldu, work( itau ),work( iwork ), lwork-& + call stdlib_${ci}$ungqr( m, m, n, u, ldu, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ! copy r to work(iu), zeroing out below it - call stdlib_wlacpy( 'U', n, n, a, lda, work( iu ),ldwrku ) - call stdlib_wlaset( 'L', n-1, n-1, czero, czero,work( iu+1 ), ldwrku ) + call stdlib_${ci}$lacpy( 'U', n, n, a, lda, work( iu ),ldwrku ) + call stdlib_${ci}$laset( 'L', n-1, n-1, czero, czero,work( iu+1 ), ldwrku ) ie = 1 itauq = itau @@ -13220,19 +13222,19 @@ module stdlib_linalg_lapack_w ! bidiagonalize r in work(iu), copying result to vt ! (cworkspace: need n*n+3*n, prefer n*n+2*n+2*n*nb) ! (rworkspace: need n) - call stdlib_wgebrd( n, n, work( iu ), ldwrku, s,rwork( ie ), work( & + call stdlib_${ci}$gebrd( n, n, work( iu ), ldwrku, s,rwork( ie ), work( & itauq ),work( itaup ), work( iwork ),lwork-iwork+1, ierr ) - call stdlib_wlacpy( 'U', n, n, work( iu ), ldwrku, vt,ldvt ) + call stdlib_${ci}$lacpy( 'U', n, n, work( iu ), ldwrku, vt,ldvt ) ! generate left bidiagonalizing vectors in work(iu) ! (cworkspace: need n*n+3*n, prefer n*n+2*n+n*nb) ! (rworkspace: 0) - call stdlib_wungbr( 'Q', n, n, n, work( iu ), ldwrku,work( itauq ), & + call stdlib_${ci}$ungbr( 'Q', n, n, n, work( iu ), ldwrku,work( itauq ), & work( iwork ),lwork-iwork+1, ierr ) ! generate right bidiagonalizing vectors in vt ! (cworkspace: need n*n+3*n-1, ! prefer n*n+2*n+(n-1)*nb) ! (rworkspace: need 0) - call stdlib_wungbr( 'P', n, n, n, vt, ldvt, work( itaup ),work( iwork ),& + call stdlib_${ci}$ungbr( 'P', n, n, n, vt, ldvt, work( itaup ),work( iwork ),& lwork-iwork+1, ierr ) irwork = ie + n ! perform bidiagonal qr iteration, computing left @@ -13240,16 +13242,16 @@ module stdlib_linalg_lapack_w ! right singular vectors of r in vt ! (cworkspace: need n*n) ! (rworkspace: need bdspac) - call stdlib_wbdsqr( 'U', n, n, n, 0, s, rwork( ie ), vt,ldvt, work( iu )& + call stdlib_${ci}$bdsqr( 'U', n, n, n, 0, s, rwork( ie ), vt,ldvt, work( iu )& , ldwrku, cdum, 1,rwork( irwork ), info ) ! multiply q in u by left singular vectors of r in ! work(iu), storing result in a ! (cworkspace: need n*n) ! (rworkspace: 0) - call stdlib_wgemm( 'N', 'N', m, n, n, cone, u, ldu,work( iu ), ldwrku, & + call stdlib_${ci}$gemm( 'N', 'N', m, n, n, cone, u, ldu,work( iu ), ldwrku, & czero, a, lda ) ! copy left singular vectors of a from a to u - call stdlib_wlacpy( 'F', m, n, a, lda, u, ldu ) + call stdlib_${ci}$lacpy( 'F', m, n, a, lda, u, ldu ) else ! insufficient workspace for a fast algorithm itau = 1 @@ -13257,17 +13259,17 @@ module stdlib_linalg_lapack_w ! compute a=q*r, copying result to u ! (cworkspace: need 2*n, prefer n+n*nb) ! (rworkspace: 0) - call stdlib_wgeqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib_${ci}$geqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - call stdlib_wlacpy( 'L', m, n, a, lda, u, ldu ) + call stdlib_${ci}$lacpy( 'L', m, n, a, lda, u, ldu ) ! generate q in u ! (cworkspace: need n+m, prefer n+m*nb) ! (rworkspace: 0) - call stdlib_wungqr( m, m, n, u, ldu, work( itau ),work( iwork ), lwork-& + call stdlib_${ci}$ungqr( m, m, n, u, ldu, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ! copy r from a to vt, zeroing out below it - call stdlib_wlacpy( 'U', n, n, a, lda, vt, ldvt ) - if( n>1 )call stdlib_wlaset( 'L', n-1, n-1, czero, czero,vt( 2, 1 ), & + call stdlib_${ci}$lacpy( 'U', n, n, a, lda, vt, ldvt ) + if( n>1 )call stdlib_${ci}$laset( 'L', n-1, n-1, czero, czero,vt( 2, 1 ), & ldvt ) ie = 1 itauq = itau @@ -13276,18 +13278,18 @@ module stdlib_linalg_lapack_w ! bidiagonalize r in vt ! (cworkspace: need 3*n, prefer 2*n+2*n*nb) ! (rworkspace: need n) - call stdlib_wgebrd( n, n, vt, ldvt, s, rwork( ie ),work( itauq ), work( & + call stdlib_${ci}$gebrd( n, n, vt, ldvt, s, rwork( ie ),work( itauq ), work( & itaup ),work( iwork ), lwork-iwork+1, ierr ) ! multiply q in u by left bidiagonalizing vectors ! in vt ! (cworkspace: need 2*n+m, prefer 2*n+m*nb) ! (rworkspace: 0) - call stdlib_wunmbr( 'Q', 'R', 'N', m, n, n, vt, ldvt,work( itauq ), u, & + call stdlib_${ci}$unmbr( 'Q', 'R', 'N', m, n, n, vt, ldvt,work( itauq ), u, & ldu, work( iwork ),lwork-iwork+1, ierr ) ! generate right bidiagonalizing vectors in vt ! (cworkspace: need 3*n-1, prefer 2*n+(n-1)*nb) ! (rworkspace: 0) - call stdlib_wungbr( 'P', n, n, n, vt, ldvt, work( itaup ),work( iwork ),& + call stdlib_${ci}$ungbr( 'P', n, n, n, vt, ldvt, work( itaup ),work( iwork ),& lwork-iwork+1, ierr ) irwork = ie + n ! perform bidiagonal qr iteration, computing left @@ -13295,7 +13297,7 @@ module stdlib_linalg_lapack_w ! singular vectors of a in vt ! (cworkspace: 0) ! (rworkspace: need bdspac) - call stdlib_wbdsqr( 'U', n, n, m, 0, s, rwork( ie ), vt,ldvt, u, ldu, & + call stdlib_${ci}$bdsqr( 'U', n, n, m, 0, s, rwork( ie ), vt,ldvt, u, ldu, & cdum, 1,rwork( irwork ), info ) end if end if @@ -13311,17 +13313,17 @@ module stdlib_linalg_lapack_w ! bidiagonalize a ! (cworkspace: need 2*n+m, prefer 2*n+(m+n)*nb) ! (rworkspace: need n) - call stdlib_wgebrd( m, n, a, lda, s, rwork( ie ), work( itauq ),work( itaup ), & + call stdlib_${ci}$gebrd( m, n, a, lda, s, rwork( ie ), work( itauq ),work( itaup ), & work( iwork ), lwork-iwork+1,ierr ) if( wntuas ) then ! if left singular vectors desired in u, copy result to u ! and generate left bidiagonalizing vectors in u ! (cworkspace: need 2*n+ncu, prefer 2*n+ncu*nb) ! (rworkspace: 0) - call stdlib_wlacpy( 'L', m, n, a, lda, u, ldu ) + call stdlib_${ci}$lacpy( 'L', m, n, a, lda, u, ldu ) if( wntus )ncu = n if( wntua )ncu = m - call stdlib_wungbr( 'Q', m, ncu, n, u, ldu, work( itauq ),work( iwork ), & + call stdlib_${ci}$ungbr( 'Q', m, ncu, n, u, ldu, work( itauq ),work( iwork ), & lwork-iwork+1, ierr ) end if if( wntvas ) then @@ -13329,8 +13331,8 @@ module stdlib_linalg_lapack_w ! vt and generate right bidiagonalizing vectors in vt ! (cworkspace: need 3*n-1, prefer 2*n+(n-1)*nb) ! (rworkspace: 0) - call stdlib_wlacpy( 'U', n, n, a, lda, vt, ldvt ) - call stdlib_wungbr( 'P', n, n, n, vt, ldvt, work( itaup ),work( iwork ), & + call stdlib_${ci}$lacpy( 'U', n, n, a, lda, vt, ldvt ) + call stdlib_${ci}$ungbr( 'P', n, n, n, vt, ldvt, work( itaup ),work( iwork ), & lwork-iwork+1, ierr ) end if if( wntuo ) then @@ -13338,7 +13340,7 @@ module stdlib_linalg_lapack_w ! bidiagonalizing vectors in a ! (cworkspace: need 3*n, prefer 2*n+n*nb) ! (rworkspace: 0) - call stdlib_wungbr( 'Q', m, n, n, a, lda, work( itauq ),work( iwork ), lwork-& + call stdlib_${ci}$ungbr( 'Q', m, n, n, a, lda, work( itauq ),work( iwork ), lwork-& iwork+1, ierr ) end if if( wntvo ) then @@ -13346,7 +13348,7 @@ module stdlib_linalg_lapack_w ! bidiagonalizing vectors in a ! (cworkspace: need 3*n-1, prefer 2*n+(n-1)*nb) ! (rworkspace: 0) - call stdlib_wungbr( 'P', n, n, n, a, lda, work( itaup ),work( iwork ), lwork-& + call stdlib_${ci}$ungbr( 'P', n, n, n, a, lda, work( itaup ),work( iwork ), lwork-& iwork+1, ierr ) end if irwork = ie + n @@ -13360,7 +13362,7 @@ module stdlib_linalg_lapack_w ! vectors in vt ! (cworkspace: 0) ! (rworkspace: need bdspac) - call stdlib_wbdsqr( 'U', n, ncvt, nru, 0, s, rwork( ie ), vt,ldvt, u, ldu, & + call stdlib_${ci}$bdsqr( 'U', n, ncvt, nru, 0, s, rwork( ie ), vt,ldvt, u, ldu, & cdum, 1, rwork( irwork ),info ) else if( ( .not.wntuo ) .and. wntvo ) then ! perform bidiagonal qr iteration, if desired, computing @@ -13368,7 +13370,7 @@ module stdlib_linalg_lapack_w ! vectors in a ! (cworkspace: 0) ! (rworkspace: need bdspac) - call stdlib_wbdsqr( 'U', n, ncvt, nru, 0, s, rwork( ie ), a,lda, u, ldu, cdum,& + call stdlib_${ci}$bdsqr( 'U', n, ncvt, nru, 0, s, rwork( ie ), a,lda, u, ldu, cdum,& 1, rwork( irwork ),info ) else ! perform bidiagonal qr iteration, if desired, computing @@ -13376,7 +13378,7 @@ module stdlib_linalg_lapack_w ! vectors in vt ! (cworkspace: 0) ! (rworkspace: need bdspac) - call stdlib_wbdsqr( 'U', n, ncvt, nru, 0, s, rwork( ie ), vt,ldvt, a, lda, & + call stdlib_${ci}$bdsqr( 'U', n, ncvt, nru, 0, s, rwork( ie ), vt,ldvt, a, lda, & cdum, 1, rwork( irwork ),info ) end if end if @@ -13393,10 +13395,10 @@ module stdlib_linalg_lapack_w ! compute a=l*q ! (cworkspace: need 2*m, prefer m+m*nb) ! (rworkspace: 0) - call stdlib_wgelqf( m, n, a, lda, work( itau ), work( iwork ),lwork-iwork+1, & + call stdlib_${ci}$gelqf( m, n, a, lda, work( itau ), work( iwork ),lwork-iwork+1, & ierr ) ! zero out above l - if (m>1) call stdlib_wlaset( 'U', m-1, m-1, czero, czero, a( 1, 2 ),lda ) + if (m>1) call stdlib_${ci}$laset( 'U', m-1, m-1, czero, czero, a( 1, 2 ),lda ) ie = 1 itauq = 1 itaup = itauq + m @@ -13404,13 +13406,13 @@ module stdlib_linalg_lapack_w ! bidiagonalize l in a ! (cworkspace: need 3*m, prefer 2*m+2*m*nb) ! (rworkspace: need m) - call stdlib_wgebrd( m, m, a, lda, s, rwork( ie ), work( itauq ),work( itaup ),& + call stdlib_${ci}$gebrd( m, m, a, lda, s, rwork( ie ), work( itauq ),work( itaup ),& work( iwork ), lwork-iwork+1,ierr ) if( wntuo .or. wntuas ) then ! if left singular vectors desired, generate q ! (cworkspace: need 3*m, prefer 2*m+m*nb) ! (rworkspace: 0) - call stdlib_wungbr( 'Q', m, m, m, a, lda, work( itauq ),work( iwork ), & + call stdlib_${ci}$ungbr( 'Q', m, m, m, a, lda, work( itauq ),work( iwork ), & lwork-iwork+1, ierr ) end if irwork = ie + m @@ -13420,10 +13422,10 @@ module stdlib_linalg_lapack_w ! vectors of a in a if desired ! (cworkspace: 0) ! (rworkspace: need bdspac) - call stdlib_wbdsqr( 'U', m, 0, nru, 0, s, rwork( ie ), cdum, 1,a, lda, cdum, & + call stdlib_${ci}$bdsqr( 'U', m, 0, nru, 0, s, rwork( ie ), cdum, 1,a, lda, cdum, & 1, rwork( irwork ), info ) ! if left singular vectors desired in u, copy them there - if( wntuas )call stdlib_wlacpy( 'F', m, m, a, lda, u, ldu ) + if( wntuas )call stdlib_${ci}$lacpy( 'F', m, m, a, lda, u, ldu ) else if( wntvo .and. wntun ) then ! path 2t(n much larger than m, jobu='n', jobvt='o') ! m right singular vectors to be overwritten on a and @@ -13452,16 +13454,16 @@ module stdlib_linalg_lapack_w ! compute a=l*q ! (cworkspace: need m*m+2*m, prefer m*m+m+m*nb) ! (rworkspace: 0) - call stdlib_wgelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-iwork+& + call stdlib_${ci}$gelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-iwork+& 1, ierr ) ! copy l to work(ir) and zero out above it - call stdlib_wlacpy( 'L', m, m, a, lda, work( ir ), ldwrkr ) - call stdlib_wlaset( 'U', m-1, m-1, czero, czero,work( ir+ldwrkr ), ldwrkr ) + call stdlib_${ci}$lacpy( 'L', m, m, a, lda, work( ir ), ldwrkr ) + call stdlib_${ci}$laset( 'U', m-1, m-1, czero, czero,work( ir+ldwrkr ), ldwrkr ) ! generate q in a ! (cworkspace: need m*m+2*m, prefer m*m+m+m*nb) ! (rworkspace: 0) - call stdlib_wunglq( m, n, m, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib_${ci}$unglq( m, n, m, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ie = 1 itauq = itau @@ -13470,19 +13472,19 @@ module stdlib_linalg_lapack_w ! bidiagonalize l in work(ir) ! (cworkspace: need m*m+3*m, prefer m*m+2*m+2*m*nb) ! (rworkspace: need m) - call stdlib_wgebrd( m, m, work( ir ), ldwrkr, s, rwork( ie ),work( itauq ),& + call stdlib_${ci}$gebrd( m, m, work( ir ), ldwrkr, s, rwork( ie ),work( itauq ),& work( itaup ),work( iwork ), lwork-iwork+1, ierr ) ! generate right vectors bidiagonalizing l ! (cworkspace: need m*m+3*m-1, prefer m*m+2*m+(m-1)*nb) ! (rworkspace: 0) - call stdlib_wungbr( 'P', m, m, m, work( ir ), ldwrkr,work( itaup ), work( & + call stdlib_${ci}$ungbr( 'P', m, m, m, work( ir ), ldwrkr,work( itaup ), work( & iwork ),lwork-iwork+1, ierr ) irwork = ie + m ! perform bidiagonal qr iteration, computing right ! singular vectors of l in work(ir) ! (cworkspace: need m*m) ! (rworkspace: need bdspac) - call stdlib_wbdsqr( 'U', m, m, 0, 0, s, rwork( ie ),work( ir ), ldwrkr, & + call stdlib_${ci}$bdsqr( 'U', m, m, 0, 0, s, rwork( ie ),work( ir ), ldwrkr, & cdum, 1, cdum, 1,rwork( irwork ), info ) iu = itauq ! multiply right singular vectors of l in work(ir) by q @@ -13491,9 +13493,9 @@ module stdlib_linalg_lapack_w ! (rworkspace: 0) do i = 1, n, chunk blk = min( n-i+1, chunk ) - call stdlib_wgemm( 'N', 'N', m, blk, m, cone, work( ir ),ldwrkr, a( 1, & + call stdlib_${ci}$gemm( 'N', 'N', m, blk, m, cone, work( ir ),ldwrkr, a( 1, & i ), lda, czero,work( iu ), ldwrku ) - call stdlib_wlacpy( 'F', m, blk, work( iu ), ldwrku,a( 1, i ), lda ) + call stdlib_${ci}$lacpy( 'F', m, blk, work( iu ), ldwrku,a( 1, i ), lda ) end do else @@ -13505,19 +13507,19 @@ module stdlib_linalg_lapack_w ! bidiagonalize a ! (cworkspace: need 2*m+n, prefer 2*m+(m+n)*nb) ! (rworkspace: need m) - call stdlib_wgebrd( m, n, a, lda, s, rwork( ie ),work( itauq ), work( & + call stdlib_${ci}$gebrd( m, n, a, lda, s, rwork( ie ),work( itauq ), work( & itaup ),work( iwork ), lwork-iwork+1, ierr ) ! generate right vectors bidiagonalizing a ! (cworkspace: need 3*m, prefer 2*m+m*nb) ! (rworkspace: 0) - call stdlib_wungbr( 'P', m, n, m, a, lda, work( itaup ),work( iwork ), & + call stdlib_${ci}$ungbr( 'P', m, n, m, a, lda, work( itaup ),work( iwork ), & lwork-iwork+1, ierr ) irwork = ie + m ! perform bidiagonal qr iteration, computing right ! singular vectors of a in a ! (cworkspace: 0) ! (rworkspace: need bdspac) - call stdlib_wbdsqr( 'L', m, n, 0, 0, s, rwork( ie ), a, lda,cdum, 1, cdum, & + call stdlib_${ci}$bdsqr( 'L', m, n, 0, 0, s, rwork( ie ), a, lda,cdum, 1, cdum, & 1, rwork( irwork ), info ) end if else if( wntvo .and. wntuas ) then @@ -13548,15 +13550,15 @@ module stdlib_linalg_lapack_w ! compute a=l*q ! (cworkspace: need m*m+2*m, prefer m*m+m+m*nb) ! (rworkspace: 0) - call stdlib_wgelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-iwork+& + call stdlib_${ci}$gelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-iwork+& 1, ierr ) ! copy l to u, zeroing about above it - call stdlib_wlacpy( 'L', m, m, a, lda, u, ldu ) - if (m>1) call stdlib_wlaset( 'U', m-1, m-1, czero, czero, u( 1, 2 ),ldu ) + call stdlib_${ci}$lacpy( 'L', m, m, a, lda, u, ldu ) + if (m>1) call stdlib_${ci}$laset( 'U', m-1, m-1, czero, czero, u( 1, 2 ),ldu ) ! generate q in a ! (cworkspace: need m*m+2*m, prefer m*m+m+m*nb) ! (rworkspace: 0) - call stdlib_wunglq( m, n, m, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib_${ci}$unglq( m, n, m, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ie = 1 itauq = itau @@ -13565,18 +13567,18 @@ module stdlib_linalg_lapack_w ! bidiagonalize l in u, copying result to work(ir) ! (cworkspace: need m*m+3*m, prefer m*m+2*m+2*m*nb) ! (rworkspace: need m) - call stdlib_wgebrd( m, m, u, ldu, s, rwork( ie ),work( itauq ), work( & + call stdlib_${ci}$gebrd( m, m, u, ldu, s, rwork( ie ),work( itauq ), work( & itaup ),work( iwork ), lwork-iwork+1, ierr ) - call stdlib_wlacpy( 'U', m, m, u, ldu, work( ir ), ldwrkr ) + call stdlib_${ci}$lacpy( 'U', m, m, u, ldu, work( ir ), ldwrkr ) ! generate right vectors bidiagonalizing l in work(ir) ! (cworkspace: need m*m+3*m-1, prefer m*m+2*m+(m-1)*nb) ! (rworkspace: 0) - call stdlib_wungbr( 'P', m, m, m, work( ir ), ldwrkr,work( itaup ), work( & + call stdlib_${ci}$ungbr( 'P', m, m, m, work( ir ), ldwrkr,work( itaup ), work( & iwork ),lwork-iwork+1, ierr ) ! generate left vectors bidiagonalizing l in u ! (cworkspace: need m*m+3*m, prefer m*m+2*m+m*nb) ! (rworkspace: 0) - call stdlib_wungbr( 'Q', m, m, m, u, ldu, work( itauq ),work( iwork ), & + call stdlib_${ci}$ungbr( 'Q', m, m, m, u, ldu, work( itauq ),work( iwork ), & lwork-iwork+1, ierr ) irwork = ie + m ! perform bidiagonal qr iteration, computing left @@ -13584,7 +13586,7 @@ module stdlib_linalg_lapack_w ! singular vectors of l in work(ir) ! (cworkspace: need m*m) ! (rworkspace: need bdspac) - call stdlib_wbdsqr( 'U', m, m, m, 0, s, rwork( ie ),work( ir ), ldwrkr, u, & + call stdlib_${ci}$bdsqr( 'U', m, m, m, 0, s, rwork( ie ),work( ir ), ldwrkr, u, & ldu, cdum, 1,rwork( irwork ), info ) iu = itauq ! multiply right singular vectors of l in work(ir) by q @@ -13593,9 +13595,9 @@ module stdlib_linalg_lapack_w ! (rworkspace: 0) do i = 1, n, chunk blk = min( n-i+1, chunk ) - call stdlib_wgemm( 'N', 'N', m, blk, m, cone, work( ir ),ldwrkr, a( 1, & + call stdlib_${ci}$gemm( 'N', 'N', m, blk, m, cone, work( ir ),ldwrkr, a( 1, & i ), lda, czero,work( iu ), ldwrku ) - call stdlib_wlacpy( 'F', m, blk, work( iu ), ldwrku,a( 1, i ), lda ) + call stdlib_${ci}$lacpy( 'F', m, blk, work( iu ), ldwrku,a( 1, i ), lda ) end do else @@ -13605,15 +13607,15 @@ module stdlib_linalg_lapack_w ! compute a=l*q ! (cworkspace: need 2*m, prefer m+m*nb) ! (rworkspace: 0) - call stdlib_wgelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-iwork+& + call stdlib_${ci}$gelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-iwork+& 1, ierr ) ! copy l to u, zeroing out above it - call stdlib_wlacpy( 'L', m, m, a, lda, u, ldu ) - if (m>1) call stdlib_wlaset( 'U', m-1, m-1, czero, czero, u( 1, 2 ),ldu ) + call stdlib_${ci}$lacpy( 'L', m, m, a, lda, u, ldu ) + if (m>1) call stdlib_${ci}$laset( 'U', m-1, m-1, czero, czero, u( 1, 2 ),ldu ) ! generate q in a ! (cworkspace: need 2*m, prefer m+m*nb) ! (rworkspace: 0) - call stdlib_wunglq( m, n, m, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib_${ci}$unglq( m, n, m, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ie = 1 itauq = itau @@ -13622,17 +13624,17 @@ module stdlib_linalg_lapack_w ! bidiagonalize l in u ! (cworkspace: need 3*m, prefer 2*m+2*m*nb) ! (rworkspace: need m) - call stdlib_wgebrd( m, m, u, ldu, s, rwork( ie ),work( itauq ), work( & + call stdlib_${ci}$gebrd( m, m, u, ldu, s, rwork( ie ),work( itauq ), work( & itaup ),work( iwork ), lwork-iwork+1, ierr ) ! multiply right vectors bidiagonalizing l by q in a ! (cworkspace: need 2*m+n, prefer 2*m+n*nb) ! (rworkspace: 0) - call stdlib_wunmbr( 'P', 'L', 'C', m, n, m, u, ldu,work( itaup ), a, lda, & + call stdlib_${ci}$unmbr( 'P', 'L', 'C', m, n, m, u, ldu,work( itaup ), a, lda, & work( iwork ),lwork-iwork+1, ierr ) ! generate left vectors bidiagonalizing l in u ! (cworkspace: need 3*m, prefer 2*m+m*nb) ! (rworkspace: 0) - call stdlib_wungbr( 'Q', m, m, m, u, ldu, work( itauq ),work( iwork ), & + call stdlib_${ci}$ungbr( 'Q', m, m, m, u, ldu, work( itauq ),work( iwork ), & lwork-iwork+1, ierr ) irwork = ie + m ! perform bidiagonal qr iteration, computing left @@ -13640,7 +13642,7 @@ module stdlib_linalg_lapack_w ! singular vectors of a in a ! (cworkspace: 0) ! (rworkspace: need bdspac) - call stdlib_wbdsqr( 'U', m, n, m, 0, s, rwork( ie ), a, lda,u, ldu, cdum, & + call stdlib_${ci}$bdsqr( 'U', m, n, m, 0, s, rwork( ie ), a, lda,u, ldu, cdum, & 1, rwork( irwork ), info ) end if else if( wntvs ) then @@ -13663,16 +13665,16 @@ module stdlib_linalg_lapack_w ! compute a=l*q ! (cworkspace: need m*m+2*m, prefer m*m+m+m*nb) ! (rworkspace: 0) - call stdlib_wgelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib_${ci}$gelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ! copy l to work(ir), zeroing out above it - call stdlib_wlacpy( 'L', m, m, a, lda, work( ir ),ldwrkr ) - call stdlib_wlaset( 'U', m-1, m-1, czero, czero,work( ir+ldwrkr ), & + call stdlib_${ci}$lacpy( 'L', m, m, a, lda, work( ir ),ldwrkr ) + call stdlib_${ci}$laset( 'U', m-1, m-1, czero, czero,work( ir+ldwrkr ), & ldwrkr ) ! generate q in a ! (cworkspace: need m*m+2*m, prefer m*m+m+m*nb) ! (rworkspace: 0) - call stdlib_wunglq( m, n, m, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib_${ci}$unglq( m, n, m, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ie = 1 itauq = itau @@ -13681,26 +13683,26 @@ module stdlib_linalg_lapack_w ! bidiagonalize l in work(ir) ! (cworkspace: need m*m+3*m, prefer m*m+2*m+2*m*nb) ! (rworkspace: need m) - call stdlib_wgebrd( m, m, work( ir ), ldwrkr, s,rwork( ie ), work( & + call stdlib_${ci}$gebrd( m, m, work( ir ), ldwrkr, s,rwork( ie ), work( & itauq ),work( itaup ), work( iwork ),lwork-iwork+1, ierr ) ! generate right vectors bidiagonalizing l in ! work(ir) ! (cworkspace: need m*m+3*m, prefer m*m+2*m+(m-1)*nb) ! (rworkspace: 0) - call stdlib_wungbr( 'P', m, m, m, work( ir ), ldwrkr,work( itaup ), & + call stdlib_${ci}$ungbr( 'P', m, m, m, work( ir ), ldwrkr,work( itaup ), & work( iwork ),lwork-iwork+1, ierr ) irwork = ie + m ! perform bidiagonal qr iteration, computing right ! singular vectors of l in work(ir) ! (cworkspace: need m*m) ! (rworkspace: need bdspac) - call stdlib_wbdsqr( 'U', m, m, 0, 0, s, rwork( ie ),work( ir ), ldwrkr, & + call stdlib_${ci}$bdsqr( 'U', m, m, 0, 0, s, rwork( ie ),work( ir ), ldwrkr, & cdum, 1, cdum, 1,rwork( irwork ), info ) ! multiply right singular vectors of l in work(ir) by ! q in a, storing result in vt ! (cworkspace: need m*m) ! (rworkspace: 0) - call stdlib_wgemm( 'N', 'N', m, n, m, cone, work( ir ),ldwrkr, a, lda, & + call stdlib_${ci}$gemm( 'N', 'N', m, n, m, cone, work( ir ),ldwrkr, a, lda, & czero, vt, ldvt ) else ! insufficient workspace for a fast algorithm @@ -13709,37 +13711,37 @@ module stdlib_linalg_lapack_w ! compute a=l*q ! (cworkspace: need 2*m, prefer m+m*nb) ! (rworkspace: 0) - call stdlib_wgelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib_${ci}$gelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ! copy result to vt - call stdlib_wlacpy( 'U', m, n, a, lda, vt, ldvt ) + call stdlib_${ci}$lacpy( 'U', m, n, a, lda, vt, ldvt ) ! generate q in vt ! (cworkspace: need 2*m, prefer m+m*nb) ! (rworkspace: 0) - call stdlib_wunglq( m, n, m, vt, ldvt, work( itau ),work( iwork ), & + call stdlib_${ci}$unglq( m, n, m, vt, ldvt, work( itau ),work( iwork ), & lwork-iwork+1, ierr ) ie = 1 itauq = itau itaup = itauq + m iwork = itaup + m ! zero out above l in a - if (m>1) call stdlib_wlaset( 'U', m-1, m-1, czero, czero,a( 1, 2 ), lda ) + if (m>1) call stdlib_${ci}$laset( 'U', m-1, m-1, czero, czero,a( 1, 2 ), lda ) ! bidiagonalize l in a ! (cworkspace: need 3*m, prefer 2*m+2*m*nb) ! (rworkspace: need m) - call stdlib_wgebrd( m, m, a, lda, s, rwork( ie ),work( itauq ), work( & + call stdlib_${ci}$gebrd( m, m, a, lda, s, rwork( ie ),work( itauq ), work( & itaup ),work( iwork ), lwork-iwork+1, ierr ) ! multiply right vectors bidiagonalizing l by q in vt ! (cworkspace: need 2*m+n, prefer 2*m+n*nb) ! (rworkspace: 0) - call stdlib_wunmbr( 'P', 'L', 'C', m, n, m, a, lda,work( itaup ), vt, & + call stdlib_${ci}$unmbr( 'P', 'L', 'C', m, n, m, a, lda,work( itaup ), vt, & ldvt,work( iwork ), lwork-iwork+1, ierr ) irwork = ie + m ! perform bidiagonal qr iteration, computing right ! singular vectors of a in vt ! (cworkspace: 0) ! (rworkspace: need bdspac) - call stdlib_wbdsqr( 'U', m, n, 0, 0, s, rwork( ie ), vt,ldvt, cdum, 1, & + call stdlib_${ci}$bdsqr( 'U', m, n, 0, 0, s, rwork( ie ), vt,ldvt, cdum, 1, & cdum, 1,rwork( irwork ), info ) end if else if( wntuo ) then @@ -13770,16 +13772,16 @@ module stdlib_linalg_lapack_w ! compute a=l*q ! (cworkspace: need 2*m*m+2*m, prefer 2*m*m+m+m*nb) ! (rworkspace: 0) - call stdlib_wgelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib_${ci}$gelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ! copy l to work(iu), zeroing out below it - call stdlib_wlacpy( 'L', m, m, a, lda, work( iu ),ldwrku ) - call stdlib_wlaset( 'U', m-1, m-1, czero, czero,work( iu+ldwrku ), & + call stdlib_${ci}$lacpy( 'L', m, m, a, lda, work( iu ),ldwrku ) + call stdlib_${ci}$laset( 'U', m-1, m-1, czero, czero,work( iu+ldwrku ), & ldwrku ) ! generate q in a ! (cworkspace: need 2*m*m+2*m, prefer 2*m*m+m+m*nb) ! (rworkspace: 0) - call stdlib_wunglq( m, n, m, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib_${ci}$unglq( m, n, m, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ie = 1 itauq = itau @@ -13790,20 +13792,20 @@ module stdlib_linalg_lapack_w ! (cworkspace: need 2*m*m+3*m, ! prefer 2*m*m+2*m+2*m*nb) ! (rworkspace: need m) - call stdlib_wgebrd( m, m, work( iu ), ldwrku, s,rwork( ie ), work( & + call stdlib_${ci}$gebrd( m, m, work( iu ), ldwrku, s,rwork( ie ), work( & itauq ),work( itaup ), work( iwork ),lwork-iwork+1, ierr ) - call stdlib_wlacpy( 'L', m, m, work( iu ), ldwrku,work( ir ), ldwrkr ) + call stdlib_${ci}$lacpy( 'L', m, m, work( iu ), ldwrku,work( ir ), ldwrkr ) ! generate right bidiagonalizing vectors in work(iu) ! (cworkspace: need 2*m*m+3*m-1, ! prefer 2*m*m+2*m+(m-1)*nb) ! (rworkspace: 0) - call stdlib_wungbr( 'P', m, m, m, work( iu ), ldwrku,work( itaup ), & + call stdlib_${ci}$ungbr( 'P', m, m, m, work( iu ), ldwrku,work( itaup ), & work( iwork ),lwork-iwork+1, ierr ) ! generate left bidiagonalizing vectors in work(ir) ! (cworkspace: need 2*m*m+3*m, prefer 2*m*m+2*m+m*nb) ! (rworkspace: 0) - call stdlib_wungbr( 'Q', m, m, m, work( ir ), ldwrkr,work( itauq ), & + call stdlib_${ci}$ungbr( 'Q', m, m, m, work( ir ), ldwrkr,work( itauq ), & work( iwork ),lwork-iwork+1, ierr ) irwork = ie + m ! perform bidiagonal qr iteration, computing left @@ -13811,18 +13813,18 @@ module stdlib_linalg_lapack_w ! right singular vectors of l in work(iu) ! (cworkspace: need 2*m*m) ! (rworkspace: need bdspac) - call stdlib_wbdsqr( 'U', m, m, m, 0, s, rwork( ie ),work( iu ), ldwrku, & + call stdlib_${ci}$bdsqr( 'U', m, m, m, 0, s, rwork( ie ),work( iu ), ldwrku, & work( ir ),ldwrkr, cdum, 1, rwork( irwork ),info ) ! multiply right singular vectors of l in work(iu) by ! q in a, storing result in vt ! (cworkspace: need m*m) ! (rworkspace: 0) - call stdlib_wgemm( 'N', 'N', m, n, m, cone, work( iu ),ldwrku, a, lda, & + call stdlib_${ci}$gemm( 'N', 'N', m, n, m, cone, work( iu ),ldwrku, a, lda, & czero, vt, ldvt ) ! copy left singular vectors of l to a ! (cworkspace: need m*m) ! (rworkspace: 0) - call stdlib_wlacpy( 'F', m, m, work( ir ), ldwrkr, a,lda ) + call stdlib_${ci}$lacpy( 'F', m, m, work( ir ), ldwrkr, a,lda ) else ! insufficient workspace for a fast algorithm itau = 1 @@ -13830,34 +13832,34 @@ module stdlib_linalg_lapack_w ! compute a=l*q, copying result to vt ! (cworkspace: need 2*m, prefer m+m*nb) ! (rworkspace: 0) - call stdlib_wgelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib_${ci}$gelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - call stdlib_wlacpy( 'U', m, n, a, lda, vt, ldvt ) + call stdlib_${ci}$lacpy( 'U', m, n, a, lda, vt, ldvt ) ! generate q in vt ! (cworkspace: need 2*m, prefer m+m*nb) ! (rworkspace: 0) - call stdlib_wunglq( m, n, m, vt, ldvt, work( itau ),work( iwork ), & + call stdlib_${ci}$unglq( m, n, m, vt, ldvt, work( itau ),work( iwork ), & lwork-iwork+1, ierr ) ie = 1 itauq = itau itaup = itauq + m iwork = itaup + m ! zero out above l in a - if (m>1) call stdlib_wlaset( 'U', m-1, m-1, czero, czero,a( 1, 2 ), lda ) + if (m>1) call stdlib_${ci}$laset( 'U', m-1, m-1, czero, czero,a( 1, 2 ), lda ) ! bidiagonalize l in a ! (cworkspace: need 3*m, prefer 2*m+2*m*nb) ! (rworkspace: need m) - call stdlib_wgebrd( m, m, a, lda, s, rwork( ie ),work( itauq ), work( & + call stdlib_${ci}$gebrd( m, m, a, lda, s, rwork( ie ),work( itauq ), work( & itaup ),work( iwork ), lwork-iwork+1, ierr ) ! multiply right vectors bidiagonalizing l by q in vt ! (cworkspace: need 2*m+n, prefer 2*m+n*nb) ! (rworkspace: 0) - call stdlib_wunmbr( 'P', 'L', 'C', m, n, m, a, lda,work( itaup ), vt, & + call stdlib_${ci}$unmbr( 'P', 'L', 'C', m, n, m, a, lda,work( itaup ), vt, & ldvt,work( iwork ), lwork-iwork+1, ierr ) ! generate left bidiagonalizing vectors of l in a ! (cworkspace: need 3*m, prefer 2*m+m*nb) ! (rworkspace: 0) - call stdlib_wungbr( 'Q', m, m, m, a, lda, work( itauq ),work( iwork ), & + call stdlib_${ci}$ungbr( 'Q', m, m, m, a, lda, work( itauq ),work( iwork ), & lwork-iwork+1, ierr ) irwork = ie + m ! perform bidiagonal qr iteration, computing left @@ -13865,7 +13867,7 @@ module stdlib_linalg_lapack_w ! singular vectors of a in vt ! (cworkspace: 0) ! (rworkspace: need bdspac) - call stdlib_wbdsqr( 'U', m, n, m, 0, s, rwork( ie ), vt,ldvt, a, lda, & + call stdlib_${ci}$bdsqr( 'U', m, n, m, 0, s, rwork( ie ), vt,ldvt, a, lda, & cdum, 1,rwork( irwork ), info ) end if else if( wntuas ) then @@ -13888,16 +13890,16 @@ module stdlib_linalg_lapack_w ! compute a=l*q ! (cworkspace: need m*m+2*m, prefer m*m+m+m*nb) ! (rworkspace: 0) - call stdlib_wgelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib_${ci}$gelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ! copy l to work(iu), zeroing out above it - call stdlib_wlacpy( 'L', m, m, a, lda, work( iu ),ldwrku ) - call stdlib_wlaset( 'U', m-1, m-1, czero, czero,work( iu+ldwrku ), & + call stdlib_${ci}$lacpy( 'L', m, m, a, lda, work( iu ),ldwrku ) + call stdlib_${ci}$laset( 'U', m-1, m-1, czero, czero,work( iu+ldwrku ), & ldwrku ) ! generate q in a ! (cworkspace: need m*m+2*m, prefer m*m+m+m*nb) ! (rworkspace: 0) - call stdlib_wunglq( m, n, m, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib_${ci}$unglq( m, n, m, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ie = 1 itauq = itau @@ -13906,19 +13908,19 @@ module stdlib_linalg_lapack_w ! bidiagonalize l in work(iu), copying result to u ! (cworkspace: need m*m+3*m, prefer m*m+2*m+2*m*nb) ! (rworkspace: need m) - call stdlib_wgebrd( m, m, work( iu ), ldwrku, s,rwork( ie ), work( & + call stdlib_${ci}$gebrd( m, m, work( iu ), ldwrku, s,rwork( ie ), work( & itauq ),work( itaup ), work( iwork ),lwork-iwork+1, ierr ) - call stdlib_wlacpy( 'L', m, m, work( iu ), ldwrku, u,ldu ) + call stdlib_${ci}$lacpy( 'L', m, m, work( iu ), ldwrku, u,ldu ) ! generate right bidiagonalizing vectors in work(iu) ! (cworkspace: need m*m+3*m-1, ! prefer m*m+2*m+(m-1)*nb) ! (rworkspace: 0) - call stdlib_wungbr( 'P', m, m, m, work( iu ), ldwrku,work( itaup ), & + call stdlib_${ci}$ungbr( 'P', m, m, m, work( iu ), ldwrku,work( itaup ), & work( iwork ),lwork-iwork+1, ierr ) ! generate left bidiagonalizing vectors in u ! (cworkspace: need m*m+3*m, prefer m*m+2*m+m*nb) ! (rworkspace: 0) - call stdlib_wungbr( 'Q', m, m, m, u, ldu, work( itauq ),work( iwork ), & + call stdlib_${ci}$ungbr( 'Q', m, m, m, u, ldu, work( itauq ),work( iwork ), & lwork-iwork+1, ierr ) irwork = ie + m ! perform bidiagonal qr iteration, computing left @@ -13926,13 +13928,13 @@ module stdlib_linalg_lapack_w ! singular vectors of l in work(iu) ! (cworkspace: need m*m) ! (rworkspace: need bdspac) - call stdlib_wbdsqr( 'U', m, m, m, 0, s, rwork( ie ),work( iu ), ldwrku, & + call stdlib_${ci}$bdsqr( 'U', m, m, m, 0, s, rwork( ie ),work( iu ), ldwrku, & u, ldu, cdum, 1,rwork( irwork ), info ) ! multiply right singular vectors of l in work(iu) by ! q in a, storing result in vt ! (cworkspace: need m*m) ! (rworkspace: 0) - call stdlib_wgemm( 'N', 'N', m, n, m, cone, work( iu ),ldwrku, a, lda, & + call stdlib_${ci}$gemm( 'N', 'N', m, n, m, cone, work( iu ),ldwrku, a, lda, & czero, vt, ldvt ) else ! insufficient workspace for a fast algorithm @@ -13941,17 +13943,17 @@ module stdlib_linalg_lapack_w ! compute a=l*q, copying result to vt ! (cworkspace: need 2*m, prefer m+m*nb) ! (rworkspace: 0) - call stdlib_wgelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib_${ci}$gelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - call stdlib_wlacpy( 'U', m, n, a, lda, vt, ldvt ) + call stdlib_${ci}$lacpy( 'U', m, n, a, lda, vt, ldvt ) ! generate q in vt ! (cworkspace: need 2*m, prefer m+m*nb) ! (rworkspace: 0) - call stdlib_wunglq( m, n, m, vt, ldvt, work( itau ),work( iwork ), & + call stdlib_${ci}$unglq( m, n, m, vt, ldvt, work( itau ),work( iwork ), & lwork-iwork+1, ierr ) ! copy l to u, zeroing out above it - call stdlib_wlacpy( 'L', m, m, a, lda, u, ldu ) - if (m>1) call stdlib_wlaset( 'U', m-1, m-1, czero, czero,u( 1, 2 ), ldu ) + call stdlib_${ci}$lacpy( 'L', m, m, a, lda, u, ldu ) + if (m>1) call stdlib_${ci}$laset( 'U', m-1, m-1, czero, czero,u( 1, 2 ), ldu ) ie = 1 itauq = itau itaup = itauq + m @@ -13959,18 +13961,18 @@ module stdlib_linalg_lapack_w ! bidiagonalize l in u ! (cworkspace: need 3*m, prefer 2*m+2*m*nb) ! (rworkspace: need m) - call stdlib_wgebrd( m, m, u, ldu, s, rwork( ie ),work( itauq ), work( & + call stdlib_${ci}$gebrd( m, m, u, ldu, s, rwork( ie ),work( itauq ), work( & itaup ),work( iwork ), lwork-iwork+1, ierr ) ! multiply right bidiagonalizing vectors in u by q ! in vt ! (cworkspace: need 2*m+n, prefer 2*m+n*nb) ! (rworkspace: 0) - call stdlib_wunmbr( 'P', 'L', 'C', m, n, m, u, ldu,work( itaup ), vt, & + call stdlib_${ci}$unmbr( 'P', 'L', 'C', m, n, m, u, ldu,work( itaup ), vt, & ldvt,work( iwork ), lwork-iwork+1, ierr ) ! generate left bidiagonalizing vectors in u ! (cworkspace: need 3*m, prefer 2*m+m*nb) ! (rworkspace: 0) - call stdlib_wungbr( 'Q', m, m, m, u, ldu, work( itauq ),work( iwork ), & + call stdlib_${ci}$ungbr( 'Q', m, m, m, u, ldu, work( itauq ),work( iwork ), & lwork-iwork+1, ierr ) irwork = ie + m ! perform bidiagonal qr iteration, computing left @@ -13978,7 +13980,7 @@ module stdlib_linalg_lapack_w ! singular vectors of a in vt ! (cworkspace: 0) ! (rworkspace: need bdspac) - call stdlib_wbdsqr( 'U', m, n, m, 0, s, rwork( ie ), vt,ldvt, u, ldu, & + call stdlib_${ci}$bdsqr( 'U', m, n, m, 0, s, rwork( ie ), vt,ldvt, u, ldu, & cdum, 1,rwork( irwork ), info ) end if end if @@ -14002,17 +14004,17 @@ module stdlib_linalg_lapack_w ! compute a=l*q, copying result to vt ! (cworkspace: need m*m+2*m, prefer m*m+m+m*nb) ! (rworkspace: 0) - call stdlib_wgelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib_${ci}$gelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - call stdlib_wlacpy( 'U', m, n, a, lda, vt, ldvt ) + call stdlib_${ci}$lacpy( 'U', m, n, a, lda, vt, ldvt ) ! copy l to work(ir), zeroing out above it - call stdlib_wlacpy( 'L', m, m, a, lda, work( ir ),ldwrkr ) - call stdlib_wlaset( 'U', m-1, m-1, czero, czero,work( ir+ldwrkr ), & + call stdlib_${ci}$lacpy( 'L', m, m, a, lda, work( ir ),ldwrkr ) + call stdlib_${ci}$laset( 'U', m-1, m-1, czero, czero,work( ir+ldwrkr ), & ldwrkr ) ! generate q in vt ! (cworkspace: need m*m+m+n, prefer m*m+m+n*nb) ! (rworkspace: 0) - call stdlib_wunglq( n, n, m, vt, ldvt, work( itau ),work( iwork ), & + call stdlib_${ci}$unglq( n, n, m, vt, ldvt, work( itau ),work( iwork ), & lwork-iwork+1, ierr ) ie = 1 itauq = itau @@ -14021,29 +14023,29 @@ module stdlib_linalg_lapack_w ! bidiagonalize l in work(ir) ! (cworkspace: need m*m+3*m, prefer m*m+2*m+2*m*nb) ! (rworkspace: need m) - call stdlib_wgebrd( m, m, work( ir ), ldwrkr, s,rwork( ie ), work( & + call stdlib_${ci}$gebrd( m, m, work( ir ), ldwrkr, s,rwork( ie ), work( & itauq ),work( itaup ), work( iwork ),lwork-iwork+1, ierr ) ! generate right bidiagonalizing vectors in work(ir) ! (cworkspace: need m*m+3*m-1, ! prefer m*m+2*m+(m-1)*nb) ! (rworkspace: 0) - call stdlib_wungbr( 'P', m, m, m, work( ir ), ldwrkr,work( itaup ), & + call stdlib_${ci}$ungbr( 'P', m, m, m, work( ir ), ldwrkr,work( itaup ), & work( iwork ),lwork-iwork+1, ierr ) irwork = ie + m ! perform bidiagonal qr iteration, computing right ! singular vectors of l in work(ir) ! (cworkspace: need m*m) ! (rworkspace: need bdspac) - call stdlib_wbdsqr( 'U', m, m, 0, 0, s, rwork( ie ),work( ir ), ldwrkr, & + call stdlib_${ci}$bdsqr( 'U', m, m, 0, 0, s, rwork( ie ),work( ir ), ldwrkr, & cdum, 1, cdum, 1,rwork( irwork ), info ) ! multiply right singular vectors of l in work(ir) by ! q in vt, storing result in a ! (cworkspace: need m*m) ! (rworkspace: 0) - call stdlib_wgemm( 'N', 'N', m, n, m, cone, work( ir ),ldwrkr, vt, ldvt,& + call stdlib_${ci}$gemm( 'N', 'N', m, n, m, cone, work( ir ),ldwrkr, vt, ldvt,& czero, a, lda ) ! copy right singular vectors of a from a to vt - call stdlib_wlacpy( 'F', m, n, a, lda, vt, ldvt ) + call stdlib_${ci}$lacpy( 'F', m, n, a, lda, vt, ldvt ) else ! insufficient workspace for a fast algorithm itau = 1 @@ -14051,37 +14053,37 @@ module stdlib_linalg_lapack_w ! compute a=l*q, copying result to vt ! (cworkspace: need 2*m, prefer m+m*nb) ! (rworkspace: 0) - call stdlib_wgelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib_${ci}$gelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - call stdlib_wlacpy( 'U', m, n, a, lda, vt, ldvt ) + call stdlib_${ci}$lacpy( 'U', m, n, a, lda, vt, ldvt ) ! generate q in vt ! (cworkspace: need m+n, prefer m+n*nb) ! (rworkspace: 0) - call stdlib_wunglq( n, n, m, vt, ldvt, work( itau ),work( iwork ), & + call stdlib_${ci}$unglq( n, n, m, vt, ldvt, work( itau ),work( iwork ), & lwork-iwork+1, ierr ) ie = 1 itauq = itau itaup = itauq + m iwork = itaup + m ! zero out above l in a - if (m>1) call stdlib_wlaset( 'U', m-1, m-1, czero, czero,a( 1, 2 ), lda ) + if (m>1) call stdlib_${ci}$laset( 'U', m-1, m-1, czero, czero,a( 1, 2 ), lda ) ! bidiagonalize l in a ! (cworkspace: need 3*m, prefer 2*m+2*m*nb) ! (rworkspace: need m) - call stdlib_wgebrd( m, m, a, lda, s, rwork( ie ),work( itauq ), work( & + call stdlib_${ci}$gebrd( m, m, a, lda, s, rwork( ie ),work( itauq ), work( & itaup ),work( iwork ), lwork-iwork+1, ierr ) ! multiply right bidiagonalizing vectors in a by q ! in vt ! (cworkspace: need 2*m+n, prefer 2*m+n*nb) ! (rworkspace: 0) - call stdlib_wunmbr( 'P', 'L', 'C', m, n, m, a, lda,work( itaup ), vt, & + call stdlib_${ci}$unmbr( 'P', 'L', 'C', m, n, m, a, lda,work( itaup ), vt, & ldvt,work( iwork ), lwork-iwork+1, ierr ) irwork = ie + m ! perform bidiagonal qr iteration, computing right ! singular vectors of a in vt ! (cworkspace: 0) ! (rworkspace: need bdspac) - call stdlib_wbdsqr( 'U', m, n, 0, 0, s, rwork( ie ), vt,ldvt, cdum, 1, & + call stdlib_${ci}$bdsqr( 'U', m, n, 0, 0, s, rwork( ie ), vt,ldvt, cdum, 1, & cdum, 1,rwork( irwork ), info ) end if else if( wntuo ) then @@ -14112,17 +14114,17 @@ module stdlib_linalg_lapack_w ! compute a=l*q, copying result to vt ! (cworkspace: need 2*m*m+2*m, prefer 2*m*m+m+m*nb) ! (rworkspace: 0) - call stdlib_wgelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib_${ci}$gelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - call stdlib_wlacpy( 'U', m, n, a, lda, vt, ldvt ) + call stdlib_${ci}$lacpy( 'U', m, n, a, lda, vt, ldvt ) ! generate q in vt ! (cworkspace: need 2*m*m+m+n, prefer 2*m*m+m+n*nb) ! (rworkspace: 0) - call stdlib_wunglq( n, n, m, vt, ldvt, work( itau ),work( iwork ), & + call stdlib_${ci}$unglq( n, n, m, vt, ldvt, work( itau ),work( iwork ), & lwork-iwork+1, ierr ) ! copy l to work(iu), zeroing out above it - call stdlib_wlacpy( 'L', m, m, a, lda, work( iu ),ldwrku ) - call stdlib_wlaset( 'U', m-1, m-1, czero, czero,work( iu+ldwrku ), & + call stdlib_${ci}$lacpy( 'L', m, m, a, lda, work( iu ),ldwrku ) + call stdlib_${ci}$laset( 'U', m-1, m-1, czero, czero,work( iu+ldwrku ), & ldwrku ) ie = 1 itauq = itau @@ -14133,20 +14135,20 @@ module stdlib_linalg_lapack_w ! (cworkspace: need 2*m*m+3*m, ! prefer 2*m*m+2*m+2*m*nb) ! (rworkspace: need m) - call stdlib_wgebrd( m, m, work( iu ), ldwrku, s,rwork( ie ), work( & + call stdlib_${ci}$gebrd( m, m, work( iu ), ldwrku, s,rwork( ie ), work( & itauq ),work( itaup ), work( iwork ),lwork-iwork+1, ierr ) - call stdlib_wlacpy( 'L', m, m, work( iu ), ldwrku,work( ir ), ldwrkr ) + call stdlib_${ci}$lacpy( 'L', m, m, work( iu ), ldwrku,work( ir ), ldwrkr ) ! generate right bidiagonalizing vectors in work(iu) ! (cworkspace: need 2*m*m+3*m-1, ! prefer 2*m*m+2*m+(m-1)*nb) ! (rworkspace: 0) - call stdlib_wungbr( 'P', m, m, m, work( iu ), ldwrku,work( itaup ), & + call stdlib_${ci}$ungbr( 'P', m, m, m, work( iu ), ldwrku,work( itaup ), & work( iwork ),lwork-iwork+1, ierr ) ! generate left bidiagonalizing vectors in work(ir) ! (cworkspace: need 2*m*m+3*m, prefer 2*m*m+2*m+m*nb) ! (rworkspace: 0) - call stdlib_wungbr( 'Q', m, m, m, work( ir ), ldwrkr,work( itauq ), & + call stdlib_${ci}$ungbr( 'Q', m, m, m, work( ir ), ldwrkr,work( itauq ), & work( iwork ),lwork-iwork+1, ierr ) irwork = ie + m ! perform bidiagonal qr iteration, computing left @@ -14154,18 +14156,18 @@ module stdlib_linalg_lapack_w ! right singular vectors of l in work(iu) ! (cworkspace: need 2*m*m) ! (rworkspace: need bdspac) - call stdlib_wbdsqr( 'U', m, m, m, 0, s, rwork( ie ),work( iu ), ldwrku, & + call stdlib_${ci}$bdsqr( 'U', m, m, m, 0, s, rwork( ie ),work( iu ), ldwrku, & work( ir ),ldwrkr, cdum, 1, rwork( irwork ),info ) ! multiply right singular vectors of l in work(iu) by ! q in vt, storing result in a ! (cworkspace: need m*m) ! (rworkspace: 0) - call stdlib_wgemm( 'N', 'N', m, n, m, cone, work( iu ),ldwrku, vt, ldvt,& + call stdlib_${ci}$gemm( 'N', 'N', m, n, m, cone, work( iu ),ldwrku, vt, ldvt,& czero, a, lda ) ! copy right singular vectors of a from a to vt - call stdlib_wlacpy( 'F', m, n, a, lda, vt, ldvt ) + call stdlib_${ci}$lacpy( 'F', m, n, a, lda, vt, ldvt ) ! copy left singular vectors of a from work(ir) to a - call stdlib_wlacpy( 'F', m, m, work( ir ), ldwrkr, a,lda ) + call stdlib_${ci}$lacpy( 'F', m, m, work( ir ), ldwrkr, a,lda ) else ! insufficient workspace for a fast algorithm itau = 1 @@ -14173,35 +14175,35 @@ module stdlib_linalg_lapack_w ! compute a=l*q, copying result to vt ! (cworkspace: need 2*m, prefer m+m*nb) ! (rworkspace: 0) - call stdlib_wgelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib_${ci}$gelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - call stdlib_wlacpy( 'U', m, n, a, lda, vt, ldvt ) + call stdlib_${ci}$lacpy( 'U', m, n, a, lda, vt, ldvt ) ! generate q in vt ! (cworkspace: need m+n, prefer m+n*nb) ! (rworkspace: 0) - call stdlib_wunglq( n, n, m, vt, ldvt, work( itau ),work( iwork ), & + call stdlib_${ci}$unglq( n, n, m, vt, ldvt, work( itau ),work( iwork ), & lwork-iwork+1, ierr ) ie = 1 itauq = itau itaup = itauq + m iwork = itaup + m ! zero out above l in a - if (m>1) call stdlib_wlaset( 'U', m-1, m-1, czero, czero,a( 1, 2 ), lda ) + if (m>1) call stdlib_${ci}$laset( 'U', m-1, m-1, czero, czero,a( 1, 2 ), lda ) ! bidiagonalize l in a ! (cworkspace: need 3*m, prefer 2*m+2*m*nb) ! (rworkspace: need m) - call stdlib_wgebrd( m, m, a, lda, s, rwork( ie ),work( itauq ), work( & + call stdlib_${ci}$gebrd( m, m, a, lda, s, rwork( ie ),work( itauq ), work( & itaup ),work( iwork ), lwork-iwork+1, ierr ) ! multiply right bidiagonalizing vectors in a by q ! in vt ! (cworkspace: need 2*m+n, prefer 2*m+n*nb) ! (rworkspace: 0) - call stdlib_wunmbr( 'P', 'L', 'C', m, n, m, a, lda,work( itaup ), vt, & + call stdlib_${ci}$unmbr( 'P', 'L', 'C', m, n, m, a, lda,work( itaup ), vt, & ldvt,work( iwork ), lwork-iwork+1, ierr ) ! generate left bidiagonalizing vectors in a ! (cworkspace: need 3*m, prefer 2*m+m*nb) ! (rworkspace: 0) - call stdlib_wungbr( 'Q', m, m, m, a, lda, work( itauq ),work( iwork ), & + call stdlib_${ci}$ungbr( 'Q', m, m, m, a, lda, work( itauq ),work( iwork ), & lwork-iwork+1, ierr ) irwork = ie + m ! perform bidiagonal qr iteration, computing left @@ -14209,7 +14211,7 @@ module stdlib_linalg_lapack_w ! singular vectors of a in vt ! (cworkspace: 0) ! (rworkspace: need bdspac) - call stdlib_wbdsqr( 'U', m, n, m, 0, s, rwork( ie ), vt,ldvt, a, lda, & + call stdlib_${ci}$bdsqr( 'U', m, n, m, 0, s, rwork( ie ), vt,ldvt, a, lda, & cdum, 1,rwork( irwork ), info ) end if else if( wntuas ) then @@ -14232,17 +14234,17 @@ module stdlib_linalg_lapack_w ! compute a=l*q, copying result to vt ! (cworkspace: need m*m+2*m, prefer m*m+m+m*nb) ! (rworkspace: 0) - call stdlib_wgelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib_${ci}$gelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - call stdlib_wlacpy( 'U', m, n, a, lda, vt, ldvt ) + call stdlib_${ci}$lacpy( 'U', m, n, a, lda, vt, ldvt ) ! generate q in vt ! (cworkspace: need m*m+m+n, prefer m*m+m+n*nb) ! (rworkspace: 0) - call stdlib_wunglq( n, n, m, vt, ldvt, work( itau ),work( iwork ), & + call stdlib_${ci}$unglq( n, n, m, vt, ldvt, work( itau ),work( iwork ), & lwork-iwork+1, ierr ) ! copy l to work(iu), zeroing out above it - call stdlib_wlacpy( 'L', m, m, a, lda, work( iu ),ldwrku ) - call stdlib_wlaset( 'U', m-1, m-1, czero, czero,work( iu+ldwrku ), & + call stdlib_${ci}$lacpy( 'L', m, m, a, lda, work( iu ),ldwrku ) + call stdlib_${ci}$laset( 'U', m-1, m-1, czero, czero,work( iu+ldwrku ), & ldwrku ) ie = 1 itauq = itau @@ -14251,18 +14253,18 @@ module stdlib_linalg_lapack_w ! bidiagonalize l in work(iu), copying result to u ! (cworkspace: need m*m+3*m, prefer m*m+2*m+2*m*nb) ! (rworkspace: need m) - call stdlib_wgebrd( m, m, work( iu ), ldwrku, s,rwork( ie ), work( & + call stdlib_${ci}$gebrd( m, m, work( iu ), ldwrku, s,rwork( ie ), work( & itauq ),work( itaup ), work( iwork ),lwork-iwork+1, ierr ) - call stdlib_wlacpy( 'L', m, m, work( iu ), ldwrku, u,ldu ) + call stdlib_${ci}$lacpy( 'L', m, m, work( iu ), ldwrku, u,ldu ) ! generate right bidiagonalizing vectors in work(iu) ! (cworkspace: need m*m+3*m, prefer m*m+2*m+(m-1)*nb) ! (rworkspace: 0) - call stdlib_wungbr( 'P', m, m, m, work( iu ), ldwrku,work( itaup ), & + call stdlib_${ci}$ungbr( 'P', m, m, m, work( iu ), ldwrku,work( itaup ), & work( iwork ),lwork-iwork+1, ierr ) ! generate left bidiagonalizing vectors in u ! (cworkspace: need m*m+3*m, prefer m*m+2*m+m*nb) ! (rworkspace: 0) - call stdlib_wungbr( 'Q', m, m, m, u, ldu, work( itauq ),work( iwork ), & + call stdlib_${ci}$ungbr( 'Q', m, m, m, u, ldu, work( itauq ),work( iwork ), & lwork-iwork+1, ierr ) irwork = ie + m ! perform bidiagonal qr iteration, computing left @@ -14270,16 +14272,16 @@ module stdlib_linalg_lapack_w ! singular vectors of l in work(iu) ! (cworkspace: need m*m) ! (rworkspace: need bdspac) - call stdlib_wbdsqr( 'U', m, m, m, 0, s, rwork( ie ),work( iu ), ldwrku, & + call stdlib_${ci}$bdsqr( 'U', m, m, m, 0, s, rwork( ie ),work( iu ), ldwrku, & u, ldu, cdum, 1,rwork( irwork ), info ) ! multiply right singular vectors of l in work(iu) by ! q in vt, storing result in a ! (cworkspace: need m*m) ! (rworkspace: 0) - call stdlib_wgemm( 'N', 'N', m, n, m, cone, work( iu ),ldwrku, vt, ldvt,& + call stdlib_${ci}$gemm( 'N', 'N', m, n, m, cone, work( iu ),ldwrku, vt, ldvt,& czero, a, lda ) ! copy right singular vectors of a from a to vt - call stdlib_wlacpy( 'F', m, n, a, lda, vt, ldvt ) + call stdlib_${ci}$lacpy( 'F', m, n, a, lda, vt, ldvt ) else ! insufficient workspace for a fast algorithm itau = 1 @@ -14287,17 +14289,17 @@ module stdlib_linalg_lapack_w ! compute a=l*q, copying result to vt ! (cworkspace: need 2*m, prefer m+m*nb) ! (rworkspace: 0) - call stdlib_wgelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib_${ci}$gelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - call stdlib_wlacpy( 'U', m, n, a, lda, vt, ldvt ) + call stdlib_${ci}$lacpy( 'U', m, n, a, lda, vt, ldvt ) ! generate q in vt ! (cworkspace: need m+n, prefer m+n*nb) ! (rworkspace: 0) - call stdlib_wunglq( n, n, m, vt, ldvt, work( itau ),work( iwork ), & + call stdlib_${ci}$unglq( n, n, m, vt, ldvt, work( itau ),work( iwork ), & lwork-iwork+1, ierr ) ! copy l to u, zeroing out above it - call stdlib_wlacpy( 'L', m, m, a, lda, u, ldu ) - if (m>1) call stdlib_wlaset( 'U', m-1, m-1, czero, czero,u( 1, 2 ), ldu ) + call stdlib_${ci}$lacpy( 'L', m, m, a, lda, u, ldu ) + if (m>1) call stdlib_${ci}$laset( 'U', m-1, m-1, czero, czero,u( 1, 2 ), ldu ) ie = 1 itauq = itau itaup = itauq + m @@ -14305,18 +14307,18 @@ module stdlib_linalg_lapack_w ! bidiagonalize l in u ! (cworkspace: need 3*m, prefer 2*m+2*m*nb) ! (rworkspace: need m) - call stdlib_wgebrd( m, m, u, ldu, s, rwork( ie ),work( itauq ), work( & + call stdlib_${ci}$gebrd( m, m, u, ldu, s, rwork( ie ),work( itauq ), work( & itaup ),work( iwork ), lwork-iwork+1, ierr ) ! multiply right bidiagonalizing vectors in u by q ! in vt ! (cworkspace: need 2*m+n, prefer 2*m+n*nb) ! (rworkspace: 0) - call stdlib_wunmbr( 'P', 'L', 'C', m, n, m, u, ldu,work( itaup ), vt, & + call stdlib_${ci}$unmbr( 'P', 'L', 'C', m, n, m, u, ldu,work( itaup ), vt, & ldvt,work( iwork ), lwork-iwork+1, ierr ) ! generate left bidiagonalizing vectors in u ! (cworkspace: need 3*m, prefer 2*m+m*nb) ! (rworkspace: 0) - call stdlib_wungbr( 'Q', m, m, m, u, ldu, work( itauq ),work( iwork ), & + call stdlib_${ci}$ungbr( 'Q', m, m, m, u, ldu, work( itauq ),work( iwork ), & lwork-iwork+1, ierr ) irwork = ie + m ! perform bidiagonal qr iteration, computing left @@ -14324,7 +14326,7 @@ module stdlib_linalg_lapack_w ! singular vectors of a in vt ! (cworkspace: 0) ! (rworkspace: need bdspac) - call stdlib_wbdsqr( 'U', m, n, m, 0, s, rwork( ie ), vt,ldvt, u, ldu, & + call stdlib_${ci}$bdsqr( 'U', m, n, m, 0, s, rwork( ie ), vt,ldvt, u, ldu, & cdum, 1,rwork( irwork ), info ) end if end if @@ -14340,15 +14342,15 @@ module stdlib_linalg_lapack_w ! bidiagonalize a ! (cworkspace: need 2*m+n, prefer 2*m+(m+n)*nb) ! (rworkspace: m) - call stdlib_wgebrd( m, n, a, lda, s, rwork( ie ), work( itauq ),work( itaup ), & + call stdlib_${ci}$gebrd( m, n, a, lda, s, rwork( ie ), work( itauq ),work( itaup ), & work( iwork ), lwork-iwork+1,ierr ) if( wntuas ) then ! if left singular vectors desired in u, copy result to u ! and generate left bidiagonalizing vectors in u ! (cworkspace: need 3*m-1, prefer 2*m+(m-1)*nb) ! (rworkspace: 0) - call stdlib_wlacpy( 'L', m, m, a, lda, u, ldu ) - call stdlib_wungbr( 'Q', m, m, n, u, ldu, work( itauq ),work( iwork ), lwork-& + call stdlib_${ci}$lacpy( 'L', m, m, a, lda, u, ldu ) + call stdlib_${ci}$ungbr( 'Q', m, m, n, u, ldu, work( itauq ),work( iwork ), lwork-& iwork+1, ierr ) end if if( wntvas ) then @@ -14356,10 +14358,10 @@ module stdlib_linalg_lapack_w ! vt and generate right bidiagonalizing vectors in vt ! (cworkspace: need 2*m+nrvt, prefer 2*m+nrvt*nb) ! (rworkspace: 0) - call stdlib_wlacpy( 'U', m, n, a, lda, vt, ldvt ) + call stdlib_${ci}$lacpy( 'U', m, n, a, lda, vt, ldvt ) if( wntva )nrvt = n if( wntvs )nrvt = m - call stdlib_wungbr( 'P', nrvt, n, m, vt, ldvt, work( itaup ),work( iwork ), & + call stdlib_${ci}$ungbr( 'P', nrvt, n, m, vt, ldvt, work( itaup ),work( iwork ), & lwork-iwork+1, ierr ) end if if( wntuo ) then @@ -14367,7 +14369,7 @@ module stdlib_linalg_lapack_w ! bidiagonalizing vectors in a ! (cworkspace: need 3*m-1, prefer 2*m+(m-1)*nb) ! (rworkspace: 0) - call stdlib_wungbr( 'Q', m, m, n, a, lda, work( itauq ),work( iwork ), lwork-& + call stdlib_${ci}$ungbr( 'Q', m, m, n, a, lda, work( itauq ),work( iwork ), lwork-& iwork+1, ierr ) end if if( wntvo ) then @@ -14375,7 +14377,7 @@ module stdlib_linalg_lapack_w ! bidiagonalizing vectors in a ! (cworkspace: need 3*m, prefer 2*m+m*nb) ! (rworkspace: 0) - call stdlib_wungbr( 'P', m, n, m, a, lda, work( itaup ),work( iwork ), lwork-& + call stdlib_${ci}$ungbr( 'P', m, n, m, a, lda, work( itaup ),work( iwork ), lwork-& iwork+1, ierr ) end if irwork = ie + m @@ -14389,7 +14391,7 @@ module stdlib_linalg_lapack_w ! vectors in vt ! (cworkspace: 0) ! (rworkspace: need bdspac) - call stdlib_wbdsqr( 'L', m, ncvt, nru, 0, s, rwork( ie ), vt,ldvt, u, ldu, & + call stdlib_${ci}$bdsqr( 'L', m, ncvt, nru, 0, s, rwork( ie ), vt,ldvt, u, ldu, & cdum, 1, rwork( irwork ),info ) else if( ( .not.wntuo ) .and. wntvo ) then ! perform bidiagonal qr iteration, if desired, computing @@ -14397,7 +14399,7 @@ module stdlib_linalg_lapack_w ! vectors in a ! (cworkspace: 0) ! (rworkspace: need bdspac) - call stdlib_wbdsqr( 'L', m, ncvt, nru, 0, s, rwork( ie ), a,lda, u, ldu, cdum,& + call stdlib_${ci}$bdsqr( 'L', m, ncvt, nru, 0, s, rwork( ie ), a,lda, u, ldu, cdum,& 1, rwork( irwork ),info ) else ! perform bidiagonal qr iteration, if desired, computing @@ -14405,29 +14407,29 @@ module stdlib_linalg_lapack_w ! vectors in vt ! (cworkspace: 0) ! (rworkspace: need bdspac) - call stdlib_wbdsqr( 'L', m, ncvt, nru, 0, s, rwork( ie ), vt,ldvt, a, lda, & + call stdlib_${ci}$bdsqr( 'L', m, ncvt, nru, 0, s, rwork( ie ), vt,ldvt, a, lda, & cdum, 1, rwork( irwork ),info ) end if end if end if ! undo scaling if necessary if( iscl==1 ) then - if( anrm>bignum )call stdlib_qlascl( 'G', 0, 0, bignum, anrm, minmn, 1, s, minmn,& + if( anrm>bignum )call stdlib_${c2ri(ci)}$lascl( 'G', 0, 0, bignum, anrm, minmn, 1, s, minmn,& ierr ) - if( info/=0 .and. anrm>bignum )call stdlib_qlascl( 'G', 0, 0, bignum, anrm, minmn-1,& + if( info/=0 .and. anrm>bignum )call stdlib_${c2ri(ci)}$lascl( 'G', 0, 0, bignum, anrm, minmn-1,& 1,rwork( ie ), minmn, ierr ) - if( anrm= N. The SVD of A is written as !! [++] [xx] [x0] [xx] @@ -14444,9 +14446,9 @@ module stdlib_linalg_lapack_w integer(ilp), intent(out) :: numrank, info integer(ilp), intent(inout) :: lcwork ! Array Arguments - complex(qp), intent(inout) :: a(lda,*) - complex(qp), intent(out) :: u(ldu,*), v(ldv,*), cwork(*) - real(qp), intent(out) :: s(*), rwork(*) + complex(${ck}$), intent(inout) :: a(lda,*) + complex(${ck}$), intent(out) :: u(ldu,*), v(ldv,*), cwork(*) + real(${ck}$), intent(out) :: s(*), rwork(*) integer(ilp), intent(out) :: iwork(*) ! ===================================================================== @@ -14458,11 +14460,11 @@ module stdlib_linalg_lapack_w lwunq, lwunq2, lwunlq, minwrk, minwrk2, optwrk, optwrk2, iminwrk, rminwrk logical(lk) :: accla, acclm, acclh, ascaled, conda, dntwu, dntwv, lquery, lsvc0, lsvec,& rowprm, rsvec, rtrans, wntua, wntuf, wntur, wntus, wntva, wntvr - real(qp) :: big, epsln, rtmp, sconda, sfmin - complex(qp) :: ctmp + real(${ck}$) :: big, epsln, rtmp, sconda, sfmin + complex(${ck}$) :: ctmp ! Local Arrays - complex(qp) :: cdummy(1) - real(qp) :: rdummy(1) + complex(${ck}$) :: cdummy(1) + real(${ck}$) :: rdummy(1) ! Intrinsic Functions intrinsic :: abs,conjg,max,min,real,sqrt ! Executable Statements @@ -14537,15 +14539,15 @@ module stdlib_linalg_lapack_w ! Stdlib_Zgesvd Of An N X N Matrix lwsvd = max( 3 * n, 1 ) if ( lquery ) then - call stdlib_wgeqp3( m, n, a, lda, iwork, cdummy, cdummy, -1,rdummy, ierr ) + call stdlib_${ci}$geqp3( m, n, a, lda, iwork, cdummy, cdummy, -1,rdummy, ierr ) lwrk_wgeqp3 = int( cdummy(1),KIND=ilp) if ( wntus .or. wntur ) then - call stdlib_wunmqr( 'L', 'N', m, n, n, a, lda, cdummy, u,ldu, cdummy, -1, & + call stdlib_${ci}$unmqr( 'L', 'N', m, n, n, a, lda, cdummy, u,ldu, cdummy, -1, & ierr ) lwrk_wunmqr = int( cdummy(1),KIND=ilp) else if ( wntua ) then - call stdlib_wunmqr( 'L', 'N', m, m, n, a, lda, cdummy, u,ldu, cdummy, -1, & + call stdlib_${ci}$unmqr( 'L', 'N', m, m, n, a, lda, cdummy, u,ldu, cdummy, -1, & ierr ) lwrk_wunmqr = int( cdummy(1),KIND=ilp) else @@ -14563,7 +14565,7 @@ module stdlib_linalg_lapack_w minwrk = max( n+lwqp3, lwsvd ) end if if ( lquery ) then - call stdlib_wgesvd( 'N', 'N', n, n, a, lda, s, u, ldu,v, ldv, cdummy, -1, & + call stdlib_${ci}$gesvd( 'N', 'N', n, n, a, lda, s, u, ldu,v, ldv, cdummy, -1, & rdummy, ierr ) lwrk_wgesvd = int( cdummy(1),KIND=ilp) if ( conda ) then @@ -14582,10 +14584,10 @@ module stdlib_linalg_lapack_w end if if ( lquery ) then if ( rtrans ) then - call stdlib_wgesvd( 'N', 'O', n, n, a, lda, s, u, ldu,v, ldv, cdummy, -1, & + call stdlib_${ci}$gesvd( 'N', 'O', n, n, a, lda, s, u, ldu,v, ldv, cdummy, -1, & rdummy, ierr ) else - call stdlib_wgesvd( 'O', 'N', n, n, a, lda, s, u, ldu,v, ldv, cdummy, -1, & + call stdlib_${ci}$gesvd( 'O', 'N', n, n, a, lda, s, u, ldu,v, ldv, cdummy, -1, & rdummy, ierr ) end if lwrk_wgesvd = int( cdummy(1),KIND=ilp) @@ -14605,10 +14607,10 @@ module stdlib_linalg_lapack_w end if if ( lquery ) then if ( rtrans ) then - call stdlib_wgesvd( 'O', 'N', n, n, a, lda, s, u, ldu,v, ldv, cdummy, -& + call stdlib_${ci}$gesvd( 'O', 'N', n, n, a, lda, s, u, ldu,v, ldv, cdummy, -& 1, rdummy, ierr ) else - call stdlib_wgesvd( 'N', 'O', n, n, a, lda, s, u, ldu,v, ldv, cdummy, -& + call stdlib_${ci}$gesvd( 'N', 'O', n, n, a, lda, s, u, ldu,v, ldv, cdummy, -& 1, rdummy, ierr ) end if lwrk_wgesvd = int( cdummy(1),KIND=ilp) @@ -14626,9 +14628,9 @@ module stdlib_linalg_lapack_w if ( conda ) minwrk = max( minwrk, lwcon ) minwrk = minwrk + n if ( wntva ) then - ! .. minimal workspace length for n x n/2 stdlib_wgeqrf + ! .. minimal workspace length for n x n/2 stdlib_${ci}$geqrf lwqrf = max( n/2, 1 ) - ! .. minimal workspace length for n/2 x n/2 stdlib_wgesvd + ! .. minimal workspace length for n/2 x n/2 stdlib_${ci}$gesvd lwsvd2 = max( 3 * (n/2), 1 ) lwunq2 = max( n, 1 ) minwrk2 = max( lwqp3, n/2+lwqrf, n/2+lwsvd2,n/2+lwunq2, lwunq ) @@ -14641,7 +14643,7 @@ module stdlib_linalg_lapack_w if ( conda ) minwrk = max( minwrk, lwcon ) minwrk = minwrk + n if ( wntva ) then - ! .. minimal workspace length for n/2 x n stdlib_wgelqf + ! .. minimal workspace length for n/2 x n stdlib_${ci}$gelqf lwlqf = max( n/2, 1 ) lwsvd2 = max( 3 * (n/2), 1 ) lwunlq = max( n , 1 ) @@ -14653,19 +14655,19 @@ module stdlib_linalg_lapack_w end if if ( lquery ) then if ( rtrans ) then - call stdlib_wgesvd( 'O', 'A', n, n, a, lda, s, u, ldu,v, ldv, cdummy, -1, & + call stdlib_${ci}$gesvd( 'O', 'A', n, n, a, lda, s, u, ldu,v, ldv, cdummy, -1, & rdummy, ierr ) lwrk_wgesvd = int( cdummy(1),KIND=ilp) optwrk = max(lwrk_wgeqp3,lwrk_wgesvd,lwrk_wunmqr) if ( conda ) optwrk = max( optwrk, lwcon ) optwrk = n + optwrk if ( wntva ) then - call stdlib_wgeqrf(n,n/2,u,ldu,cdummy,cdummy,-1,ierr) + call stdlib_${ci}$geqrf(n,n/2,u,ldu,cdummy,cdummy,-1,ierr) lwrk_wgeqrf = int( cdummy(1),KIND=ilp) - call stdlib_wgesvd( 'S', 'O', n/2,n/2, v,ldv, s, u,ldu,v, ldv, cdummy,& + call stdlib_${ci}$gesvd( 'S', 'O', n/2,n/2, v,ldv, s, u,ldu,v, ldv, cdummy,& -1, rdummy, ierr ) lwrk_wgesvd2 = int( cdummy(1),KIND=ilp) - call stdlib_wunmqr( 'R', 'C', n, n, n/2, u, ldu, cdummy,v, ldv, & + call stdlib_${ci}$unmqr( 'R', 'C', n, n, n/2, u, ldu, cdummy,v, ldv, & cdummy, -1, ierr ) lwrk_wunmqr2 = int( cdummy(1),KIND=ilp) optwrk2 = max( lwrk_wgeqp3, n/2+lwrk_wgeqrf,n/2+lwrk_wgesvd2, n/2+& @@ -14675,19 +14677,19 @@ module stdlib_linalg_lapack_w optwrk = max( optwrk, optwrk2 ) end if else - call stdlib_wgesvd( 'S', 'O', n, n, a, lda, s, u, ldu,v, ldv, cdummy, -1, & + call stdlib_${ci}$gesvd( 'S', 'O', n, n, a, lda, s, u, ldu,v, ldv, cdummy, -1, & rdummy, ierr ) lwrk_wgesvd = int( cdummy(1),KIND=ilp) optwrk = max(lwrk_wgeqp3,lwrk_wgesvd,lwrk_wunmqr) if ( conda ) optwrk = max( optwrk, lwcon ) optwrk = n + optwrk if ( wntva ) then - call stdlib_wgelqf(n/2,n,u,ldu,cdummy,cdummy,-1,ierr) + call stdlib_${ci}$gelqf(n/2,n,u,ldu,cdummy,cdummy,-1,ierr) lwrk_wgelqf = int( cdummy(1),KIND=ilp) - call stdlib_wgesvd( 'S','O', n/2,n/2, v, ldv, s, u, ldu,v, ldv, cdummy,& + call stdlib_${ci}$gesvd( 'S','O', n/2,n/2, v, ldv, s, u, ldu,v, ldv, cdummy,& -1, rdummy, ierr ) lwrk_wgesvd2 = int( cdummy(1),KIND=ilp) - call stdlib_wunmlq( 'R', 'N', n, n, n/2, u, ldu, cdummy,v, ldv, cdummy,& + call stdlib_${ci}$unmlq( 'R', 'N', n, n, n/2, u, ldu, cdummy,v, ldv, cdummy,& -1,ierr ) lwrk_wunmlq = int( cdummy(1),KIND=ilp) optwrk2 = max( lwrk_wgeqp3, n/2+lwrk_wgelqf,n/2+lwrk_wgesvd2, n/2+& @@ -14722,16 +14724,16 @@ module stdlib_linalg_lapack_w ! All Output Is Void return end if - big = stdlib_qlamch('O') + big = stdlib_${c2ri(ci)}$lamch('O') ascaled = .false. if ( rowprm ) then ! Reordering The Rows In Decreasing Sequence In The ! ell-infinity norm - this enhances numerical robustness in ! the case of differently scaled rows. do p = 1, m - ! rwork(p) = abs( a(p,stdlib_iwamax(n,a(p,1),lda)) ) - ! [[stdlib_wlange will return nan if an entry of the p-th row is nan]] - rwork(p) = stdlib_wlange( 'M', 1, n, a(p,1), lda, rdummy ) + ! rwork(p) = abs( a(p,stdlib_i${ci}$amax(n,a(p,1),lda)) ) + ! [[stdlib_${ci}$lange will return nan if an entry of the p-th row is nan]] + rwork(p) = stdlib_${ci}$lange( 'M', 1, n, a(p,1), lda, rdummy ) ! .. check for nan's and inf's if ( ( rwork(p) /= rwork(p) ) .or.( (rwork(p)*zero) /= zero ) ) then info = -8 @@ -14740,7 +14742,7 @@ module stdlib_linalg_lapack_w end if end do do p = 1, m - 1 - q = stdlib_iqamax( m-p+1, rwork(p), 1 ) + p - 1 + q = stdlib_i${c2ri(ci)}$amax( m-p+1, rwork(p), 1 ) + p - 1 iwork(n+p) = q if ( p /= q ) then rtmp = rwork(p) @@ -14751,13 +14753,13 @@ module stdlib_linalg_lapack_w if ( rwork(1) == zero ) then ! quick return: a is the m x n zero matrix. numrank = 0 - call stdlib_qlaset( 'G', n, 1, zero, zero, s, n ) - if ( wntus ) call stdlib_wlaset('G', m, n, czero, cone, u, ldu) - if ( wntua ) call stdlib_wlaset('G', m, m, czero, cone, u, ldu) - if ( wntva ) call stdlib_wlaset('G', n, n, czero, cone, v, ldv) + call stdlib_${c2ri(ci)}$laset( 'G', n, 1, zero, zero, s, n ) + if ( wntus ) call stdlib_${ci}$laset('G', m, n, czero, cone, u, ldu) + if ( wntua ) call stdlib_${ci}$laset('G', m, m, czero, cone, u, ldu) + if ( wntva ) call stdlib_${ci}$laset('G', n, n, czero, cone, v, ldv) if ( wntuf ) then - call stdlib_wlaset( 'G', n, 1, czero, czero, cwork, n ) - call stdlib_wlaset( 'G', m, n, czero, cone, u, ldu ) + call stdlib_${ci}$laset( 'G', n, 1, czero, czero, cwork, n ) + call stdlib_${ci}$laset( 'G', m, n, czero, cone, u, ldu ) end if do p = 1, n iwork(p) = p @@ -14771,30 +14773,30 @@ module stdlib_linalg_lapack_w rwork(2) = -1 return end if - if ( rwork(1) > big / sqrt(real(m,KIND=qp)) ) then + if ( rwork(1) > big / sqrt(real(m,KIND=${ck}$)) ) then ! .. to prevent overflow in the qr factorization, scale the ! matrix by 1/sqrt(m) if too large entry detected - call stdlib_wlascl('G',0,0,sqrt(real(m,KIND=qp)),one, m,n, a,lda, ierr) + call stdlib_${ci}$lascl('G',0,0,sqrt(real(m,KIND=${ck}$)),one, m,n, a,lda, ierr) ascaled = .true. end if - call stdlib_wlaswp( n, a, lda, 1, m-1, iwork(n+1), 1 ) + call stdlib_${ci}$laswp( n, a, lda, 1, m-1, iwork(n+1), 1 ) end if ! .. at this stage, preemptive scaling is done only to avoid column ! norms overflows during the qr factorization. the svd procedure should ! have its own scaling to save the singular values from overflows and ! underflows. that depends on the svd procedure. if ( .not.rowprm ) then - rtmp = stdlib_wlange( 'M', m, n, a, lda, rwork ) + rtmp = stdlib_${ci}$lange( 'M', m, n, a, lda, rwork ) if ( ( rtmp /= rtmp ) .or.( (rtmp*zero) /= zero ) ) then info = -8 call stdlib_xerbla( 'ZGESVDQ', -info ) return end if - if ( rtmp > big / sqrt(real(m,KIND=qp)) ) then + if ( rtmp > big / sqrt(real(m,KIND=${ck}$)) ) then ! .. to prevent overflow in the qr factorization, scale the ! matrix by 1/sqrt(m) if too large entry detected - call stdlib_wlascl('G',0,0, sqrt(real(m,KIND=qp)),one, m,n, a,lda, ierr) + call stdlib_${ci}$lascl('G',0,0, sqrt(real(m,KIND=${ck}$)),one, m,n, a,lda, ierr) ascaled = .true. end if @@ -14806,13 +14808,13 @@ module stdlib_linalg_lapack_w ! All Columns Are Free Columns iwork(p) = 0 end do - call stdlib_wgeqp3( m, n, a, lda, iwork, cwork, cwork(n+1), lcwork-n,rwork, ierr ) + call stdlib_${ci}$geqp3( m, n, a, lda, iwork, cwork, cwork(n+1), lcwork-n,rwork, ierr ) ! if the user requested accuracy level allows truncation in the ! computed upper triangular factor, the matrix r is examined and, ! if possible, replaced with its leading upper trapezoidal part. - epsln = stdlib_qlamch('E') - sfmin = stdlib_qlamch('S') + epsln = stdlib_${c2ri(ci)}$lamch('E') + sfmin = stdlib_${c2ri(ci)}$lamch('S') ! small = sfmin / epsln nr = n if ( accla ) then @@ -14821,7 +14823,7 @@ module stdlib_linalg_lapack_w ! aggressive enforcement of lower numerical rank by introducing a ! backward error of the order of n*eps*||a||_f. nr = 1 - rtmp = sqrt(real(n,KIND=qp))*epsln + rtmp = sqrt(real(n,KIND=${ck}$))*epsln do p = 2, n if ( abs(a(p,p)) < (rtmp*abs(a(1,1))) ) go to 3002 nr = nr + 1 @@ -14830,7 +14832,7 @@ module stdlib_linalg_lapack_w elseif ( acclm ) then ! .. similarly as above, only slightly more gentle (less aggressive). ! sudden drop on the diagonal of r is used as the criterion for being - ! close-to-rank-deficient. the threshold is set to epsln=stdlib_qlamch('e'). + ! close-to-rank-deficient. the threshold is set to epsln=stdlib_${c2ri(ci)}$lamch('e'). ! [[this can be made more flexible by replacing this hard-coded value ! with a user specified threshold.]] also, the values that underflow ! will be truncated. @@ -14856,21 +14858,21 @@ module stdlib_linalg_lapack_w ! estimate the scaled condition number of a. use the fact that it is ! the same as the scaled condition number of r. ! V Is Used As Workspace - call stdlib_wlacpy( 'U', n, n, a, lda, v, ldv ) + call stdlib_${ci}$lacpy( 'U', n, n, a, lda, v, ldv ) ! only the leading nr x nr submatrix of the triangular factor ! is considered. only if nr=n will this give a reliable error ! bound. however, even for nr < n, this can be used on an ! expert level and obtain useful information in the sense of ! perturbation theory. do p = 1, nr - rtmp = stdlib_qznrm2( p, v(1,p), 1 ) - call stdlib_wdscal( p, one/rtmp, v(1,p), 1 ) + rtmp = stdlib_${c2ri(ci)}$znrm2( p, v(1,p), 1 ) + call stdlib_${ci}$dscal( p, one/rtmp, v(1,p), 1 ) end do if ( .not. ( lsvec .or. rsvec ) ) then - call stdlib_wpocon( 'U', nr, v, ldv, one, rtmp,cwork, rwork, ierr ) + call stdlib_${ci}$pocon( 'U', nr, v, ldv, one, rtmp,cwork, rwork, ierr ) else - call stdlib_wpocon( 'U', nr, v, ldv, one, rtmp,cwork(n+1), rwork, ierr ) + call stdlib_${ci}$pocon( 'U', nr, v, ldv, one, rtmp,cwork(n+1), rwork, ierr ) end if sconda = one / sqrt(rtmp) @@ -14901,13 +14903,13 @@ module stdlib_linalg_lapack_w if ( q <= nr ) a(p,q) = czero end do end do - call stdlib_wgesvd( 'N', 'N', n, nr, a, lda, s, u, ldu,v, ldv, cwork, lcwork, & + call stdlib_${ci}$gesvd( 'N', 'N', n, nr, a, lda, s, u, ldu,v, ldv, cwork, lcwork, & rwork, info ) else ! .. compute the singular values of r = [a](1:nr,1:n) - if ( nr > 1 )call stdlib_wlaset( 'L', nr-1,nr-1, czero,czero, a(2,1), lda ) + if ( nr > 1 )call stdlib_${ci}$laset( 'L', nr-1,nr-1, czero,czero, a(2,1), lda ) - call stdlib_wgesvd( 'N', 'N', nr, n, a, lda, s, u, ldu,v, ldv, cwork, lcwork, & + call stdlib_${ci}$gesvd( 'N', 'N', nr, n, a, lda, s, u, ldu,v, ldv, cwork, lcwork, & rwork, info ) end if else if ( lsvec .and. ( .not. rsvec) ) then @@ -14915,7 +14917,7 @@ module stdlib_linalg_lapack_w ! The Singular Values And The Left Singular Vectors Requested ! ......................................................................."""""""" if ( rtrans ) then - ! .. apply stdlib_wgesvd to r**h + ! .. apply stdlib_${ci}$gesvd to r**h ! .. copy r**h into [u] and overwrite [u] with the right singular ! vectors of r do p = 1, nr @@ -14923,12 +14925,12 @@ module stdlib_linalg_lapack_w u(q,p) = conjg(a(p,q)) end do end do - if ( nr > 1 )call stdlib_wlaset( 'U', nr-1,nr-1, czero,czero, u(1,2), ldu ) + if ( nr > 1 )call stdlib_${ci}$laset( 'U', nr-1,nr-1, czero,czero, u(1,2), ldu ) ! .. the left singular vectors not computed, the nr right singular ! vectors overwrite [u](1:nr,1:nr) as conjugate transposed. these ! will be pre-multiplied by q to build the left singular vectors of a. - call stdlib_wgesvd( 'N', 'O', n, nr, u, ldu, s, u, ldu,u, ldu, cwork(n+1), & + call stdlib_${ci}$gesvd( 'N', 'O', n, nr, u, ldu, s, u, ldu,u, ldu, cwork(n+1), & lcwork-n, rwork, info ) do p = 1, nr u(p,p) = conjg(u(p,p)) @@ -14941,12 +14943,12 @@ module stdlib_linalg_lapack_w else ! Apply Stdlib_Zgesvd To R ! .. copy r into [u] and overwrite [u] with the left singular vectors - call stdlib_wlacpy( 'U', nr, n, a, lda, u, ldu ) - if ( nr > 1 )call stdlib_wlaset( 'L', nr-1, nr-1, czero, czero, u(2,1), ldu ) + call stdlib_${ci}$lacpy( 'U', nr, n, a, lda, u, ldu ) + if ( nr > 1 )call stdlib_${ci}$laset( 'L', nr-1, nr-1, czero, czero, u(2,1), ldu ) ! .. the right singular vectors not computed, the nr left singular ! vectors overwrite [u](1:nr,1:nr) - call stdlib_wgesvd( 'O', 'N', nr, n, u, ldu, s, u, ldu,v, ldv, cwork(n+1), & + call stdlib_${ci}$gesvd( 'O', 'N', nr, n, u, ldu, s, u, ldu,v, ldv, cwork(n+1), & lcwork-n, rwork, info ) ! .. now [u](1:nr,1:nr) contains the nr left singular vectors of ! r. these will be pre-multiplied by q to build the left singular @@ -14955,36 +14957,36 @@ module stdlib_linalg_lapack_w ! Assemble The Left Singular Vector Matrix U Of Dimensions ! (m x nr) or (m x n) or (m x m). if ( ( nr < m ) .and. ( .not.wntuf ) ) then - call stdlib_wlaset('A', m-nr, nr, czero, czero, u(nr+1,1), ldu) + call stdlib_${ci}$laset('A', m-nr, nr, czero, czero, u(nr+1,1), ldu) if ( nr < n1 ) then - call stdlib_wlaset( 'A',nr,n1-nr,czero,czero,u(1,nr+1), ldu ) - call stdlib_wlaset( 'A',m-nr,n1-nr,czero,cone,u(nr+1,nr+1), ldu ) + call stdlib_${ci}$laset( 'A',nr,n1-nr,czero,czero,u(1,nr+1), ldu ) + call stdlib_${ci}$laset( 'A',m-nr,n1-nr,czero,cone,u(nr+1,nr+1), ldu ) end if end if ! the q matrix from the first qrf is built into the left singular ! vectors matrix u. - if ( .not.wntuf )call stdlib_wunmqr( 'L', 'N', m, n1, n, a, lda, cwork, u,ldu, & + if ( .not.wntuf )call stdlib_${ci}$unmqr( 'L', 'N', m, n1, n, a, lda, cwork, u,ldu, & cwork(n+1), lcwork-n, ierr ) - if ( rowprm .and. .not.wntuf )call stdlib_wlaswp( n1, u, ldu, 1, m-1, iwork(n+1), -& + if ( rowprm .and. .not.wntuf )call stdlib_${ci}$laswp( n1, u, ldu, 1, m-1, iwork(n+1), -& 1 ) else if ( rsvec .and. ( .not. lsvec ) ) then ! ....................................................................... ! The Singular Values And The Right Singular Vectors Requested ! ....................................................................... if ( rtrans ) then - ! .. apply stdlib_wgesvd to r**h + ! .. apply stdlib_${ci}$gesvd to r**h ! .. copy r**h into v and overwrite v with the left singular vectors do p = 1, nr do q = p, n v(q,p) = conjg(a(p,q)) end do end do - if ( nr > 1 )call stdlib_wlaset( 'U', nr-1,nr-1, czero,czero, v(1,2), ldv ) + if ( nr > 1 )call stdlib_${ci}$laset( 'U', nr-1,nr-1, czero,czero, v(1,2), ldv ) ! .. the left singular vectors of r**h overwrite v, the right singular ! vectors not computed if ( wntvr .or. ( nr == n ) ) then - call stdlib_wgesvd( 'O', 'N', n, nr, v, ldv, s, u, ldu,u, ldu, cwork(n+1), & + call stdlib_${ci}$gesvd( 'O', 'N', n, nr, v, ldv, s, u, ldu,u, ldu, cwork(n+1), & lcwork-n, rwork, info ) do p = 1, nr v(p,p) = conjg(v(p,p)) @@ -15001,15 +15003,15 @@ module stdlib_linalg_lapack_w end do end do end if - call stdlib_wlapmt( .false., nr, n, v, ldv, iwork ) + call stdlib_${ci}$lapmt( .false., nr, n, v, ldv, iwork ) else ! .. need all n right singular vectors and nr < n ! [!] this is simple implementation that augments [v](1:n,1:nr) ! by padding a zero block. in the case nr << n, a more efficient ! way is to first use the qr factorization. for more details ! how to implement this, see the " full svd " branch. - call stdlib_wlaset('G', n, n-nr, czero, czero, v(1,nr+1), ldv) - call stdlib_wgesvd( 'O', 'N', n, n, v, ldv, s, u, ldu,u, ldu, cwork(n+1), & + call stdlib_${ci}$laset('G', n, n-nr, czero, czero, v(1,nr+1), ldv) + call stdlib_${ci}$gesvd( 'O', 'N', n, n, v, ldv, s, u, ldu,u, ldu, cwork(n+1), & lcwork-n, rwork, info ) do p = 1, n v(p,p) = conjg(v(p,p)) @@ -15019,20 +15021,20 @@ module stdlib_linalg_lapack_w v(p,q) = ctmp end do end do - call stdlib_wlapmt( .false., n, n, v, ldv, iwork ) + call stdlib_${ci}$lapmt( .false., n, n, v, ldv, iwork ) end if else ! Aply Stdlib_Zgesvd To R ! Copy R Into V And Overwrite V With The Right Singular Vectors - call stdlib_wlacpy( 'U', nr, n, a, lda, v, ldv ) - if ( nr > 1 )call stdlib_wlaset( 'L', nr-1, nr-1, czero, czero, v(2,1), ldv ) + call stdlib_${ci}$lacpy( 'U', nr, n, a, lda, v, ldv ) + if ( nr > 1 )call stdlib_${ci}$laset( 'L', nr-1, nr-1, czero, czero, v(2,1), ldv ) ! .. the right singular vectors overwrite v, the nr left singular ! vectors stored in u(1:nr,1:nr) if ( wntvr .or. ( nr == n ) ) then - call stdlib_wgesvd( 'N', 'O', nr, n, v, ldv, s, u, ldu,v, ldv, cwork(n+1), & + call stdlib_${ci}$gesvd( 'N', 'O', nr, n, v, ldv, s, u, ldu,v, ldv, cwork(n+1), & lcwork-n, rwork, info ) - call stdlib_wlapmt( .false., nr, n, v, ldv, iwork ) + call stdlib_${ci}$lapmt( .false., nr, n, v, ldv, iwork ) ! .. now [v](1:nr,1:n) contains v(1:n,1:nr)**h else ! .. need all n right singular vectors and nr < n @@ -15040,10 +15042,10 @@ module stdlib_linalg_lapack_w ! by padding a zero block. in the case nr << n, a more efficient ! way is to first use the lq factorization. for more details ! how to implement this, see the " full svd " branch. - call stdlib_wlaset('G', n-nr, n, czero,czero, v(nr+1,1), ldv) - call stdlib_wgesvd( 'N', 'O', n, n, v, ldv, s, u, ldu,v, ldv, cwork(n+1), & + call stdlib_${ci}$laset('G', n-nr, n, czero,czero, v(nr+1,1), ldv) + call stdlib_${ci}$gesvd( 'N', 'O', n, n, v, ldv, s, u, ldu,v, ldv, cwork(n+1), & lcwork-n, rwork, info ) - call stdlib_wlapmt( .false., n, n, v, ldv, iwork ) + call stdlib_${ci}$lapmt( .false., n, n, v, ldv, iwork ) end if ! .. now [v] contains the adjoint of the matrix of the right singular ! vectors of a. @@ -15053,7 +15055,7 @@ module stdlib_linalg_lapack_w ! Full Svd Requested ! ....................................................................... if ( rtrans ) then - ! .. apply stdlib_wgesvd to r**h [[this option is left for r + ! .. apply stdlib_${ci}$gesvd to r**h [[this option is left for r if ( wntvr .or. ( nr == n ) ) then ! .. copy r**h into [v] and overwrite [v] with the left singular ! vectors of r**h @@ -15062,12 +15064,12 @@ module stdlib_linalg_lapack_w v(q,p) = conjg(a(p,q)) end do end do - if ( nr > 1 )call stdlib_wlaset( 'U', nr-1,nr-1, czero,czero, v(1,2), ldv ) + if ( nr > 1 )call stdlib_${ci}$laset( 'U', nr-1,nr-1, czero,czero, v(1,2), ldv ) ! .. the left singular vectors of r**h overwrite [v], the nr right ! singular vectors of r**h stored in [u](1:nr,1:nr) as conjugate ! transposed - call stdlib_wgesvd( 'O', 'A', n, nr, v, ldv, s, v, ldv,u, ldu, cwork(n+1), & + call stdlib_${ci}$gesvd( 'O', 'A', n, nr, v, ldv, s, v, ldv,u, ldu, cwork(n+1), & lcwork-n, rwork, info ) ! Assemble V do p = 1, nr @@ -15085,7 +15087,7 @@ module stdlib_linalg_lapack_w end do end do end if - call stdlib_wlapmt( .false., nr, n, v, ldv, iwork ) + call stdlib_${ci}$lapmt( .false., nr, n, v, ldv, iwork ) do p = 1, nr u(p,p) = conjg(u(p,p)) do q = p + 1, nr @@ -15095,10 +15097,10 @@ module stdlib_linalg_lapack_w end do end do if ( ( nr < m ) .and. .not.(wntuf)) then - call stdlib_wlaset('A', m-nr,nr, czero,czero, u(nr+1,1), ldu) + call stdlib_${ci}$laset('A', m-nr,nr, czero,czero, u(nr+1,1), ldu) if ( nr < n1 ) then - call stdlib_wlaset('A',nr,n1-nr,czero,czero,u(1,nr+1),ldu) - call stdlib_wlaset( 'A',m-nr,n1-nr,czero,cone,u(nr+1,nr+1), ldu ) + call stdlib_${ci}$laset('A',nr,n1-nr,czero,czero,u(1,nr+1),ldu) + call stdlib_${ci}$laset( 'A',m-nr,n1-nr,czero,cone,u(nr+1,nr+1), ldu ) end if end if @@ -15118,10 +15120,10 @@ module stdlib_linalg_lapack_w v(q,p) = conjg(a(p,q)) end do end do - if ( nr > 1 )call stdlib_wlaset('U',nr-1,nr-1, czero,czero, v(1,2),ldv) + if ( nr > 1 )call stdlib_${ci}$laset('U',nr-1,nr-1, czero,czero, v(1,2),ldv) - call stdlib_wlaset('A',n,n-nr,czero,czero,v(1,nr+1),ldv) - call stdlib_wgesvd( 'O', 'A', n, n, v, ldv, s, v, ldv,u, ldu, cwork(n+1), & + call stdlib_${ci}$laset('A',n,n-nr,czero,czero,v(1,nr+1),ldv) + call stdlib_${ci}$gesvd( 'O', 'A', n, n, v, ldv, s, v, ldv,u, ldu, cwork(n+1), & lcwork-n, rwork, info ) do p = 1, n v(p,p) = conjg(v(p,p)) @@ -15131,7 +15133,7 @@ module stdlib_linalg_lapack_w v(p,q) = ctmp end do end do - call stdlib_wlapmt( .false., n, n, v, ldv, iwork ) + call stdlib_${ci}$lapmt( .false., n, n, v, ldv, iwork ) ! Assemble The Left Singular Vector Matrix U Of Dimensions ! (m x n1), i.e. (m x n) or (m x m). do p = 1, n @@ -15143,10 +15145,10 @@ module stdlib_linalg_lapack_w end do end do if ( ( n < m ) .and. .not.(wntuf)) then - call stdlib_wlaset('A',m-n,n,czero,czero,u(n+1,1),ldu) + call stdlib_${ci}$laset('A',m-n,n,czero,czero,u(n+1,1),ldu) if ( n < n1 ) then - call stdlib_wlaset('A',n,n1-n,czero,czero,u(1,n+1),ldu) - call stdlib_wlaset('A',m-n,n1-n,czero,cone,u(n+1,n+1), ldu ) + call stdlib_${ci}$laset('A',n,n1-n,czero,czero,u(1,n+1),ldu) + call stdlib_${ci}$laset('A',m-n,n1-n,czero,cone,u(n+1,n+1), ldu ) end if end if else @@ -15157,55 +15159,55 @@ module stdlib_linalg_lapack_w u(q,nr+p) = conjg(a(p,q)) end do end do - if ( nr > 1 )call stdlib_wlaset('U',nr-1,nr-1,czero,czero,u(1,nr+2),ldu) + if ( nr > 1 )call stdlib_${ci}$laset('U',nr-1,nr-1,czero,czero,u(1,nr+2),ldu) - call stdlib_wgeqrf( n, nr, u(1,nr+1), ldu, cwork(n+1),cwork(n+nr+1), & + call stdlib_${ci}$geqrf( n, nr, u(1,nr+1), ldu, cwork(n+1),cwork(n+nr+1), & lcwork-n-nr, ierr ) do p = 1, nr do q = 1, n v(q,p) = conjg(u(p,nr+q)) end do end do - if (nr>1) call stdlib_wlaset('U',nr-1,nr-1,czero,czero,v(1,2),ldv) - call stdlib_wgesvd( 'S', 'O', nr, nr, v, ldv, s, u, ldu,v,ldv, cwork(n+nr+& + if (nr>1) call stdlib_${ci}$laset('U',nr-1,nr-1,czero,czero,v(1,2),ldv) + call stdlib_${ci}$gesvd( 'S', 'O', nr, nr, v, ldv, s, u, ldu,v,ldv, cwork(n+nr+& 1),lcwork-n-nr,rwork, info ) - call stdlib_wlaset('A',n-nr,nr,czero,czero,v(nr+1,1),ldv) - call stdlib_wlaset('A',nr,n-nr,czero,czero,v(1,nr+1),ldv) - call stdlib_wlaset('A',n-nr,n-nr,czero,cone,v(nr+1,nr+1),ldv) - call stdlib_wunmqr('R','C', n, n, nr, u(1,nr+1), ldu,cwork(n+1),v,ldv,& + call stdlib_${ci}$laset('A',n-nr,nr,czero,czero,v(nr+1,1),ldv) + call stdlib_${ci}$laset('A',nr,n-nr,czero,czero,v(1,nr+1),ldv) + call stdlib_${ci}$laset('A',n-nr,n-nr,czero,cone,v(nr+1,nr+1),ldv) + call stdlib_${ci}$unmqr('R','C', n, n, nr, u(1,nr+1), ldu,cwork(n+1),v,ldv,& cwork(n+nr+1),lcwork-n-nr,ierr) - call stdlib_wlapmt( .false., n, n, v, ldv, iwork ) + call stdlib_${ci}$lapmt( .false., n, n, v, ldv, iwork ) ! Assemble The Left Singular Vector Matrix U Of Dimensions ! (m x nr) or (m x n) or (m x m). if ( ( nr < m ) .and. .not.(wntuf)) then - call stdlib_wlaset('A',m-nr,nr,czero,czero,u(nr+1,1),ldu) + call stdlib_${ci}$laset('A',m-nr,nr,czero,czero,u(nr+1,1),ldu) if ( nr < n1 ) then - call stdlib_wlaset('A',nr,n1-nr,czero,czero,u(1,nr+1),ldu) - call stdlib_wlaset( 'A',m-nr,n1-nr,czero,cone,u(nr+1,nr+1),ldu) + call stdlib_${ci}$laset('A',nr,n1-nr,czero,czero,u(1,nr+1),ldu) + call stdlib_${ci}$laset( 'A',m-nr,n1-nr,czero,cone,u(nr+1,nr+1),ldu) end if end if end if end if else - ! .. apply stdlib_wgesvd to r [[this is the recommended option]] + ! .. apply stdlib_${ci}$gesvd to r [[this is the recommended option]] if ( wntvr .or. ( nr == n ) ) then ! .. copy r into [v] and overwrite v with the right singular vectors - call stdlib_wlacpy( 'U', nr, n, a, lda, v, ldv ) - if ( nr > 1 )call stdlib_wlaset( 'L', nr-1,nr-1, czero,czero, v(2,1), ldv ) + call stdlib_${ci}$lacpy( 'U', nr, n, a, lda, v, ldv ) + if ( nr > 1 )call stdlib_${ci}$laset( 'L', nr-1,nr-1, czero,czero, v(2,1), ldv ) ! .. the right singular vectors of r overwrite [v], the nr left ! singular vectors of r stored in [u](1:nr,1:nr) - call stdlib_wgesvd( 'S', 'O', nr, n, v, ldv, s, u, ldu,v, ldv, cwork(n+1), & + call stdlib_${ci}$gesvd( 'S', 'O', nr, n, v, ldv, s, u, ldu,v, ldv, cwork(n+1), & lcwork-n, rwork, info ) - call stdlib_wlapmt( .false., nr, n, v, ldv, iwork ) + call stdlib_${ci}$lapmt( .false., nr, n, v, ldv, iwork ) ! .. now [v](1:nr,1:n) contains v(1:n,1:nr)**h ! Assemble The Left Singular Vector Matrix U Of Dimensions ! (m x nr) or (m x n) or (m x m). if ( ( nr < m ) .and. .not.(wntuf)) then - call stdlib_wlaset('A', m-nr,nr, czero,czero, u(nr+1,1), ldu) + call stdlib_${ci}$laset('A', m-nr,nr, czero,czero, u(nr+1,1), ldu) if ( nr < n1 ) then - call stdlib_wlaset('A',nr,n1-nr,czero,czero,u(1,nr+1),ldu) - call stdlib_wlaset( 'A',m-nr,n1-nr,czero,cone,u(nr+1,nr+1), ldu ) + call stdlib_${ci}$laset('A',nr,n1-nr,czero,czero,u(1,nr+1),ldu) + call stdlib_${ci}$laset( 'A',m-nr,n1-nr,czero,cone,u(nr+1,nr+1), ldu ) end if end if @@ -15220,51 +15222,51 @@ module stdlib_linalg_lapack_w ! optratio = max( optratio, 2 ) optratio = 2 if ( optratio * nr > n ) then - call stdlib_wlacpy( 'U', nr, n, a, lda, v, ldv ) - if ( nr > 1 )call stdlib_wlaset('L', nr-1,nr-1, czero,czero, v(2,1),ldv) + call stdlib_${ci}$lacpy( 'U', nr, n, a, lda, v, ldv ) + if ( nr > 1 )call stdlib_${ci}$laset('L', nr-1,nr-1, czero,czero, v(2,1),ldv) ! .. the right singular vectors of r overwrite [v], the nr left ! singular vectors of r stored in [u](1:nr,1:nr) - call stdlib_wlaset('A', n-nr,n, czero,czero, v(nr+1,1),ldv) - call stdlib_wgesvd( 'S', 'O', n, n, v, ldv, s, u, ldu,v, ldv, cwork(n+1), & + call stdlib_${ci}$laset('A', n-nr,n, czero,czero, v(nr+1,1),ldv) + call stdlib_${ci}$gesvd( 'S', 'O', n, n, v, ldv, s, u, ldu,v, ldv, cwork(n+1), & lcwork-n, rwork, info ) - call stdlib_wlapmt( .false., n, n, v, ldv, iwork ) + call stdlib_${ci}$lapmt( .false., n, n, v, ldv, iwork ) ! .. now [v] contains the adjoint of the matrix of the right ! singular vectors of a. the leading n left singular vectors ! are in [u](1:n,1:n) ! Assemble The Left Singular Vector Matrix U Of Dimensions ! (m x n1), i.e. (m x n) or (m x m). if ( ( n < m ) .and. .not.(wntuf)) then - call stdlib_wlaset('A',m-n,n,czero,czero,u(n+1,1),ldu) + call stdlib_${ci}$laset('A',m-n,n,czero,czero,u(n+1,1),ldu) if ( n < n1 ) then - call stdlib_wlaset('A',n,n1-n,czero,czero,u(1,n+1),ldu) - call stdlib_wlaset( 'A',m-n,n1-n,czero,cone,u(n+1,n+1), ldu ) + call stdlib_${ci}$laset('A',n,n1-n,czero,czero,u(1,n+1),ldu) + call stdlib_${ci}$laset( 'A',m-n,n1-n,czero,cone,u(n+1,n+1), ldu ) end if end if else - call stdlib_wlacpy( 'U', nr, n, a, lda, u(nr+1,1), ldu ) - if ( nr > 1 )call stdlib_wlaset('L',nr-1,nr-1,czero,czero,u(nr+2,1),ldu) + call stdlib_${ci}$lacpy( 'U', nr, n, a, lda, u(nr+1,1), ldu ) + if ( nr > 1 )call stdlib_${ci}$laset('L',nr-1,nr-1,czero,czero,u(nr+2,1),ldu) - call stdlib_wgelqf( nr, n, u(nr+1,1), ldu, cwork(n+1),cwork(n+nr+1), & + call stdlib_${ci}$gelqf( nr, n, u(nr+1,1), ldu, cwork(n+1),cwork(n+nr+1), & lcwork-n-nr, ierr ) - call stdlib_wlacpy('L',nr,nr,u(nr+1,1),ldu,v,ldv) - if ( nr > 1 )call stdlib_wlaset('U',nr-1,nr-1,czero,czero,v(1,2),ldv) + call stdlib_${ci}$lacpy('L',nr,nr,u(nr+1,1),ldu,v,ldv) + if ( nr > 1 )call stdlib_${ci}$laset('U',nr-1,nr-1,czero,czero,v(1,2),ldv) - call stdlib_wgesvd( 'S', 'O', nr, nr, v, ldv, s, u, ldu,v, ldv, cwork(n+nr+& + call stdlib_${ci}$gesvd( 'S', 'O', nr, nr, v, ldv, s, u, ldu,v, ldv, cwork(n+nr+& 1), lcwork-n-nr, rwork, info ) - call stdlib_wlaset('A',n-nr,nr,czero,czero,v(nr+1,1),ldv) - call stdlib_wlaset('A',nr,n-nr,czero,czero,v(1,nr+1),ldv) - call stdlib_wlaset('A',n-nr,n-nr,czero,cone,v(nr+1,nr+1),ldv) - call stdlib_wunmlq('R','N',n,n,nr,u(nr+1,1),ldu,cwork(n+1),v, ldv, cwork(n+& + call stdlib_${ci}$laset('A',n-nr,nr,czero,czero,v(nr+1,1),ldv) + call stdlib_${ci}$laset('A',nr,n-nr,czero,czero,v(1,nr+1),ldv) + call stdlib_${ci}$laset('A',n-nr,n-nr,czero,cone,v(nr+1,nr+1),ldv) + call stdlib_${ci}$unmlq('R','N',n,n,nr,u(nr+1,1),ldu,cwork(n+1),v, ldv, cwork(n+& nr+1),lcwork-n-nr,ierr) - call stdlib_wlapmt( .false., n, n, v, ldv, iwork ) + call stdlib_${ci}$lapmt( .false., n, n, v, ldv, iwork ) ! Assemble The Left Singular Vector Matrix U Of Dimensions ! (m x nr) or (m x n) or (m x m). if ( ( nr < m ) .and. .not.(wntuf)) then - call stdlib_wlaset('A',m-nr,nr,czero,czero,u(nr+1,1),ldu) + call stdlib_${ci}$laset('A',m-nr,nr,czero,czero,u(nr+1,1),ldu) if ( nr < n1 ) then - call stdlib_wlaset('A',nr,n1-nr,czero,czero,u(1,nr+1),ldu) - call stdlib_wlaset( 'A',m-nr,n1-nr,czero,cone,u(nr+1,nr+1), ldu ) + call stdlib_${ci}$laset('A',nr,n1-nr,czero,czero,u(1,nr+1),ldu) + call stdlib_${ci}$laset( 'A',m-nr,n1-nr,czero,cone,u(nr+1,nr+1), ldu ) end if end if @@ -15274,9 +15276,9 @@ module stdlib_linalg_lapack_w end if ! the q matrix from the first qrf is built into the left singular ! vectors matrix u. - if ( .not. wntuf )call stdlib_wunmqr( 'L', 'N', m, n1, n, a, lda, cwork, u,ldu, & + if ( .not. wntuf )call stdlib_${ci}$unmqr( 'L', 'N', m, n1, n, a, lda, cwork, u,ldu, & cwork(n+1), lcwork-n, ierr ) - if ( rowprm .and. .not.wntuf )call stdlib_wlaswp( n1, u, ldu, 1, m-1, iwork(n+1), -& + if ( rowprm .and. .not.wntuf )call stdlib_${ci}$laswp( n1, u, ldu, 1, m-1, iwork(n+1), -& 1 ) ! ... end of the "full svd" branch end if @@ -15290,22 +15292,22 @@ module stdlib_linalg_lapack_w 4002 continue ! .. if numerical rank deficiency is detected, the truncated ! singular values are set to zero. - if ( nr < n ) call stdlib_qlaset( 'G', n-nr,1, zero,zero, s(nr+1), n ) + if ( nr < n ) call stdlib_${c2ri(ci)}$laset( 'G', n-nr,1, zero,zero, s(nr+1), n ) ! .. undo scaling; this may cause overflow in the largest singular ! values. - if ( ascaled )call stdlib_qlascl( 'G',0,0, one,sqrt(real(m,KIND=qp)), nr,1, s, n, ierr & + if ( ascaled )call stdlib_${c2ri(ci)}$lascl( 'G',0,0, one,sqrt(real(m,KIND=${ck}$)), nr,1, s, n, ierr & ) if ( conda ) rwork(1) = sconda rwork(2) = p - nr ! .. p-nr is the number of singular values that are computed as - ! exact zeros in stdlib_wgesvd() applied to the (possibly truncated) + ! exact zeros in stdlib_${ci}$gesvd() applied to the (possibly truncated) ! full row rank triangular (trapezoidal) factor of a. numrank = nr return - end subroutine stdlib_wgesvdq + end subroutine stdlib_${ci}$gesvdq - pure subroutine stdlib_wgesvj( joba, jobu, jobv, m, n, a, lda, sva, mv, v,ldv, cwork, lwork, & + pure subroutine stdlib_${ci}$gesvj( joba, jobu, jobv, m, n, a, lda, sva, mv, v,ldv, cwork, lwork, & !! ZGESVJ: computes the singular value decomposition (SVD) of a complex !! M-by-N matrix A, where M >= N. The SVD of A is written as !! [++] [xx] [x0] [xx] @@ -15324,9 +15326,9 @@ module stdlib_linalg_lapack_w integer(ilp), intent(in) :: lda, ldv, lwork, lrwork, m, mv, n character, intent(in) :: joba, jobu, jobv ! Array Arguments - complex(qp), intent(inout) :: a(lda,*), v(ldv,*), cwork(lwork) - real(qp), intent(inout) :: rwork(lrwork) - real(qp), intent(out) :: sva(n) + complex(${ck}$), intent(inout) :: a(lda,*), v(ldv,*), cwork(lwork) + real(${ck}$), intent(inout) :: rwork(lrwork) + real(${ck}$), intent(out) :: sva(n) ! ===================================================================== ! Local Parameters integer(ilp), parameter :: nsweep = 30 @@ -15334,8 +15336,8 @@ module stdlib_linalg_lapack_w ! Local Scalars - complex(qp) :: aapq, ompq - real(qp) :: aapp, aapp0, aapq1, aaqq, apoaq, aqoap, big, bigtheta, cs, ctol, epsln, & + complex(${ck}$) :: aapq, ompq + real(${ck}$) :: aapp, aapp0, aapq1, aaqq, apoaq, aqoap, big, bigtheta, cs, ctol, epsln, & mxaapq, mxsinj, rootbig, rooteps, rootsfmin, roottol, skl, sfmin, small, sn, t, temp1, & theta, thsign, tol integer(ilp) :: blskip, emptsw, i, ibr, ierr, igl, ijblsk, ir1, iswrot, jbc, jgl, kbl, & @@ -15401,26 +15403,26 @@ module stdlib_linalg_lapack_w else ! ... default if( lsvec .or. rsvec .or. applv ) then - ctol = sqrt( real( m,KIND=qp) ) + ctol = sqrt( real( m,KIND=${ck}$) ) else - ctol = real( m,KIND=qp) + ctol = real( m,KIND=${ck}$) end if end if ! ... and the machine dependent parameters are ! [!] (make sure that stdlib_dlamch() works properly on the target machine.) - epsln = stdlib_qlamch( 'EPSILON' ) + epsln = stdlib_${c2ri(ci)}$lamch( 'EPSILON' ) rooteps = sqrt( epsln ) - sfmin = stdlib_qlamch( 'SAFEMINIMUM' ) + sfmin = stdlib_${c2ri(ci)}$lamch( 'SAFEMINIMUM' ) rootsfmin = sqrt( sfmin ) small = sfmin / epsln - big = stdlib_qlamch( 'OVERFLOW' ) + big = stdlib_${c2ri(ci)}$lamch( 'OVERFLOW' ) ! big = one / sfmin rootbig = one / rootsfmin - ! large = big / sqrt( real( m*n,KIND=qp) ) + ! large = big / sqrt( real( m*n,KIND=${ck}$) ) bigtheta = one / rooteps tol = ctol*epsln roottol = sqrt( tol ) - if( real( m,KIND=qp)*epsln>=one ) then + if( real( m,KIND=${ck}$)*epsln>=one ) then info = -4 call stdlib_xerbla( 'ZGESVJ', -info ) return @@ -15428,7 +15430,7 @@ module stdlib_linalg_lapack_w ! initialize the right singular vector matrix. if( rsvec ) then mvl = n - call stdlib_wlaset( 'A', mvl, n, czero, cone, v, ldv ) + call stdlib_${ci}$laset( 'A', mvl, n, czero, cone, v, ldv ) else if( applv ) then mvl = mv end if @@ -15441,7 +15443,7 @@ module stdlib_linalg_lapack_w ! goal is to make sure that no column norm overflows, and that ! sqrt(n)*max_i sva(i) does not overflow. if infinite entries ! in a are detected, the procedure returns with info=-6. - skl = one / sqrt( real( m,KIND=qp)*real( n,KIND=qp) ) + skl = one / sqrt( real( m,KIND=${ck}$)*real( n,KIND=${ck}$) ) noscale = .true. goscale = .true. if( lower ) then @@ -15449,7 +15451,7 @@ module stdlib_linalg_lapack_w do p = 1, n aapp = zero aaqq = one - call stdlib_wlassq( m-p+1, a( p, p ), 1, aapp, aaqq ) + call stdlib_${ci}$lassq( m-p+1, a( p, p ), 1, aapp, aaqq ) if( aapp>big ) then info = -6 call stdlib_xerbla( 'ZGESVJ', -info ) @@ -15474,7 +15476,7 @@ module stdlib_linalg_lapack_w do p = 1, n aapp = zero aaqq = one - call stdlib_wlassq( p, a( 1, p ), 1, aapp, aaqq ) + call stdlib_${ci}$lassq( p, a( 1, p ), 1, aapp, aaqq ) if( aapp>big ) then info = -6 call stdlib_xerbla( 'ZGESVJ', -info ) @@ -15499,7 +15501,7 @@ module stdlib_linalg_lapack_w do p = 1, n aapp = zero aaqq = one - call stdlib_wlassq( m, a( 1, p ), 1, aapp, aaqq ) + call stdlib_${ci}$lassq( m, a( 1, p ), 1, aapp, aaqq ) if( aapp>big ) then info = -6 call stdlib_xerbla( 'ZGESVJ', -info ) @@ -15532,7 +15534,7 @@ module stdlib_linalg_lapack_w end do ! #:) quick return for zero matrix if( aapp==zero ) then - if( lsvec )call stdlib_wlaset( 'G', m, n, czero, cone, a, lda ) + if( lsvec )call stdlib_${ci}$laset( 'G', m, n, czero, cone, a, lda ) rwork( 1 ) = one rwork( 2 ) = zero rwork( 3 ) = zero @@ -15543,7 +15545,7 @@ module stdlib_linalg_lapack_w end if ! #:) quick return for one-column matrix if( n==1 ) then - if( lsvec )call stdlib_wlascl( 'G', 0, 0, sva( 1 ), skl, m, 1,a( 1, 1 ), lda, ierr ) + if( lsvec )call stdlib_${ci}$lascl( 'G', 0, 0, sva( 1 ), skl, m, 1,a( 1, 1 ), lda, ierr ) rwork( 1 ) = one / skl if( sva( 1 )>=sfmin ) then @@ -15560,14 +15562,14 @@ module stdlib_linalg_lapack_w ! protect small singular values from underflow, and try to ! avoid underflows/overflows in computing jacobi rotations. sn = sqrt( sfmin / epsln ) - temp1 = sqrt( big / real( n,KIND=qp) ) + temp1 = sqrt( big / real( n,KIND=${ck}$) ) if( ( aapp<=sn ) .or. ( aaqq>=temp1 ) .or.( ( sn<=aaqq ) .and. ( aapp<=temp1 ) ) ) & then temp1 = min( big, temp1 / aapp ) ! aaqq = aaqq*temp1 ! aapp = aapp*temp1 else if( ( aaqq<=sn ) .and. ( aapp<=temp1 ) ) then - temp1 = min( sn / aaqq, big / (aapp*sqrt( real(n,KIND=qp)) ) ) + temp1 = min( sn / aaqq, big / (aapp*sqrt( real(n,KIND=${ck}$)) ) ) ! aaqq = aaqq*temp1 ! aapp = aapp*temp1 else if( ( aaqq>=sn ) .and. ( aapp>=temp1 ) ) then @@ -15575,7 +15577,7 @@ module stdlib_linalg_lapack_w ! aaqq = aaqq*temp1 ! aapp = aapp*temp1 else if( ( aaqq<=sn ) .and. ( aapp>=temp1 ) ) then - temp1 = min( sn / aaqq, big / ( sqrt( real( n,KIND=qp) )*aapp ) ) + temp1 = min( sn / aaqq, big / ( sqrt( real( n,KIND=${ck}$) )*aapp ) ) ! aaqq = aaqq*temp1 ! aapp = aapp*temp1 else @@ -15583,11 +15585,11 @@ module stdlib_linalg_lapack_w end if ! scale, if necessary if( temp1/=one ) then - call stdlib_qlascl( 'G', 0, 0, one, temp1, n, 1, sva, n, ierr ) + call stdlib_${c2ri(ci)}$lascl( 'G', 0, 0, one, temp1, n, 1, sva, n, ierr ) end if skl = temp1*skl if( skl/=one ) then - call stdlib_wlascl( joba, 0, 0, one, skl, m, n, a, lda, ierr ) + call stdlib_${ci}$lascl( joba, 0, 0, one, skl, m, n, a, lda, ierr ) skl = one / skl end if ! row-cyclic jacobi svd algorithm with column pivoting @@ -15598,8 +15600,8 @@ module stdlib_linalg_lapack_w end do swband = 3 ! [tp] swband is a tuning parameter [tp]. it is meaningful and effective - ! if stdlib_wgesvj is used as a computational routine in the preconditioned - ! jacobi svd algorithm stdlib_wgejsv. for sweeps i=1:swband the procedure + ! if stdlib_${ci}$gesvj is used as a computational routine in the preconditioned + ! jacobi svd algorithm stdlib_${ci}$gejsv. for sweeps i=1:swband the procedure ! works on pivots inside a band-like region around the diagonal. ! the boundaries are determined dynamically, based on the number of ! pivots above a threshold. @@ -15639,31 +15641,31 @@ module stdlib_linalg_lapack_w ! [+ + 0 0] [0 0] ! [+ + x 0] actually work on [x 0] [x 0] ! [+ + x x] [x x]. [x x] - call stdlib_wgsvj0( jobv, m-n34, n-n34, a( n34+1, n34+1 ), lda,cwork( n34+1 ), & + call stdlib_${ci}$gsvj0( jobv, m-n34, n-n34, a( n34+1, n34+1 ), lda,cwork( n34+1 ), & sva( n34+1 ), mvl,v( n34*q+1, n34+1 ), ldv, epsln, sfmin, tol,2, cwork( n+1 ), & lwork-n, ierr ) - call stdlib_wgsvj0( jobv, m-n2, n34-n2, a( n2+1, n2+1 ), lda,cwork( n2+1 ), sva( & + call stdlib_${ci}$gsvj0( jobv, m-n2, n34-n2, a( n2+1, n2+1 ), lda,cwork( n2+1 ), sva( & n2+1 ), mvl,v( n2*q+1, n2+1 ), ldv, epsln, sfmin, tol, 2,cwork( n+1 ), lwork-n, & ierr ) - call stdlib_wgsvj1( jobv, m-n2, n-n2, n4, a( n2+1, n2+1 ), lda,cwork( n2+1 ), & + call stdlib_${ci}$gsvj1( jobv, m-n2, n-n2, n4, a( n2+1, n2+1 ), lda,cwork( n2+1 ), & sva( n2+1 ), mvl,v( n2*q+1, n2+1 ), ldv, epsln, sfmin, tol, 1,cwork( n+1 ), & lwork-n, ierr ) - call stdlib_wgsvj0( jobv, m-n4, n2-n4, a( n4+1, n4+1 ), lda,cwork( n4+1 ), sva( & + call stdlib_${ci}$gsvj0( jobv, m-n4, n2-n4, a( n4+1, n4+1 ), lda,cwork( n4+1 ), sva( & n4+1 ), mvl,v( n4*q+1, n4+1 ), ldv, epsln, sfmin, tol, 1,cwork( n+1 ), lwork-n, & ierr ) - call stdlib_wgsvj0( jobv, m, n4, a, lda, cwork, sva, mvl, v, ldv,epsln, sfmin, & + call stdlib_${ci}$gsvj0( jobv, m, n4, a, lda, cwork, sva, mvl, v, ldv,epsln, sfmin, & tol, 1, cwork( n+1 ), lwork-n,ierr ) - call stdlib_wgsvj1( jobv, m, n2, n4, a, lda, cwork, sva, mvl, v,ldv, epsln, & + call stdlib_${ci}$gsvj1( jobv, m, n2, n4, a, lda, cwork, sva, mvl, v,ldv, epsln, & sfmin, tol, 1, cwork( n+1 ),lwork-n, ierr ) else if( upper ) then - call stdlib_wgsvj0( jobv, n4, n4, a, lda, cwork, sva, mvl, v, ldv,epsln, sfmin, & + call stdlib_${ci}$gsvj0( jobv, n4, n4, a, lda, cwork, sva, mvl, v, ldv,epsln, sfmin, & tol, 2, cwork( n+1 ), lwork-n,ierr ) - call stdlib_wgsvj0( jobv, n2, n4, a( 1, n4+1 ), lda, cwork( n4+1 ),sva( n4+1 ), & + call stdlib_${ci}$gsvj0( jobv, n2, n4, a( 1, n4+1 ), lda, cwork( n4+1 ),sva( n4+1 ), & mvl, v( n4*q+1, n4+1 ), ldv,epsln, sfmin, tol, 1, cwork( n+1 ), lwork-n,ierr ) - call stdlib_wgsvj1( jobv, n2, n2, n4, a, lda, cwork, sva, mvl, v,ldv, epsln, & + call stdlib_${ci}$gsvj1( jobv, n2, n2, n4, a, lda, cwork, sva, mvl, v,ldv, epsln, & sfmin, tol, 1, cwork( n+1 ),lwork-n, ierr ) - call stdlib_wgsvj0( jobv, n2+n4, n4, a( 1, n2+1 ), lda,cwork( n2+1 ), sva( n2+1 )& + call stdlib_${ci}$gsvj0( jobv, n2+n4, n4, a( 1, n2+1 ), lda,cwork( n2+1 ), sva( n2+1 )& , mvl,v( n2*q+1, n2+1 ), ldv, epsln, sfmin, tol, 1,cwork( n+1 ), lwork-n, ierr ) end if @@ -15686,10 +15688,10 @@ module stdlib_linalg_lapack_w igl = igl + ir1*kbl loop_2001: do p = igl, min( igl+kbl-1, n-1 ) ! .. de rijk's pivoting - q = stdlib_iqamax( n-p+1, sva( p ), 1 ) + p - 1 + q = stdlib_i${c2ri(ci)}$amax( n-p+1, sva( p ), 1 ) + p - 1 if( p/=q ) then - call stdlib_wswap( m, a( 1, p ), 1, a( 1, q ), 1 ) - if( rsvec )call stdlib_wswap( mvl, v( 1, p ), 1,v( 1, q ), 1 ) + call stdlib_${ci}$swap( m, a( 1, p ), 1, a( 1, q ), 1 ) + if( rsvec )call stdlib_${ci}$swap( mvl, v( 1, p ), 1,v( 1, q ), 1 ) temp1 = sva( p ) sva( p ) = sva( q ) sva( q ) = temp1 @@ -15701,20 +15703,20 @@ module stdlib_linalg_lapack_w ! column norms are periodically updated by explicit ! norm computation. ! [!] caveat: - ! unfortunately, some blas implementations compute stdlib_qznrm2(m,a(1,p),1) + ! unfortunately, some blas implementations compute stdlib_${c2ri(ci)}$znrm2(m,a(1,p),1) ! as sqrt(s=stdlib_zdotc(m,a(1,p),1,a(1,p),1)), which may cause the result to ! overflow for ||a(:,p)||_2 > sqrt(overflow_threshold), and to ! underflow for ||a(:,p)||_2 < sqrt(underflow_threshold). - ! hence, stdlib_qznrm2 cannot be trusted, not even in the case when + ! hence, stdlib_${c2ri(ci)}$znrm2 cannot be trusted, not even in the case when ! the true norm is far from the under(over)flow boundaries. ! if properly implemented stdlib_dcnrm2 is available, the if-then-else-end if - ! below should be replaced with "aapp = stdlib_qznrm2( m, a(1,p), 1 )". + ! below should be replaced with "aapp = stdlib_${c2ri(ci)}$znrm2( m, a(1,p), 1 )". if( ( sva( p )rootsfmin ) ) then - sva( p ) = stdlib_qznrm2( m, a( 1, p ), 1 ) + sva( p ) = stdlib_${c2ri(ci)}$znrm2( m, a( 1, p ), 1 ) else temp1 = zero aapp = one - call stdlib_wlassq( m, a( 1, p ), 1, temp1, aapp ) + call stdlib_${ci}$lassq( m, a( 1, p ), 1, temp1, aapp ) sva( p ) = temp1*sqrt( aapp ) end if aapp = sva( p ) @@ -15730,25 +15732,25 @@ module stdlib_linalg_lapack_w if( aaqq>=one ) then rotok = ( small*aapp )<=aaqq if( aapp<( big / aaqq ) ) then - aapq = ( stdlib_wdotc( m, a( 1, p ), 1,a( 1, q ), 1 ) / & + aapq = ( stdlib_${ci}$dotc( m, a( 1, p ), 1,a( 1, q ), 1 ) / & aaqq ) / aapp else - call stdlib_wcopy( m, a( 1, p ), 1,cwork(n+1), 1 ) - call stdlib_wlascl( 'G', 0, 0, aapp, one,m, 1, cwork(n+1), & + call stdlib_${ci}$copy( m, a( 1, p ), 1,cwork(n+1), 1 ) + call stdlib_${ci}$lascl( 'G', 0, 0, aapp, one,m, 1, cwork(n+1), & lda, ierr ) - aapq = stdlib_wdotc( m, cwork(n+1), 1,a( 1, q ), 1 ) / & + aapq = stdlib_${ci}$dotc( m, cwork(n+1), 1,a( 1, q ), 1 ) / & aaqq end if else rotok = aapp<=( aaqq / small ) if( aapp>( small / aaqq ) ) then - aapq = ( stdlib_wdotc( m, a( 1, p ), 1,a( 1, q ), 1 ) / & + aapq = ( stdlib_${ci}$dotc( m, a( 1, p ), 1,a( 1, q ), 1 ) / & aapp ) / aaqq else - call stdlib_wcopy( m, a( 1, q ), 1,cwork(n+1), 1 ) - call stdlib_wlascl( 'G', 0, 0, aaqq,one, m, 1,cwork(n+1), & + call stdlib_${ci}$copy( m, a( 1, q ), 1,cwork(n+1), 1 ) + call stdlib_${ci}$lascl( 'G', 0, 0, aaqq,one, m, 1,cwork(n+1), & lda, ierr ) - aapq = stdlib_wdotc( m, a(1, p ), 1,cwork(n+1), 1 ) / & + aapq = stdlib_${ci}$dotc( m, a(1, p ), 1,cwork(n+1), 1 ) / & aapp end if end if @@ -15772,10 +15774,10 @@ module stdlib_linalg_lapack_w if( abs( theta )>bigtheta ) then t = half / theta cs = one - call stdlib_wrot( m, a(1,p), 1, a(1,q), 1,cs, conjg(ompq)& + call stdlib_${ci}$rot( m, a(1,p), 1, a(1,q), 1,cs, conjg(ompq)& *t ) if ( rsvec ) then - call stdlib_wrot( mvl, v(1,p), 1,v(1,q), 1, cs, & + call stdlib_${ci}$rot( mvl, v(1,p), 1,v(1,q), 1, cs, & conjg(ompq)*t ) end if sva( q ) = aaqq*sqrt( max( zero,one+t*apoaq*aapq1 ) ) @@ -15793,24 +15795,24 @@ module stdlib_linalg_lapack_w sva( q ) = aaqq*sqrt( max( zero,one+t*apoaq*aapq1 ) ) aapp = aapp*sqrt( max( zero,one-t*aqoap*aapq1 ) ) - call stdlib_wrot( m, a(1,p), 1, a(1,q), 1,cs, conjg(ompq)& + call stdlib_${ci}$rot( m, a(1,p), 1, a(1,q), 1,cs, conjg(ompq)& *sn ) if ( rsvec ) then - call stdlib_wrot( mvl, v(1,p), 1,v(1,q), 1, cs, & + call stdlib_${ci}$rot( mvl, v(1,p), 1,v(1,q), 1, cs, & conjg(ompq)*sn ) end if end if cwork(p) = -cwork(q) * ompq else ! .. have to use modified gram-schmidt like transformation - call stdlib_wcopy( m, a( 1, p ), 1,cwork(n+1), 1 ) - call stdlib_wlascl( 'G', 0, 0, aapp, one, m,1, cwork(n+1), & + call stdlib_${ci}$copy( m, a( 1, p ), 1,cwork(n+1), 1 ) + call stdlib_${ci}$lascl( 'G', 0, 0, aapp, one, m,1, cwork(n+1), & lda,ierr ) - call stdlib_wlascl( 'G', 0, 0, aaqq, one, m,1, a( 1, q ), & + call stdlib_${ci}$lascl( 'G', 0, 0, aaqq, one, m,1, a( 1, q ), & lda, ierr ) - call stdlib_waxpy( m, -aapq, cwork(n+1), 1,a( 1, q ), 1 ) + call stdlib_${ci}$axpy( m, -aapq, cwork(n+1), 1,a( 1, q ), 1 ) - call stdlib_wlascl( 'G', 0, 0, one, aaqq, m,1, a( 1, q ), & + call stdlib_${ci}$lascl( 'G', 0, 0, one, aaqq, m,1, a( 1, q ), & lda, ierr ) sva( q ) = aaqq*sqrt( max( zero,one-aapq1*aapq1 ) ) mxsinj = max( mxsinj, sfmin ) @@ -15820,21 +15822,21 @@ module stdlib_linalg_lapack_w ! recompute sva(q), sva(p). if( ( sva( q ) / aaqq )**2<=rooteps )then if( ( aaqqrootsfmin ) ) then - sva( q ) = stdlib_qznrm2( m, a( 1, q ), 1 ) + sva( q ) = stdlib_${c2ri(ci)}$znrm2( m, a( 1, q ), 1 ) else t = zero aaqq = one - call stdlib_wlassq( m, a( 1, q ), 1, t,aaqq ) + call stdlib_${ci}$lassq( m, a( 1, q ), 1, t,aaqq ) sva( q ) = t*sqrt( aaqq ) end if end if if( ( aapp / aapp0 )<=rooteps ) then if( ( aapprootsfmin ) ) then - aapp = stdlib_qznrm2( m, a( 1, p ), 1 ) + aapp = stdlib_${c2ri(ci)}$znrm2( m, a( 1, p ), 1 ) else t = zero aapp = one - call stdlib_wlassq( m, a( 1, p ), 1, t,aapp ) + call stdlib_${ci}$lassq( m, a( 1, p ), 1, t,aapp ) aapp = t*sqrt( aapp ) end if sva( p ) = aapp @@ -15893,13 +15895,13 @@ module stdlib_linalg_lapack_w rotok = ( small*aaqq )<=aapp end if if( aapp<( big / aaqq ) ) then - aapq = ( stdlib_wdotc( m, a( 1, p ), 1,a( 1, q ), 1 ) / & + aapq = ( stdlib_${ci}$dotc( m, a( 1, p ), 1,a( 1, q ), 1 ) / & aaqq ) / aapp else - call stdlib_wcopy( m, a( 1, p ), 1,cwork(n+1), 1 ) - call stdlib_wlascl( 'G', 0, 0, aapp,one, m, 1,cwork(n+1), & + call stdlib_${ci}$copy( m, a( 1, p ), 1,cwork(n+1), 1 ) + call stdlib_${ci}$lascl( 'G', 0, 0, aapp,one, m, 1,cwork(n+1), & lda, ierr ) - aapq = stdlib_wdotc( m, cwork(n+1), 1,a( 1, q ), 1 ) / & + aapq = stdlib_${ci}$dotc( m, cwork(n+1), 1,a( 1, q ), 1 ) / & aaqq end if else @@ -15909,13 +15911,13 @@ module stdlib_linalg_lapack_w rotok = aaqq<=( aapp / small ) end if if( aapp>( small / aaqq ) ) then - aapq = ( stdlib_wdotc( m, a( 1, p ), 1,a( 1, q ), 1 ) / max(& + aapq = ( stdlib_${ci}$dotc( m, a( 1, p ), 1,a( 1, q ), 1 ) / max(& aaqq,aapp) )/ min(aaqq,aapp) else - call stdlib_wcopy( m, a( 1, q ), 1,cwork(n+1), 1 ) - call stdlib_wlascl( 'G', 0, 0, aaqq,one, m, 1,cwork(n+1), & + call stdlib_${ci}$copy( m, a( 1, q ), 1,cwork(n+1), 1 ) + call stdlib_${ci}$lascl( 'G', 0, 0, aaqq,one, m, 1,cwork(n+1), & lda, ierr ) - aapq = stdlib_wdotc( m, a( 1, p ), 1,cwork(n+1), 1 ) / & + aapq = stdlib_${ci}$dotc( m, a( 1, p ), 1,cwork(n+1), 1 ) / & aapp end if end if @@ -15937,10 +15939,10 @@ module stdlib_linalg_lapack_w if( abs( theta )>bigtheta ) then t = half / theta cs = one - call stdlib_wrot( m, a(1,p), 1, a(1,q), 1,cs, conjg(ompq)& + call stdlib_${ci}$rot( m, a(1,p), 1, a(1,q), 1,cs, conjg(ompq)& *t ) if( rsvec ) then - call stdlib_wrot( mvl, v(1,p), 1,v(1,q), 1, cs, & + call stdlib_${ci}$rot( mvl, v(1,p), 1,v(1,q), 1, cs, & conjg(ompq)*t ) end if sva( q ) = aaqq*sqrt( max( zero,one+t*apoaq*aapq1 ) ) @@ -15959,10 +15961,10 @@ module stdlib_linalg_lapack_w sva( q ) = aaqq*sqrt( max( zero,one+t*apoaq*aapq1 ) ) aapp = aapp*sqrt( max( zero,one-t*aqoap*aapq1 ) ) - call stdlib_wrot( m, a(1,p), 1, a(1,q), 1,cs, conjg(ompq)& + call stdlib_${ci}$rot( m, a(1,p), 1, a(1,q), 1,cs, conjg(ompq)& *sn ) if( rsvec ) then - call stdlib_wrot( mvl, v(1,p), 1,v(1,q), 1, cs, & + call stdlib_${ci}$rot( mvl, v(1,p), 1,v(1,q), 1, cs, & conjg(ompq)*sn ) end if end if @@ -15970,28 +15972,28 @@ module stdlib_linalg_lapack_w else ! .. have to use modified gram-schmidt like transformation if( aapp>aaqq ) then - call stdlib_wcopy( m, a( 1, p ), 1,cwork(n+1), 1 ) + call stdlib_${ci}$copy( m, a( 1, p ), 1,cwork(n+1), 1 ) - call stdlib_wlascl( 'G', 0, 0, aapp, one,m, 1, cwork(n+1)& + call stdlib_${ci}$lascl( 'G', 0, 0, aapp, one,m, 1, cwork(n+1)& ,lda,ierr ) - call stdlib_wlascl( 'G', 0, 0, aaqq, one,m, 1, a( 1, q ),& + call stdlib_${ci}$lascl( 'G', 0, 0, aaqq, one,m, 1, a( 1, q ),& lda,ierr ) - call stdlib_waxpy( m, -aapq, cwork(n+1),1, a( 1, q ), 1 ) + call stdlib_${ci}$axpy( m, -aapq, cwork(n+1),1, a( 1, q ), 1 ) - call stdlib_wlascl( 'G', 0, 0, one, aaqq,m, 1, a( 1, q ),& + call stdlib_${ci}$lascl( 'G', 0, 0, one, aaqq,m, 1, a( 1, q ),& lda,ierr ) sva( q ) = aaqq*sqrt( max( zero,one-aapq1*aapq1 ) ) mxsinj = max( mxsinj, sfmin ) else - call stdlib_wcopy( m, a( 1, q ), 1,cwork(n+1), 1 ) - call stdlib_wlascl( 'G', 0, 0, aaqq, one,m, 1, cwork(n+1)& + call stdlib_${ci}$copy( m, a( 1, q ), 1,cwork(n+1), 1 ) + call stdlib_${ci}$lascl( 'G', 0, 0, aaqq, one,m, 1, cwork(n+1)& ,lda,ierr ) - call stdlib_wlascl( 'G', 0, 0, aapp, one,m, 1, a( 1, p ),& + call stdlib_${ci}$lascl( 'G', 0, 0, aapp, one,m, 1, a( 1, p ),& lda,ierr ) - call stdlib_waxpy( m, -conjg(aapq),cwork(n+1), 1, a( 1, & + call stdlib_${ci}$axpy( m, -conjg(aapq),cwork(n+1), 1, a( 1, & p ), 1 ) - call stdlib_wlascl( 'G', 0, 0, one, aapp,m, 1, a( 1, p ),& + call stdlib_${ci}$lascl( 'G', 0, 0, one, aapp,m, 1, a( 1, p ),& lda,ierr ) sva( p ) = aapp*sqrt( max( zero,one-aapq1*aapq1 ) ) @@ -16003,21 +16005,21 @@ module stdlib_linalg_lapack_w ! .. recompute sva(q), sva(p) if( ( sva( q ) / aaqq )**2<=rooteps )then if( ( aaqqrootsfmin ) ) then - sva( q ) = stdlib_qznrm2( m, a( 1, q ), 1) + sva( q ) = stdlib_${c2ri(ci)}$znrm2( m, a( 1, q ), 1) else t = zero aaqq = one - call stdlib_wlassq( m, a( 1, q ), 1, t,aaqq ) + call stdlib_${ci}$lassq( m, a( 1, q ), 1, t,aaqq ) sva( q ) = t*sqrt( aaqq ) end if end if if( ( aapp / aapp0 )**2<=rooteps ) then if( ( aapprootsfmin ) ) then - aapp = stdlib_qznrm2( m, a( 1, p ), 1 ) + aapp = stdlib_${c2ri(ci)}$znrm2( m, a( 1, p ), 1 ) else t = zero aapp = one - call stdlib_wlassq( m, a( 1, p ), 1, t,aapp ) + call stdlib_${ci}$lassq( m, a( 1, p ), 1, t,aapp ) aapp = t*sqrt( aapp ) end if sva( p ) = aapp @@ -16066,17 +16068,17 @@ module stdlib_linalg_lapack_w ! 2000 :: end of the ibr-loop ! .. update sva(n) if( ( sva( n )rootsfmin ) )then - sva( n ) = stdlib_qznrm2( m, a( 1, n ), 1 ) + sva( n ) = stdlib_${c2ri(ci)}$znrm2( m, a( 1, n ), 1 ) else t = zero aapp = one - call stdlib_wlassq( m, a( 1, n ), 1, t, aapp ) + call stdlib_${ci}$lassq( m, a( 1, n ), 1, t, aapp ) sva( n ) = t*sqrt( aapp ) end if ! additional steering devices if( ( iswband+1 ) .and. ( mxaapqswband+1 ) .and. ( mxaapq=emptsw )go to 1994 @@ -16096,13 +16098,13 @@ module stdlib_linalg_lapack_w n2 = 0 n4 = 0 do p = 1, n - 1 - q = stdlib_iqamax( n-p+1, sva( p ), 1 ) + p - 1 + q = stdlib_i${c2ri(ci)}$amax( n-p+1, sva( p ), 1 ) + p - 1 if( p/=q ) then temp1 = sva( p ) sva( p ) = sva( q ) sva( q ) = temp1 - call stdlib_wswap( m, a( 1, p ), 1, a( 1, q ), 1 ) - if( rsvec )call stdlib_wswap( mvl, v( 1, p ), 1, v( 1, q ), 1 ) + call stdlib_${ci}$swap( m, a( 1, p ), 1, a( 1, q ), 1 ) + if( rsvec )call stdlib_${ci}$swap( mvl, v( 1, p ), 1, v( 1, q ), 1 ) end if if( sva( p )/=zero ) then n4 = n4 + 1 @@ -16116,15 +16118,15 @@ module stdlib_linalg_lapack_w ! normalize the left singular vectors. if( lsvec .or. uctol ) then do p = 1, n4 - ! call stdlib_wdscal( m, one / sva( p ), a( 1, p ), 1 ) - call stdlib_wlascl( 'G',0,0, sva(p), one, m, 1, a(1,p), m, ierr ) + ! call stdlib_${ci}$dscal( m, one / sva( p ), a( 1, p ), 1 ) + call stdlib_${ci}$lascl( 'G',0,0, sva(p), one, m, 1, a(1,p), m, ierr ) end do end if ! scale the product of jacobi rotations. if( rsvec ) then do p = 1, n - temp1 = one / stdlib_qznrm2( mvl, v( 1, p ), 1 ) - call stdlib_wdscal( mvl, temp1, v( 1, p ), 1 ) + temp1 = one / stdlib_${c2ri(ci)}$znrm2( mvl, v( 1, p ), 1 ) + call stdlib_${ci}$dscal( mvl, temp1, v( 1, p ), 1 ) end do end if ! undo scaling, if necessary (and possible). @@ -16139,13 +16141,13 @@ module stdlib_linalg_lapack_w ! the singular values of a are skl*sva(1:n). if skl/=one ! then some of the singular values may overflow or underflow and ! the spectrum is given in this factored representation. - rwork( 2 ) = real( n4,KIND=qp) + rwork( 2 ) = real( n4,KIND=${ck}$) ! n4 is the number of computed nonzero singular values of a. - rwork( 3 ) = real( n2,KIND=qp) + rwork( 3 ) = real( n2,KIND=${ck}$) ! n2 is the number of singular values of a greater than sfmin. ! if n20 ) then ! compute the reciprocal pivot growth factor of the ! leading rank-deficient info columns of a. - rpvgrw = stdlib_wlantr( 'M', 'U', 'N', info, info, af, ldaf,rwork ) + rpvgrw = stdlib_${ci}$lantr( 'M', 'U', 'N', info, info, af, ldaf,rwork ) if( rpvgrw==zero ) then rpvgrw = one else - rpvgrw = stdlib_wlange( 'M', n, info, a, lda, rwork ) /rpvgrw + rpvgrw = stdlib_${ci}$lange( 'M', n, info, a, lda, rwork ) /rpvgrw end if rwork( 1 ) = rpvgrw rcond = zero @@ -16316,21 +16318,21 @@ module stdlib_linalg_lapack_w else norm = 'I' end if - anorm = stdlib_wlange( norm, n, n, a, lda, rwork ) - rpvgrw = stdlib_wlantr( 'M', 'U', 'N', n, n, af, ldaf, rwork ) + anorm = stdlib_${ci}$lange( norm, n, n, a, lda, rwork ) + rpvgrw = stdlib_${ci}$lantr( 'M', 'U', 'N', n, n, af, ldaf, rwork ) if( rpvgrw==zero ) then rpvgrw = one else - rpvgrw = stdlib_wlange( 'M', n, n, a, lda, rwork ) / rpvgrw + rpvgrw = stdlib_${ci}$lange( 'M', n, n, a, lda, rwork ) / rpvgrw end if ! compute the reciprocal of the condition number of a. - call stdlib_wgecon( norm, n, af, ldaf, anorm, rcond, work, rwork, info ) + call stdlib_${ci}$gecon( norm, n, af, ldaf, anorm, rcond, work, rwork, info ) ! compute the solution matrix x. - call stdlib_wlacpy( 'FULL', n, nrhs, b, ldb, x, ldx ) - call stdlib_wgetrs( trans, n, nrhs, af, ldaf, ipiv, x, ldx, info ) + call stdlib_${ci}$lacpy( 'FULL', n, nrhs, b, ldb, x, ldx ) + call stdlib_${ci}$getrs( trans, n, nrhs, af, ldaf, ipiv, x, ldx, info ) ! use iterative refinement to improve the computed solution and ! compute error bounds and backward error estimates for it. - call stdlib_wgerfs( trans, n, nrhs, a, lda, af, ldaf, ipiv, b, ldb, x,ldx, ferr, berr, & + call stdlib_${ci}$gerfs( trans, n, nrhs, a, lda, af, ldaf, ipiv, b, ldb, x,ldx, ferr, berr, & work, rwork, info ) ! transform the solution matrix x to a solution of the original ! system. @@ -16356,13 +16358,13 @@ module stdlib_linalg_lapack_w end do end if ! set info = n+1 if the matrix is singular to working precision. - if( rcond= sfmin ) then - call stdlib_wscal( m-j, cone / a( j, j ), a( j+1, j ), 1 ) + call stdlib_${ci}$scal( m-j, cone / a( j, j ), a( j+1, j ), 1 ) else do i = 1, m-j a( j+i, j ) = a( j+i, j ) / a( j, j ) @@ -16511,15 +16513,15 @@ module stdlib_linalg_lapack_w end if if( j=min( m, n ) ) then ! use unblocked code. - call stdlib_wgetrf2( m, n, a, lda, ipiv, info ) + call stdlib_${ci}$getrf2( m, n, a, lda, ipiv, info ) else ! use blocked code. do j = 1, min( m, n ), nb jb = min( min( m, n )-j+1, nb ) ! factor diagonal and subdiagonal blocks and test for exact ! singularity. - call stdlib_wgetrf2( m-j+1, jb, a( j, j ), lda, ipiv( j ), iinfo ) + call stdlib_${ci}$getrf2( m-j+1, jb, a( j, j ), lda, ipiv( j ), iinfo ) ! adjust info and the pivot indices. if( info==0 .and. iinfo>0 )info = iinfo + j - 1 do i = j, min( m, j+jb-1 ) ipiv( i ) = j - 1 + ipiv( i ) end do ! apply interchanges to columns 1:j-1. - call stdlib_wlaswp( j-1, a, lda, j, j+jb-1, ipiv, 1 ) + call stdlib_${ci}$laswp( j-1, a, lda, j, j+jb-1, ipiv, 1 ) if( j+jb<=n ) then ! apply interchanges to columns j+jb:n. - call stdlib_wlaswp( n-j-jb+1, a( 1, j+jb ), lda, j, j+jb-1,ipiv, 1 ) + call stdlib_${ci}$laswp( n-j-jb+1, a( 1, j+jb ), lda, j, j+jb-1,ipiv, 1 ) ! compute block row of u. - call stdlib_wtrsm( 'LEFT', 'LOWER', 'NO TRANSPOSE', 'UNIT', jb,n-j-jb+1, cone,& + call stdlib_${ci}$trsm( 'LEFT', 'LOWER', 'NO TRANSPOSE', 'UNIT', jb,n-j-jb+1, cone,& a( j, j ), lda, a( j, j+jb ),lda ) if( j+jb<=m ) then ! update trailing submatrix. - call stdlib_wgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', m-j-jb+1,n-j-jb+1, jb, -& + call stdlib_${ci}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', m-j-jb+1,n-j-jb+1, jb, -& cone, a( j+jb, j ), lda,a( j, j+jb ), lda, cone, a( j+jb, j+jb ),lda ) end if @@ -16594,10 +16596,10 @@ module stdlib_linalg_lapack_w end do end if return - end subroutine stdlib_wgetrf + end subroutine stdlib_${ci}$getrf - pure recursive subroutine stdlib_wgetrf2( m, n, a, lda, ipiv, info ) + pure recursive subroutine stdlib_${ci}$getrf2( m, n, a, lda, ipiv, info ) !! ZGETRF2: computes an LU factorization of a general M-by-N matrix A !! using partial pivoting with row interchanges. !! The factorization has the form @@ -16625,12 +16627,12 @@ module stdlib_linalg_lapack_w integer(ilp), intent(in) :: lda, m, n ! Array Arguments integer(ilp), intent(out) :: ipiv(*) - complex(qp), intent(inout) :: a(lda,*) + complex(${ck}$), intent(inout) :: a(lda,*) ! ===================================================================== ! Local Scalars - real(qp) :: sfmin - complex(qp) :: temp + real(${ck}$) :: sfmin + complex(${ck}$) :: temp integer(ilp) :: i, iinfo, n1, n2 ! Intrinsic Functions intrinsic :: max,min @@ -16658,9 +16660,9 @@ module stdlib_linalg_lapack_w else if( n==1 ) then ! use unblocked code for cone column case ! compute machine safe minimum - sfmin = stdlib_qlamch('S') + sfmin = stdlib_${c2ri(ci)}$lamch('S') ! find pivot and test for singularity - i = stdlib_iwamax( m, a( 1, 1 ), 1 ) + i = stdlib_i${ci}$amax( m, a( 1, 1 ), 1 ) ipiv( 1 ) = i if( a( i, 1 )/=czero ) then ! apply the interchange @@ -16671,7 +16673,7 @@ module stdlib_linalg_lapack_w end if ! compute elements 2:m of the column if( abs(a( 1, 1 )) >= sfmin ) then - call stdlib_wscal( m-1, cone / a( 1, 1 ), a( 2, 1 ), 1 ) + call stdlib_${ci}$scal( m-1, cone / a( 1, 1 ), a( 2, 1 ), 1 ) else do i = 1, m-1 a( 1+i, 1 ) = a( 1+i, 1 ) / a( 1, 1 ) @@ -16687,33 +16689,33 @@ module stdlib_linalg_lapack_w ! [ a11 ] ! factor [ --- ] ! [ a21 ] - call stdlib_wgetrf2( m, n1, a, lda, ipiv, iinfo ) + call stdlib_${ci}$getrf2( m, n1, a, lda, ipiv, iinfo ) if ( info==0 .and. iinfo>0 )info = iinfo ! [ a12 ] ! apply interchanges to [ --- ] ! [ a22 ] - call stdlib_wlaswp( n2, a( 1, n1+1 ), lda, 1, n1, ipiv, 1 ) + call stdlib_${ci}$laswp( n2, a( 1, n1+1 ), lda, 1, n1, ipiv, 1 ) ! solve a12 - call stdlib_wtrsm( 'L', 'L', 'N', 'U', n1, n2, cone, a, lda,a( 1, n1+1 ), lda ) + call stdlib_${ci}$trsm( 'L', 'L', 'N', 'U', n1, n2, cone, a, lda,a( 1, n1+1 ), lda ) ! update a22 - call stdlib_wgemm( 'N', 'N', m-n1, n2, n1, -cone, a( n1+1, 1 ), lda,a( 1, n1+1 ), & + call stdlib_${ci}$gemm( 'N', 'N', m-n1, n2, n1, -cone, a( n1+1, 1 ), lda,a( 1, n1+1 ), & lda, cone, a( n1+1, n1+1 ), lda ) ! factor a22 - call stdlib_wgetrf2( m-n1, n2, a( n1+1, n1+1 ), lda, ipiv( n1+1 ),iinfo ) + call stdlib_${ci}$getrf2( m-n1, n2, a( n1+1, n1+1 ), lda, ipiv( n1+1 ),iinfo ) ! adjust info and the pivot indices if ( info==0 .and. iinfo>0 )info = iinfo + n1 do i = n1+1, min( m, n ) ipiv( i ) = ipiv( i ) + n1 end do ! apply interchanges to a21 - call stdlib_wlaswp( n1, a( 1, 1 ), lda, n1+1, min( m, n), ipiv, 1 ) + call stdlib_${ci}$laswp( n1, a( 1, 1 ), lda, n1+1, min( m, n), ipiv, 1 ) end if return - end subroutine stdlib_wgetrf2 + end subroutine stdlib_${ci}$getrf2 - pure subroutine stdlib_wgetri( n, a, lda, ipiv, work, lwork, info ) + pure subroutine stdlib_${ci}$getri( n, a, lda, ipiv, work, lwork, info ) !! ZGETRI: computes the inverse of a matrix using the LU factorization !! computed by ZGETRF. !! This method inverts U and then computes inv(A) by solving the system @@ -16726,8 +16728,8 @@ module stdlib_linalg_lapack_w integer(ilp), intent(in) :: lda, lwork, n ! Array Arguments integer(ilp), intent(in) :: ipiv(*) - complex(qp), intent(inout) :: a(lda,*) - complex(qp), intent(out) :: work(*) + complex(${ck}$), intent(inout) :: a(lda,*) + complex(${ck}$), intent(out) :: work(*) ! ===================================================================== ! Local Scalars @@ -16757,9 +16759,9 @@ module stdlib_linalg_lapack_w end if ! quick return if possible if( n==0 )return - ! form inv(u). if info > 0 from stdlib_wtrtri, then u is singular, + ! form inv(u). if info > 0 from stdlib_${ci}$trtri, then u is singular, ! and the inverse is not computed. - call stdlib_wtrtri( 'UPPER', 'NON-UNIT', n, a, lda, info ) + call stdlib_${ci}$trtri( 'UPPER', 'NON-UNIT', n, a, lda, info ) if( info>0 )return nbmin = 2 ldwork = n @@ -16782,7 +16784,7 @@ module stdlib_linalg_lapack_w a( i, j ) = czero end do ! compute current column of inv(a). - if( j=n ) then - call stdlib_wgeqr( m, n, a, lda, tq, -1, workq, -1, info2 ) + call stdlib_${ci}$geqr( m, n, a, lda, tq, -1, workq, -1, info2 ) tszo = int( tq( 1 ),KIND=ilp) lwo = int( workq( 1 ),KIND=ilp) - call stdlib_wgemqr( 'L', trans, m, nrhs, n, a, lda, tq,tszo, b, ldb, workq, -1, & + call stdlib_${ci}$gemqr( 'L', trans, m, nrhs, n, a, lda, tq,tszo, b, ldb, workq, -1, & info2 ) lwo = max( lwo, int( workq( 1 ),KIND=ilp) ) - call stdlib_wgeqr( m, n, a, lda, tq, -2, workq, -2, info2 ) + call stdlib_${ci}$geqr( m, n, a, lda, tq, -2, workq, -2, info2 ) tszm = int( tq( 1 ),KIND=ilp) lwm = int( workq( 1 ),KIND=ilp) - call stdlib_wgemqr( 'L', trans, m, nrhs, n, a, lda, tq,tszm, b, ldb, workq, -1, & + call stdlib_${ci}$gemqr( 'L', trans, m, nrhs, n, a, lda, tq,tszm, b, ldb, workq, -1, & info2 ) lwm = max( lwm, int( workq( 1 ),KIND=ilp) ) wsizeo = tszo + lwo wsizem = tszm + lwm else - call stdlib_wgelq( m, n, a, lda, tq, -1, workq, -1, info2 ) + call stdlib_${ci}$gelq( m, n, a, lda, tq, -1, workq, -1, info2 ) tszo = int( tq( 1 ),KIND=ilp) lwo = int( workq( 1 ),KIND=ilp) - call stdlib_wgemlq( 'L', trans, n, nrhs, m, a, lda, tq,tszo, b, ldb, workq, -1, & + call stdlib_${ci}$gemlq( 'L', trans, n, nrhs, m, a, lda, tq,tszo, b, ldb, workq, -1, & info2 ) lwo = max( lwo, int( workq( 1 ),KIND=ilp) ) - call stdlib_wgelq( m, n, a, lda, tq, -2, workq, -2, info2 ) + call stdlib_${ci}$gelq( m, n, a, lda, tq, -2, workq, -2, info2 ) tszm = int( tq( 1 ),KIND=ilp) lwm = int( workq( 1 ),KIND=ilp) - call stdlib_wgemlq( 'L', trans, n, nrhs, m, a, lda, tq,tszm, b, ldb, workq, -1, & + call stdlib_${ci}$gemlq( 'L', trans, n, nrhs, m, a, lda, tq,tszm, b, ldb, workq, -1, & info2 ) lwm = max( lwm, int( workq( 1 ),KIND=ilp) ) wsizeo = tszo + lwo @@ -16979,14 +16981,14 @@ module stdlib_linalg_lapack_w if( ( lworkzero .and. anrmbignum ) then ! scale matrix norm down to bignum - call stdlib_wlascl( 'G', 0, 0, anrm, bignum, m, n, a, lda, info ) + call stdlib_${ci}$lascl( 'G', 0, 0, anrm, bignum, m, n, a, lda, info ) iascl = 2 else if( anrm==zero ) then ! matrix all zero. return zero solution. - call stdlib_wlaset( 'F', maxmn, nrhs, czero, czero, b, ldb ) + call stdlib_${ci}$laset( 'F', maxmn, nrhs, czero, czero, b, ldb ) go to 50 end if brow = m if ( tran ) then brow = n end if - bnrm = stdlib_wlange( 'M', brow, nrhs, b, ldb, dum ) + bnrm = stdlib_${ci}$lange( 'M', brow, nrhs, b, ldb, dum ) ibscl = 0 if( bnrm>zero .and. bnrmbignum ) then ! scale matrix norm down to bignum - call stdlib_wlascl( 'G', 0, 0, bnrm, bignum, brow, nrhs, b, ldb,info ) + call stdlib_${ci}$lascl( 'G', 0, 0, bnrm, bignum, brow, nrhs, b, ldb,info ) ibscl = 2 end if if ( m>=n ) then ! compute qr factorization of a - call stdlib_wgeqr( m, n, a, lda, work( lw2+1 ), lw1,work( 1 ), lw2, info ) + call stdlib_${ci}$geqr( m, n, a, lda, work( lw2+1 ), lw1,work( 1 ), lw2, info ) if ( .not.tran ) then ! least-squares problem min || a * x - b || ! b(1:m,1:nrhs) := q**t * b(1:m,1:nrhs) - call stdlib_wgemqr( 'L' , 'C', m, nrhs, n, a, lda,work( lw2+1 ), lw1, b, ldb, work(& + call stdlib_${ci}$gemqr( 'L' , 'C', m, nrhs, n, a, lda,work( lw2+1 ), lw1, b, ldb, work(& 1 ), lw2,info ) ! b(1:n,1:nrhs) := inv(r) * b(1:n,1:nrhs) - call stdlib_wtrtrs( 'U', 'N', 'N', n, nrhs,a, lda, b, ldb, info ) + call stdlib_${ci}$trtrs( 'U', 'N', 'N', n, nrhs,a, lda, b, ldb, info ) if( info>0 ) then return end if @@ -17053,7 +17055,7 @@ module stdlib_linalg_lapack_w else ! overdetermined system of equations a**t * x = b ! b(1:n,1:nrhs) := inv(r**t) * b(1:n,1:nrhs) - call stdlib_wtrtrs( 'U', 'C', 'N', n, nrhs,a, lda, b, ldb, info ) + call stdlib_${ci}$trtrs( 'U', 'C', 'N', n, nrhs,a, lda, b, ldb, info ) if( info>0 ) then return end if @@ -17064,18 +17066,18 @@ module stdlib_linalg_lapack_w end do end do ! b(1:m,1:nrhs) := q(1:n,:) * b(1:n,1:nrhs) - call stdlib_wgemqr( 'L', 'N', m, nrhs, n, a, lda,work( lw2+1 ), lw1, b, ldb, & + call stdlib_${ci}$gemqr( 'L', 'N', m, nrhs, n, a, lda,work( lw2+1 ), lw1, b, ldb, & work( 1 ), lw2,info ) scllen = m end if else ! compute lq factorization of a - call stdlib_wgelq( m, n, a, lda, work( lw2+1 ), lw1,work( 1 ), lw2, info ) + call stdlib_${ci}$gelq( m, n, a, lda, work( lw2+1 ), lw1,work( 1 ), lw2, info ) ! workspace at least m, optimally m*nb. if( .not.tran ) then ! underdetermined system of equations a * x = b ! b(1:m,1:nrhs) := inv(l) * b(1:m,1:nrhs) - call stdlib_wtrtrs( 'L', 'N', 'N', m, nrhs,a, lda, b, ldb, info ) + call stdlib_${ci}$trtrs( 'L', 'N', 'N', m, nrhs,a, lda, b, ldb, info ) if( info>0 ) then return end if @@ -17086,18 +17088,18 @@ module stdlib_linalg_lapack_w end do end do ! b(1:n,1:nrhs) := q(1:n,:)**t * b(1:m,1:nrhs) - call stdlib_wgemlq( 'L', 'C', n, nrhs, m, a, lda,work( lw2+1 ), lw1, b, ldb, & + call stdlib_${ci}$gemlq( 'L', 'C', n, nrhs, m, a, lda,work( lw2+1 ), lw1, b, ldb, & work( 1 ), lw2,info ) ! workspace at least nrhs, optimally nrhs*nb scllen = n else ! overdetermined system min || a**t * x - b || ! b(1:n,1:nrhs) := q * b(1:n,1:nrhs) - call stdlib_wgemlq( 'L', 'N', n, nrhs, m, a, lda,work( lw2+1 ), lw1, b, ldb, & + call stdlib_${ci}$gemlq( 'L', 'N', n, nrhs, m, a, lda,work( lw2+1 ), lw1, b, ldb, & work( 1 ), lw2,info ) ! workspace at least nrhs, optimally nrhs*nb ! b(1:m,1:nrhs) := inv(l**t) * b(1:m,1:nrhs) - call stdlib_wtrtrs( 'L', 'C', 'N', m, nrhs,a, lda, b, ldb, info ) + call stdlib_${ci}$trtrs( 'L', 'C', 'N', m, nrhs,a, lda, b, ldb, info ) if( info>0 ) then return end if @@ -17106,22 +17108,22 @@ module stdlib_linalg_lapack_w end if ! undo scaling if( iascl==1 ) then - call stdlib_wlascl( 'G', 0, 0, anrm, smlnum, scllen, nrhs, b, ldb,info ) + call stdlib_${ci}$lascl( 'G', 0, 0, anrm, smlnum, scllen, nrhs, b, ldb,info ) else if( iascl==2 ) then - call stdlib_wlascl( 'G', 0, 0, anrm, bignum, scllen, nrhs, b, ldb,info ) + call stdlib_${ci}$lascl( 'G', 0, 0, anrm, bignum, scllen, nrhs, b, ldb,info ) end if if( ibscl==1 ) then - call stdlib_wlascl( 'G', 0, 0, smlnum, bnrm, scllen, nrhs, b, ldb,info ) + call stdlib_${ci}$lascl( 'G', 0, 0, smlnum, bnrm, scllen, nrhs, b, ldb,info ) else if( ibscl==2 ) then - call stdlib_wlascl( 'G', 0, 0, bignum, bnrm, scllen, nrhs, b, ldb,info ) + call stdlib_${ci}$lascl( 'G', 0, 0, bignum, bnrm, scllen, nrhs, b, ldb,info ) end if 50 continue - work( 1 ) = real( tszo + lwo,KIND=qp) + work( 1 ) = real( tszo + lwo,KIND=${ck}$) return - end subroutine stdlib_wgetsls + end subroutine stdlib_${ci}$getsls - pure subroutine stdlib_wgetsqrhrt( m, n, mb1, nb1, nb2, a, lda, t, ldt, work,lwork, info ) + pure subroutine stdlib_${ci}$getsqrhrt( m, n, mb1, nb1, nb2, a, lda, t, ldt, work,lwork, info ) !! ZGETSQRHRT: computes a NB2-sized column blocked QR-factorization !! of a complex M-by-N matrix A with M >= N, !! A = Q * R. @@ -17142,8 +17144,8 @@ module stdlib_linalg_lapack_w integer(ilp), intent(out) :: info integer(ilp), intent(in) :: lda, ldt, lwork, m, n, nb1, nb2, mb1 ! Array Arguments - complex(qp), intent(inout) :: a(lda,*) - complex(qp), intent(out) :: t(ldt,*), work(*) + complex(${ck}$), intent(inout) :: a(lda,*) + complex(${ck}$), intent(out) :: t(ldt,*), work(*) ! ===================================================================== ! Local Scalars @@ -17173,24 +17175,24 @@ module stdlib_linalg_lapack_w else ! test the input lwork for the dimension of the array work. ! this workspace is used to store array: - ! a) matrix t and work for stdlib_wlatsqr; + ! a) matrix t and work for stdlib_${ci}$latsqr; ! b) n-by-n upper-triangular factor r_tsqr; - ! c) matrix t and array work for stdlib_wungtsqr_row; - ! d) diagonal d for stdlib_wunhr_col. + ! c) matrix t and array work for stdlib_${ci}$ungtsqr_row; + ! d) diagonal d for stdlib_${ci}$unhr_col. if( lworkzero .and. anrmzero .and. bnrm1 ) then - call stdlib_wlacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,vsl( ilo+1, ilo )& + call stdlib_${ci}$lacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,vsl( ilo+1, ilo )& , ldvsl ) end if - call stdlib_wungqr( irows, irows, irows, vsl( ilo, ilo ), ldvsl,work( itau ), work( & + call stdlib_${ci}$ungqr( irows, irows, irows, vsl( ilo, ilo ), ldvsl,work( itau ), work( & iwrk ), lwork+1-iwrk, ierr ) end if ! initialize vsr - if( ilvsr )call stdlib_wlaset( 'FULL', n, n, czero, cone, vsr, ldvsr ) + if( ilvsr )call stdlib_${ci}$laset( 'FULL', n, n, czero, cone, vsr, ldvsr ) ! reduce to generalized hessenberg form ! (workspace: none needed) - call stdlib_wgghrd( jobvsl, jobvsr, n, ilo, ihi, a, lda, b, ldb, vsl,ldvsl, vsr, ldvsr,& + call stdlib_${ci}$gghrd( jobvsl, jobvsr, n, ilo, ihi, a, lda, b, ldb, vsl,ldvsl, vsr, ldvsr,& ierr ) sdim = 0 ! perform qz algorithm, computing schur vectors if desired ! (complex workspace: need n) ! (real workspace: need n) iwrk = itau - call stdlib_whgeqz( 'S', jobvsl, jobvsr, n, ilo, ihi, a, lda, b, ldb,alpha, beta, vsl, & + call stdlib_${ci}$hgeqz( 'S', jobvsl, jobvsr, n, ilo, ihi, a, lda, b, ldb,alpha, beta, vsl, & ldvsl, vsr, ldvsr, work( iwrk ),lwork+1-iwrk, rwork( irwrk ), ierr ) if( ierr/=0 ) then if( ierr>0 .and. ierr<=n ) then @@ -17878,33 +17880,33 @@ module stdlib_linalg_lapack_w ! (workspace: none needed) if( wantst ) then ! undo scaling on eigenvalues before selecting - if( ilascl )call stdlib_wlascl( 'G', 0, 0, anrm, anrmto, n, 1, alpha, n, ierr ) + if( ilascl )call stdlib_${ci}$lascl( 'G', 0, 0, anrm, anrmto, n, 1, alpha, n, ierr ) - if( ilbscl )call stdlib_wlascl( 'G', 0, 0, bnrm, bnrmto, n, 1, beta, n, ierr ) + if( ilbscl )call stdlib_${ci}$lascl( 'G', 0, 0, bnrm, bnrmto, n, 1, beta, n, ierr ) ! select eigenvalues do i = 1, n bwork( i ) = selctg( alpha( i ), beta( i ) ) end do - call stdlib_wtgsen( 0, ilvsl, ilvsr, bwork, n, a, lda, b, ldb, alpha,beta, vsl, & + call stdlib_${ci}$tgsen( 0, ilvsl, ilvsr, bwork, n, a, lda, b, ldb, alpha,beta, vsl, & ldvsl, vsr, ldvsr, sdim, pvsl, pvsr,dif, work( iwrk ), lwork-iwrk+1, idum, 1, ierr ) if( ierr==1 )info = n + 3 end if ! apply back-permutation to vsl and vsr ! (workspace: none needed) - if( ilvsl )call stdlib_wggbak( 'P', 'L', n, ilo, ihi, rwork( ileft ),rwork( iright ), & + if( ilvsl )call stdlib_${ci}$ggbak( 'P', 'L', n, ilo, ihi, rwork( ileft ),rwork( iright ), & n, vsl, ldvsl, ierr ) - if( ilvsr )call stdlib_wggbak( 'P', 'R', n, ilo, ihi, rwork( ileft ),rwork( iright ), & + if( ilvsr )call stdlib_${ci}$ggbak( 'P', 'R', n, ilo, ihi, rwork( ileft ),rwork( iright ), & n, vsr, ldvsr, ierr ) ! undo scaling if( ilascl ) then - call stdlib_wlascl( 'U', 0, 0, anrmto, anrm, n, n, a, lda, ierr ) - call stdlib_wlascl( 'G', 0, 0, anrmto, anrm, n, 1, alpha, n, ierr ) + call stdlib_${ci}$lascl( 'U', 0, 0, anrmto, anrm, n, n, a, lda, ierr ) + call stdlib_${ci}$lascl( 'G', 0, 0, anrmto, anrm, n, 1, alpha, n, ierr ) end if if( ilbscl ) then - call stdlib_wlascl( 'U', 0, 0, bnrmto, bnrm, n, n, b, ldb, ierr ) - call stdlib_wlascl( 'G', 0, 0, bnrmto, bnrm, n, 1, beta, n, ierr ) + call stdlib_${ci}$lascl( 'U', 0, 0, bnrmto, bnrm, n, n, b, ldb, ierr ) + call stdlib_${ci}$lascl( 'G', 0, 0, bnrmto, bnrm, n, 1, beta, n, ierr ) end if if( wantst ) then ! check if reordering is correct @@ -17920,10 +17922,10 @@ module stdlib_linalg_lapack_w 30 continue work( 1 ) = lwkopt return - end subroutine stdlib_wgges + end subroutine stdlib_${ci}$gges - subroutine stdlib_wgges3( jobvsl, jobvsr, sort, selctg, n, a, lda, b,ldb, sdim, alpha, beta, & + subroutine stdlib_${ci}$gges3( jobvsl, jobvsr, sort, selctg, n, a, lda, b,ldb, sdim, alpha, beta, & !! ZGGES3: computes for a pair of N-by-N complex nonsymmetric matrices !! (A,B), the generalized eigenvalues, the generalized complex Schur !! form (S, T), and optionally left and/or right Schur vectors (VSL @@ -17954,12 +17956,12 @@ module stdlib_linalg_lapack_w integer(ilp), intent(in) :: lda, ldb, ldvsl, ldvsr, lwork, n ! Array Arguments logical(lk), intent(out) :: bwork(*) - real(qp), intent(out) :: rwork(*) - complex(qp), intent(inout) :: a(lda,*), b(ldb,*) - complex(qp), intent(out) :: alpha(*), beta(*), vsl(ldvsl,*), vsr(ldvsr,*), work(*) + real(${ck}$), intent(out) :: rwork(*) + complex(${ck}$), intent(inout) :: a(lda,*), b(ldb,*) + complex(${ck}$), intent(out) :: alpha(*), beta(*), vsl(ldvsl,*), vsr(ldvsr,*), work(*) ! Function Arguments - procedure(stdlib_selctg_w) :: selctg + procedure(stdlib_selctg_${ci}$) :: selctg ! ===================================================================== @@ -17967,10 +17969,10 @@ module stdlib_linalg_lapack_w logical(lk) :: cursl, ilascl, ilbscl, ilvsl, ilvsr, lastsl, lquery, wantst integer(ilp) :: i, icols, ierr, ihi, ijobvl, ijobvr, ileft, ilo, iright, irows, irwrk, & itau, iwrk, lwkopt - real(qp) :: anrm, anrmto, bignum, bnrm, bnrmto, eps, pvsl, pvsr, smlnum + real(${ck}$) :: anrm, anrmto, bignum, bnrm, bnrmto, eps, pvsl, pvsr, smlnum ! Local Arrays integer(ilp) :: idum(1) - real(qp) :: dif(2) + real(${ck}$) :: dif(2) ! Intrinsic Functions intrinsic :: max,sqrt ! Executable Statements @@ -18020,26 +18022,26 @@ module stdlib_linalg_lapack_w end if ! compute workspace if( info==0 ) then - call stdlib_wgeqrf( n, n, b, ldb, work, work, -1, ierr ) + call stdlib_${ci}$geqrf( n, n, b, ldb, work, work, -1, ierr ) lwkopt = max( 1, n + int( work( 1 ),KIND=ilp) ) - call stdlib_wunmqr( 'L', 'C', n, n, n, b, ldb, work, a, lda, work,-1, ierr ) + call stdlib_${ci}$unmqr( 'L', 'C', n, n, n, b, ldb, work, a, lda, work,-1, ierr ) lwkopt = max( lwkopt, n + int( work( 1 ),KIND=ilp) ) if( ilvsl ) then - call stdlib_wungqr( n, n, n, vsl, ldvsl, work, work, -1, ierr ) + call stdlib_${ci}$ungqr( n, n, n, vsl, ldvsl, work, work, -1, ierr ) lwkopt = max( lwkopt, n + int( work( 1 ),KIND=ilp) ) end if - call stdlib_wgghd3( jobvsl, jobvsr, n, 1, n, a, lda, b, ldb, vsl,ldvsl, vsr, ldvsr, & + call stdlib_${ci}$gghd3( jobvsl, jobvsr, n, 1, n, a, lda, b, ldb, vsl,ldvsl, vsr, ldvsr, & work, -1, ierr ) lwkopt = max( lwkopt, n + int( work( 1 ),KIND=ilp) ) - call stdlib_wlaqz0( 'S', jobvsl, jobvsr, n, 1, n, a, lda, b, ldb,alpha, beta, vsl, & + call stdlib_${ci}$laqz0( 'S', jobvsl, jobvsr, n, 1, n, a, lda, b, ldb,alpha, beta, vsl, & ldvsl, vsr, ldvsr, work, -1,rwork, 0, ierr ) lwkopt = max( lwkopt, int( work( 1 ),KIND=ilp) ) if( wantst ) then - call stdlib_wtgsen( 0, ilvsl, ilvsr, bwork, n, a, lda, b, ldb,alpha, beta, vsl, & + call stdlib_${ci}$tgsen( 0, ilvsl, ilvsr, bwork, n, a, lda, b, ldb,alpha, beta, vsl, & ldvsl, vsr, ldvsr, sdim,pvsl, pvsr, dif, work, -1, idum, 1, ierr ) lwkopt = max( lwkopt, int( work( 1 ),KIND=ilp) ) end if - work( 1 ) = cmplx( lwkopt,KIND=qp) + work( 1 ) = cmplx( lwkopt,KIND=${ck}$) end if if( info/=0 ) then call stdlib_xerbla( 'ZGGES3 ', -info ) @@ -18053,14 +18055,14 @@ module stdlib_linalg_lapack_w return end if ! get machine constants - eps = stdlib_qlamch( 'P' ) - smlnum = stdlib_qlamch( 'S' ) + eps = stdlib_${c2ri(ci)}$lamch( 'P' ) + smlnum = stdlib_${c2ri(ci)}$lamch( 'S' ) bignum = one / smlnum - call stdlib_qlabad( smlnum, bignum ) + call stdlib_${c2ri(ci)}$labad( smlnum, bignum ) smlnum = sqrt( smlnum ) / eps bignum = one / smlnum ! scale a if max element outside range [smlnum,bignum] - anrm = stdlib_wlange( 'M', n, n, a, lda, rwork ) + anrm = stdlib_${ci}$lange( 'M', n, n, a, lda, rwork ) ilascl = .false. if( anrm>zero .and. anrmzero .and. bnrm1 ) then - call stdlib_wlacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,vsl( ilo+1, ilo )& + call stdlib_${ci}$lacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,vsl( ilo+1, ilo )& , ldvsl ) end if - call stdlib_wungqr( irows, irows, irows, vsl( ilo, ilo ), ldvsl,work( itau ), work( & + call stdlib_${ci}$ungqr( irows, irows, irows, vsl( ilo, ilo ), ldvsl,work( itau ), work( & iwrk ), lwork+1-iwrk, ierr ) end if ! initialize vsr - if( ilvsr )call stdlib_wlaset( 'FULL', n, n, czero, cone, vsr, ldvsr ) + if( ilvsr )call stdlib_${ci}$laset( 'FULL', n, n, czero, cone, vsr, ldvsr ) ! reduce to generalized hessenberg form - call stdlib_wgghd3( jobvsl, jobvsr, n, ilo, ihi, a, lda, b, ldb, vsl,ldvsl, vsr, ldvsr,& + call stdlib_${ci}$gghd3( jobvsl, jobvsr, n, ilo, ihi, a, lda, b, ldb, vsl,ldvsl, vsr, ldvsr,& work( iwrk ), lwork+1-iwrk, ierr ) sdim = 0 ! perform qz algorithm, computing schur vectors if desired iwrk = itau - call stdlib_wlaqz0( 'S', jobvsl, jobvsr, n, ilo, ihi, a, lda, b, ldb,alpha, beta, vsl, & + call stdlib_${ci}$laqz0( 'S', jobvsl, jobvsr, n, ilo, ihi, a, lda, b, ldb,alpha, beta, vsl, & ldvsl, vsr, ldvsr, work( iwrk ),lwork+1-iwrk, rwork( irwrk ), 0, ierr ) if( ierr/=0 ) then if( ierr>0 .and. ierr<=n ) then @@ -18130,32 +18132,32 @@ module stdlib_linalg_lapack_w ! sort eigenvalues alpha/beta if desired if( wantst ) then ! undo scaling on eigenvalues before selecting - if( ilascl )call stdlib_wlascl( 'G', 0, 0, anrm, anrmto, n, 1, alpha, n, ierr ) + if( ilascl )call stdlib_${ci}$lascl( 'G', 0, 0, anrm, anrmto, n, 1, alpha, n, ierr ) - if( ilbscl )call stdlib_wlascl( 'G', 0, 0, bnrm, bnrmto, n, 1, beta, n, ierr ) + if( ilbscl )call stdlib_${ci}$lascl( 'G', 0, 0, bnrm, bnrmto, n, 1, beta, n, ierr ) ! select eigenvalues do i = 1, n bwork( i ) = selctg( alpha( i ), beta( i ) ) end do - call stdlib_wtgsen( 0, ilvsl, ilvsr, bwork, n, a, lda, b, ldb, alpha,beta, vsl, & + call stdlib_${ci}$tgsen( 0, ilvsl, ilvsr, bwork, n, a, lda, b, ldb, alpha,beta, vsl, & ldvsl, vsr, ldvsr, sdim, pvsl, pvsr,dif, work( iwrk ), lwork-iwrk+1, idum, 1, ierr ) if( ierr==1 )info = n + 3 end if ! apply back-permutation to vsl and vsr - if( ilvsl )call stdlib_wggbak( 'P', 'L', n, ilo, ihi, rwork( ileft ),rwork( iright ), & + if( ilvsl )call stdlib_${ci}$ggbak( 'P', 'L', n, ilo, ihi, rwork( ileft ),rwork( iright ), & n, vsl, ldvsl, ierr ) - if( ilvsr )call stdlib_wggbak( 'P', 'R', n, ilo, ihi, rwork( ileft ),rwork( iright ), & + if( ilvsr )call stdlib_${ci}$ggbak( 'P', 'R', n, ilo, ihi, rwork( ileft ),rwork( iright ), & n, vsr, ldvsr, ierr ) ! undo scaling if( ilascl ) then - call stdlib_wlascl( 'U', 0, 0, anrmto, anrm, n, n, a, lda, ierr ) - call stdlib_wlascl( 'G', 0, 0, anrmto, anrm, n, 1, alpha, n, ierr ) + call stdlib_${ci}$lascl( 'U', 0, 0, anrmto, anrm, n, n, a, lda, ierr ) + call stdlib_${ci}$lascl( 'G', 0, 0, anrmto, anrm, n, 1, alpha, n, ierr ) end if if( ilbscl ) then - call stdlib_wlascl( 'U', 0, 0, bnrmto, bnrm, n, n, b, ldb, ierr ) - call stdlib_wlascl( 'G', 0, 0, bnrmto, bnrm, n, 1, beta, n, ierr ) + call stdlib_${ci}$lascl( 'U', 0, 0, bnrmto, bnrm, n, n, b, ldb, ierr ) + call stdlib_${ci}$lascl( 'G', 0, 0, bnrmto, bnrm, n, 1, beta, n, ierr ) end if if( wantst ) then ! check if reordering is correct @@ -18169,12 +18171,12 @@ module stdlib_linalg_lapack_w end do end if 30 continue - work( 1 ) = cmplx( lwkopt,KIND=qp) + work( 1 ) = cmplx( lwkopt,KIND=${ck}$) return - end subroutine stdlib_wgges3 + end subroutine stdlib_${ci}$gges3 - subroutine stdlib_wggesx( jobvsl, jobvsr, sort, selctg, sense, n, a, lda,b, ldb, sdim, alpha,& + subroutine stdlib_${ci}$ggesx( jobvsl, jobvsr, sort, selctg, sense, n, a, lda,b, ldb, sdim, alpha,& !! ZGGESX: computes for a pair of N-by-N complex nonsymmetric matrices !! (A,B), the generalized eigenvalues, the complex Schur form (S,T), !! and, optionally, the left and/or right matrices of Schur vectors (VSL @@ -18209,12 +18211,12 @@ module stdlib_linalg_lapack_w ! Array Arguments logical(lk), intent(out) :: bwork(*) integer(ilp), intent(out) :: iwork(*) - real(qp), intent(out) :: rconde(2), rcondv(2), rwork(*) - complex(qp), intent(inout) :: a(lda,*), b(ldb,*) - complex(qp), intent(out) :: alpha(*), beta(*), vsl(ldvsl,*), vsr(ldvsr,*), work(*) + real(${ck}$), intent(out) :: rconde(2), rcondv(2), rwork(*) + complex(${ck}$), intent(inout) :: a(lda,*), b(ldb,*) + complex(${ck}$), intent(out) :: alpha(*), beta(*), vsl(ldvsl,*), vsr(ldvsr,*), work(*) ! Function Arguments - procedure(stdlib_selctg_w) :: selctg + procedure(stdlib_selctg_${ci}$) :: selctg ! ===================================================================== @@ -18223,9 +18225,9 @@ module stdlib_linalg_lapack_w wantsn, wantst, wantsv integer(ilp) :: i, icols, ierr, ihi, ijob, ijobvl, ijobvr, ileft, ilo, iright, irows, & irwrk, itau, iwrk, liwmin, lwrk, maxwrk, minwrk - real(qp) :: anrm, anrmto, bignum, bnrm, bnrmto, eps, pl, pr, smlnum + real(${ck}$) :: anrm, anrmto, bignum, bnrm, bnrmto, eps, pl, pr, smlnum ! Local Arrays - real(qp) :: dif(2) + real(${ck}$) :: dif(2) ! Intrinsic Functions intrinsic :: max,sqrt ! Executable Statements @@ -18335,14 +18337,14 @@ module stdlib_linalg_lapack_w return end if ! get machine constants - eps = stdlib_qlamch( 'P' ) - smlnum = stdlib_qlamch( 'S' ) + eps = stdlib_${c2ri(ci)}$lamch( 'P' ) + smlnum = stdlib_${c2ri(ci)}$lamch( 'S' ) bignum = one / smlnum - call stdlib_qlabad( smlnum, bignum ) + call stdlib_${c2ri(ci)}$labad( smlnum, bignum ) smlnum = sqrt( smlnum ) / eps bignum = one / smlnum ! scale a if max element outside range [smlnum,bignum] - anrm = stdlib_wlange( 'M', n, n, a, lda, rwork ) + anrm = stdlib_${ci}$lange( 'M', n, n, a, lda, rwork ) ilascl = .false. if( anrm>zero .and. anrmzero .and. bnrm1 ) then - call stdlib_wlacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,vsl( ilo+1, ilo )& + call stdlib_${ci}$lacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,vsl( ilo+1, ilo )& , ldvsl ) end if - call stdlib_wungqr( irows, irows, irows, vsl( ilo, ilo ), ldvsl,work( itau ), work( & + call stdlib_${ci}$ungqr( irows, irows, irows, vsl( ilo, ilo ), ldvsl,work( itau ), work( & iwrk ), lwork+1-iwrk, ierr ) end if ! initialize vsr - if( ilvsr )call stdlib_wlaset( 'FULL', n, n, czero, cone, vsr, ldvsr ) + if( ilvsr )call stdlib_${ci}$laset( 'FULL', n, n, czero, cone, vsr, ldvsr ) ! reduce to generalized hessenberg form ! (workspace: none needed) - call stdlib_wgghrd( jobvsl, jobvsr, n, ilo, ihi, a, lda, b, ldb, vsl,ldvsl, vsr, ldvsr,& + call stdlib_${ci}$gghrd( jobvsl, jobvsr, n, ilo, ihi, a, lda, b, ldb, vsl,ldvsl, vsr, ldvsr,& ierr ) sdim = 0 ! perform qz algorithm, computing schur vectors if desired ! (complex workspace: need n) ! (real workspace: need n) iwrk = itau - call stdlib_whgeqz( 'S', jobvsl, jobvsr, n, ilo, ihi, a, lda, b, ldb,alpha, beta, vsl, & + call stdlib_${ci}$hgeqz( 'S', jobvsl, jobvsr, n, ilo, ihi, a, lda, b, ldb,alpha, beta, vsl, & ldvsl, vsr, ldvsr, work( iwrk ),lwork+1-iwrk, rwork( irwrk ), ierr ) if( ierr/=0 ) then if( ierr>0 .and. ierr<=n ) then @@ -18420,9 +18422,9 @@ module stdlib_linalg_lapack_w ! condition number(s) if( wantst ) then ! undo scaling on eigenvalues before selctging - if( ilascl )call stdlib_wlascl( 'G', 0, 0, anrmto, anrm, n, 1, alpha, n, ierr ) + if( ilascl )call stdlib_${ci}$lascl( 'G', 0, 0, anrmto, anrm, n, 1, alpha, n, ierr ) - if( ilbscl )call stdlib_wlascl( 'G', 0, 0, bnrmto, bnrm, n, 1, beta, n, ierr ) + if( ilbscl )call stdlib_${ci}$lascl( 'G', 0, 0, bnrmto, bnrm, n, 1, beta, n, ierr ) ! select eigenvalues do i = 1, n @@ -18432,7 +18434,7 @@ module stdlib_linalg_lapack_w ! compute reciprocal condition numbers ! (complex workspace: if ijob >= 1, need max(1, 2*sdim*(n-sdim)) ! otherwise, need 1 ) - call stdlib_wtgsen( ijob, ilvsl, ilvsr, bwork, n, a, lda, b, ldb,alpha, beta, vsl, & + call stdlib_${ci}$tgsen( ijob, ilvsl, ilvsr, bwork, n, a, lda, b, ldb,alpha, beta, vsl, & ldvsl, vsr, ldvsr, sdim, pl, pr,dif, work( iwrk ), lwork-iwrk+1, iwork, liwork,ierr & ) if( ijob>=1 )maxwrk = max( maxwrk, 2*sdim*( n-sdim ) ) @@ -18453,18 +18455,18 @@ module stdlib_linalg_lapack_w end if ! apply permutation to vsl and vsr ! (workspace: none needed) - if( ilvsl )call stdlib_wggbak( 'P', 'L', n, ilo, ihi, rwork( ileft ),rwork( iright ), & + if( ilvsl )call stdlib_${ci}$ggbak( 'P', 'L', n, ilo, ihi, rwork( ileft ),rwork( iright ), & n, vsl, ldvsl, ierr ) - if( ilvsr )call stdlib_wggbak( 'P', 'R', n, ilo, ihi, rwork( ileft ),rwork( iright ), & + if( ilvsr )call stdlib_${ci}$ggbak( 'P', 'R', n, ilo, ihi, rwork( ileft ),rwork( iright ), & n, vsr, ldvsr, ierr ) ! undo scaling if( ilascl ) then - call stdlib_wlascl( 'U', 0, 0, anrmto, anrm, n, n, a, lda, ierr ) - call stdlib_wlascl( 'G', 0, 0, anrmto, anrm, n, 1, alpha, n, ierr ) + call stdlib_${ci}$lascl( 'U', 0, 0, anrmto, anrm, n, n, a, lda, ierr ) + call stdlib_${ci}$lascl( 'G', 0, 0, anrmto, anrm, n, 1, alpha, n, ierr ) end if if( ilbscl ) then - call stdlib_wlascl( 'U', 0, 0, bnrmto, bnrm, n, n, b, ldb, ierr ) - call stdlib_wlascl( 'G', 0, 0, bnrmto, bnrm, n, 1, beta, n, ierr ) + call stdlib_${ci}$lascl( 'U', 0, 0, bnrmto, bnrm, n, n, b, ldb, ierr ) + call stdlib_${ci}$lascl( 'G', 0, 0, bnrmto, bnrm, n, 1, beta, n, ierr ) end if if( wantst ) then ! check if reordering is correct @@ -18481,10 +18483,10 @@ module stdlib_linalg_lapack_w work( 1 ) = maxwrk iwork( 1 ) = liwmin return - end subroutine stdlib_wggesx + end subroutine stdlib_${ci}$ggesx - subroutine stdlib_wggev( jobvl, jobvr, n, a, lda, b, ldb, alpha, beta,vl, ldvl, vr, ldvr, & + subroutine stdlib_${ci}$ggev( jobvl, jobvr, n, a, lda, b, ldb, alpha, beta,vl, ldvl, vr, ldvr, & !! ZGGEV: computes for a pair of N-by-N complex nonsymmetric matrices !! (A,B), the generalized eigenvalues, and optionally, the left and/or !! right generalized eigenvectors. @@ -18509,9 +18511,9 @@ module stdlib_linalg_lapack_w integer(ilp), intent(out) :: info integer(ilp), intent(in) :: lda, ldb, ldvl, ldvr, lwork, n ! Array Arguments - real(qp), intent(out) :: rwork(*) - complex(qp), intent(inout) :: a(lda,*), b(ldb,*) - complex(qp), intent(out) :: alpha(*), beta(*), vl(ldvl,*), vr(ldvr,*), work(*) + real(${ck}$), intent(out) :: rwork(*) + complex(${ck}$), intent(inout) :: a(lda,*), b(ldb,*) + complex(${ck}$), intent(out) :: alpha(*), beta(*), vl(ldvl,*), vr(ldvr,*), work(*) ! ===================================================================== @@ -18520,16 +18522,16 @@ module stdlib_linalg_lapack_w character :: chtemp integer(ilp) :: icols, ierr, ihi, ijobvl, ijobvr, ileft, ilo, in, iright, irows, irwrk,& itau, iwrk, jc, jr, lwkmin, lwkopt - real(qp) :: anrm, anrmto, bignum, bnrm, bnrmto, eps, smlnum, temp - complex(qp) :: x + real(${ck}$) :: anrm, anrmto, bignum, bnrm, bnrmto, eps, smlnum, temp + complex(${ck}$) :: x ! Local Arrays logical(lk) :: ldumma(1) ! Intrinsic Functions intrinsic :: abs,real,aimag,max,sqrt ! Statement Functions - real(qp) :: abs1 + real(${ck}$) :: abs1 ! Statement Function Definitions - abs1( x ) = abs( real( x,KIND=qp) ) + abs( aimag( x ) ) + abs1( x ) = abs( real( x,KIND=${ck}$) ) + abs( aimag( x ) ) ! Executable Statements ! decode the input arguments if( stdlib_lsame( jobvl, 'N' ) ) then @@ -18598,14 +18600,14 @@ module stdlib_linalg_lapack_w ! quick return if possible if( n==0 )return ! get machine constants - eps = stdlib_qlamch( 'E' )*stdlib_qlamch( 'B' ) - smlnum = stdlib_qlamch( 'S' ) + eps = stdlib_${c2ri(ci)}$lamch( 'E' )*stdlib_${c2ri(ci)}$lamch( 'B' ) + smlnum = stdlib_${c2ri(ci)}$lamch( 'S' ) bignum = one / smlnum - call stdlib_qlabad( smlnum, bignum ) + call stdlib_${c2ri(ci)}$labad( smlnum, bignum ) smlnum = sqrt( smlnum ) / eps bignum = one / smlnum ! scale a if max element outside range [smlnum,bignum] - anrm = stdlib_wlange( 'M', n, n, a, lda, rwork ) + anrm = stdlib_${ci}$lange( 'M', n, n, a, lda, rwork ) ilascl = .false. if( anrm>zero .and. anrmzero .and. bnrm1 ) then - call stdlib_wlacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,vl( ilo+1, ilo ),& + call stdlib_${ci}$lacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,vl( ilo+1, ilo ),& ldvl ) end if - call stdlib_wungqr( irows, irows, irows, vl( ilo, ilo ), ldvl,work( itau ), work( & + call stdlib_${ci}$ungqr( irows, irows, irows, vl( ilo, ilo ), ldvl,work( itau ), work( & iwrk ), lwork+1-iwrk, ierr ) end if ! initialize vr - if( ilvr )call stdlib_wlaset( 'FULL', n, n, czero, cone, vr, ldvr ) + if( ilvr )call stdlib_${ci}$laset( 'FULL', n, n, czero, cone, vr, ldvr ) ! reduce to generalized hessenberg form if( ilv ) then ! eigenvectors requested -- work on whole matrix. - call stdlib_wgghrd( jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb, vl,ldvl, vr, ldvr, & + call stdlib_${ci}$gghrd( jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb, vl,ldvl, vr, ldvr, & ierr ) else - call stdlib_wgghrd( 'N', 'N', irows, 1, irows, a( ilo, ilo ), lda,b( ilo, ilo ), & + call stdlib_${ci}$gghrd( 'N', 'N', irows, 1, irows, a( ilo, ilo ), lda,b( ilo, ilo ), & ldb, vl, ldvl, vr, ldvr, ierr ) end if ! perform qz algorithm (compute eigenvalues, and optionally, the @@ -18681,7 +18683,7 @@ module stdlib_linalg_lapack_w else chtemp = 'E' end if - call stdlib_whgeqz( chtemp, jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb,alpha, beta, vl, & + call stdlib_${ci}$hgeqz( chtemp, jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb,alpha, beta, vl, & ldvl, vr, ldvr, work( iwrk ),lwork+1-iwrk, rwork( irwrk ), ierr ) if( ierr/=0 ) then if( ierr>0 .and. ierr<=n ) then @@ -18706,7 +18708,7 @@ module stdlib_linalg_lapack_w else chtemp = 'R' end if - call stdlib_wtgevc( chtemp, 'B', ldumma, n, a, lda, b, ldb, vl, ldvl,vr, ldvr, n, & + call stdlib_${ci}$tgevc( chtemp, 'B', ldumma, n, a, lda, b, ldb, vl, ldvl,vr, ldvr, n, & in, work( iwrk ), rwork( irwrk ),ierr ) if( ierr/=0 ) then info = n + 2 @@ -18715,7 +18717,7 @@ module stdlib_linalg_lapack_w ! undo balancing on vl and vr and normalization ! (workspace: none needed) if( ilvl ) then - call stdlib_wggbak( 'P', 'L', n, ilo, ihi, rwork( ileft ),rwork( iright ), n, vl,& + call stdlib_${ci}$ggbak( 'P', 'L', n, ilo, ihi, rwork( ileft ),rwork( iright ), n, vl,& ldvl, ierr ) loop_30: do jc = 1, n temp = zero @@ -18730,7 +18732,7 @@ module stdlib_linalg_lapack_w end do loop_30 end if if( ilvr ) then - call stdlib_wggbak( 'P', 'R', n, ilo, ihi, rwork( ileft ),rwork( iright ), n, vr,& + call stdlib_${ci}$ggbak( 'P', 'R', n, ilo, ihi, rwork( ileft ),rwork( iright ), n, vr,& ldvr, ierr ) loop_60: do jc = 1, n temp = zero @@ -18747,14 +18749,14 @@ module stdlib_linalg_lapack_w end if ! undo scaling if necessary 70 continue - if( ilascl )call stdlib_wlascl( 'G', 0, 0, anrmto, anrm, n, 1, alpha, n, ierr ) - if( ilbscl )call stdlib_wlascl( 'G', 0, 0, bnrmto, bnrm, n, 1, beta, n, ierr ) + if( ilascl )call stdlib_${ci}$lascl( 'G', 0, 0, anrmto, anrm, n, 1, alpha, n, ierr ) + if( ilbscl )call stdlib_${ci}$lascl( 'G', 0, 0, bnrmto, bnrm, n, 1, beta, n, ierr ) work( 1 ) = lwkopt return - end subroutine stdlib_wggev + end subroutine stdlib_${ci}$ggev - subroutine stdlib_wggev3( jobvl, jobvr, n, a, lda, b, ldb, alpha, beta,vl, ldvl, vr, ldvr, & + subroutine stdlib_${ci}$ggev3( jobvl, jobvr, n, a, lda, b, ldb, alpha, beta,vl, ldvl, vr, ldvr, & !! ZGGEV3: computes for a pair of N-by-N complex nonsymmetric matrices !! (A,B), the generalized eigenvalues, and optionally, the left and/or !! right generalized eigenvectors. @@ -18779,9 +18781,9 @@ module stdlib_linalg_lapack_w integer(ilp), intent(out) :: info integer(ilp), intent(in) :: lda, ldb, ldvl, ldvr, lwork, n ! Array Arguments - real(qp), intent(out) :: rwork(*) - complex(qp), intent(inout) :: a(lda,*), b(ldb,*) - complex(qp), intent(out) :: alpha(*), beta(*), vl(ldvl,*), vr(ldvr,*), work(*) + real(${ck}$), intent(out) :: rwork(*) + complex(${ck}$), intent(inout) :: a(lda,*), b(ldb,*) + complex(${ck}$), intent(out) :: alpha(*), beta(*), vl(ldvl,*), vr(ldvr,*), work(*) ! ===================================================================== @@ -18790,16 +18792,16 @@ module stdlib_linalg_lapack_w character :: chtemp integer(ilp) :: icols, ierr, ihi, ijobvl, ijobvr, ileft, ilo, in, iright, irows, irwrk,& itau, iwrk, jc, jr, lwkopt - real(qp) :: anrm, anrmto, bignum, bnrm, bnrmto, eps, smlnum, temp - complex(qp) :: x + real(${ck}$) :: anrm, anrmto, bignum, bnrm, bnrmto, eps, smlnum, temp + complex(${ck}$) :: x ! Local Arrays logical(lk) :: ldumma(1) ! Intrinsic Functions intrinsic :: abs,real,aimag,max,sqrt ! Statement Functions - real(qp) :: abs1 + real(${ck}$) :: abs1 ! Statement Function Definitions - abs1( x ) = abs( real( x,KIND=qp) ) + abs( aimag( x ) ) + abs1( x ) = abs( real( x,KIND=${ck}$) ) + abs( aimag( x ) ) ! Executable Statements ! decode the input arguments if( stdlib_lsame( jobvl, 'N' ) ) then @@ -18845,30 +18847,30 @@ module stdlib_linalg_lapack_w end if ! compute workspace if( info==0 ) then - call stdlib_wgeqrf( n, n, b, ldb, work, work, -1, ierr ) + call stdlib_${ci}$geqrf( n, n, b, ldb, work, work, -1, ierr ) lwkopt = max( 1, n+int( work( 1 ),KIND=ilp) ) - call stdlib_wunmqr( 'L', 'C', n, n, n, b, ldb, work, a, lda, work,-1, ierr ) + call stdlib_${ci}$unmqr( 'L', 'C', n, n, n, b, ldb, work, a, lda, work,-1, ierr ) lwkopt = max( lwkopt, n+int( work( 1 ),KIND=ilp) ) if( ilvl ) then - call stdlib_wungqr( n, n, n, vl, ldvl, work, work, -1, ierr ) + call stdlib_${ci}$ungqr( n, n, n, vl, ldvl, work, work, -1, ierr ) lwkopt = max( lwkopt, n+int( work( 1 ),KIND=ilp) ) end if if( ilv ) then - call stdlib_wgghd3( jobvl, jobvr, n, 1, n, a, lda, b, ldb, vl,ldvl, vr, ldvr, & + call stdlib_${ci}$gghd3( jobvl, jobvr, n, 1, n, a, lda, b, ldb, vl,ldvl, vr, ldvr, & work, -1, ierr ) lwkopt = max( lwkopt, n+int( work( 1 ),KIND=ilp) ) - call stdlib_wlaqz0( 'S', jobvl, jobvr, n, 1, n, a, lda, b, ldb,alpha, beta, vl, & + call stdlib_${ci}$laqz0( 'S', jobvl, jobvr, n, 1, n, a, lda, b, ldb,alpha, beta, vl, & ldvl, vr, ldvr, work, -1,rwork, 0, ierr ) lwkopt = max( lwkopt, n+int( work( 1 ),KIND=ilp) ) else - call stdlib_wgghd3( jobvl, jobvr, n, 1, n, a, lda, b, ldb, vl,ldvl, vr, ldvr, & + call stdlib_${ci}$gghd3( jobvl, jobvr, n, 1, n, a, lda, b, ldb, vl,ldvl, vr, ldvr, & work, -1, ierr ) lwkopt = max( lwkopt, n+int( work( 1 ),KIND=ilp) ) - call stdlib_wlaqz0( 'E', jobvl, jobvr, n, 1, n, a, lda, b, ldb,alpha, beta, vl, & + call stdlib_${ci}$laqz0( 'E', jobvl, jobvr, n, 1, n, a, lda, b, ldb,alpha, beta, vl, & ldvl, vr, ldvr, work, -1,rwork, 0, ierr ) lwkopt = max( lwkopt, n+int( work( 1 ),KIND=ilp) ) end if - work( 1 ) = cmplx( lwkopt,KIND=qp) + work( 1 ) = cmplx( lwkopt,KIND=${ck}$) end if if( info/=0 ) then call stdlib_xerbla( 'ZGGEV3 ', -info ) @@ -18879,14 +18881,14 @@ module stdlib_linalg_lapack_w ! quick return if possible if( n==0 )return ! get machine constants - eps = stdlib_qlamch( 'E' )*stdlib_qlamch( 'B' ) - smlnum = stdlib_qlamch( 'S' ) + eps = stdlib_${c2ri(ci)}$lamch( 'E' )*stdlib_${c2ri(ci)}$lamch( 'B' ) + smlnum = stdlib_${c2ri(ci)}$lamch( 'S' ) bignum = one / smlnum - call stdlib_qlabad( smlnum, bignum ) + call stdlib_${c2ri(ci)}$labad( smlnum, bignum ) smlnum = sqrt( smlnum ) / eps bignum = one / smlnum ! scale a if max element outside range [smlnum,bignum] - anrm = stdlib_wlange( 'M', n, n, a, lda, rwork ) + anrm = stdlib_${ci}$lange( 'M', n, n, a, lda, rwork ) ilascl = .false. if( anrm>zero .and. anrmzero .and. bnrm1 ) then - call stdlib_wlacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,vl( ilo+1, ilo ),& + call stdlib_${ci}$lacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,vl( ilo+1, ilo ),& ldvl ) end if - call stdlib_wungqr( irows, irows, irows, vl( ilo, ilo ), ldvl,work( itau ), work( & + call stdlib_${ci}$ungqr( irows, irows, irows, vl( ilo, ilo ), ldvl,work( itau ), work( & iwrk ), lwork+1-iwrk, ierr ) end if ! initialize vr - if( ilvr )call stdlib_wlaset( 'FULL', n, n, czero, cone, vr, ldvr ) + if( ilvr )call stdlib_${ci}$laset( 'FULL', n, n, czero, cone, vr, ldvr ) ! reduce to generalized hessenberg form if( ilv ) then ! eigenvectors requested -- work on whole matrix. - call stdlib_wgghd3( jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb, vl,ldvl, vr, ldvr, & + call stdlib_${ci}$gghd3( jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb, vl,ldvl, vr, ldvr, & work( iwrk ), lwork+1-iwrk, ierr ) else - call stdlib_wgghd3( 'N', 'N', irows, 1, irows, a( ilo, ilo ), lda,b( ilo, ilo ), & + call stdlib_${ci}$gghd3( 'N', 'N', irows, 1, irows, a( ilo, ilo ), lda,b( ilo, ilo ), & ldb, vl, ldvl, vr, ldvr,work( iwrk ), lwork+1-iwrk, ierr ) end if ! perform qz algorithm (compute eigenvalues, and optionally, the @@ -18956,7 +18958,7 @@ module stdlib_linalg_lapack_w else chtemp = 'E' end if - call stdlib_wlaqz0( chtemp, jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb,alpha, beta, vl, & + call stdlib_${ci}$laqz0( chtemp, jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb,alpha, beta, vl, & ldvl, vr, ldvr, work( iwrk ),lwork+1-iwrk, rwork( irwrk ), 0, ierr ) if( ierr/=0 ) then if( ierr>0 .and. ierr<=n ) then @@ -18979,7 +18981,7 @@ module stdlib_linalg_lapack_w else chtemp = 'R' end if - call stdlib_wtgevc( chtemp, 'B', ldumma, n, a, lda, b, ldb, vl, ldvl,vr, ldvr, n, & + call stdlib_${ci}$tgevc( chtemp, 'B', ldumma, n, a, lda, b, ldb, vl, ldvl,vr, ldvr, n, & in, work( iwrk ), rwork( irwrk ),ierr ) if( ierr/=0 ) then info = n + 2 @@ -18987,7 +18989,7 @@ module stdlib_linalg_lapack_w end if ! undo balancing on vl and vr and normalization if( ilvl ) then - call stdlib_wggbak( 'P', 'L', n, ilo, ihi, rwork( ileft ),rwork( iright ), n, vl,& + call stdlib_${ci}$ggbak( 'P', 'L', n, ilo, ihi, rwork( ileft ),rwork( iright ), n, vl,& ldvl, ierr ) loop_30: do jc = 1, n temp = zero @@ -19002,7 +19004,7 @@ module stdlib_linalg_lapack_w end do loop_30 end if if( ilvr ) then - call stdlib_wggbak( 'P', 'R', n, ilo, ihi, rwork( ileft ),rwork( iright ), n, vr,& + call stdlib_${ci}$ggbak( 'P', 'R', n, ilo, ihi, rwork( ileft ),rwork( iright ), n, vr,& ldvr, ierr ) loop_60: do jc = 1, n temp = zero @@ -19019,14 +19021,14 @@ module stdlib_linalg_lapack_w end if ! undo scaling if necessary 70 continue - if( ilascl )call stdlib_wlascl( 'G', 0, 0, anrmto, anrm, n, 1, alpha, n, ierr ) - if( ilbscl )call stdlib_wlascl( 'G', 0, 0, bnrmto, bnrm, n, 1, beta, n, ierr ) - work( 1 ) = cmplx( lwkopt,KIND=qp) + if( ilascl )call stdlib_${ci}$lascl( 'G', 0, 0, anrmto, anrm, n, 1, alpha, n, ierr ) + if( ilbscl )call stdlib_${ci}$lascl( 'G', 0, 0, bnrmto, bnrm, n, 1, beta, n, ierr ) + work( 1 ) = cmplx( lwkopt,KIND=${ck}$) return - end subroutine stdlib_wggev3 + end subroutine stdlib_${ci}$ggev3 - subroutine stdlib_wggevx( balanc, jobvl, jobvr, sense, n, a, lda, b, ldb,alpha, beta, vl, & + subroutine stdlib_${ci}$ggevx( balanc, jobvl, jobvr, sense, n, a, lda, b, ldb,alpha, beta, vl, & !! ZGGEVX: computes for a pair of N-by-N complex nonsymmetric matrices !! (A,B) the generalized eigenvalues, and optionally, the left and/or !! right generalized eigenvectors. @@ -19056,13 +19058,13 @@ module stdlib_linalg_lapack_w character, intent(in) :: balanc, jobvl, jobvr, sense integer(ilp), intent(out) :: ihi, ilo, info integer(ilp), intent(in) :: lda, ldb, ldvl, ldvr, lwork, n - real(qp), intent(out) :: abnrm, bbnrm + real(${ck}$), intent(out) :: abnrm, bbnrm ! Array Arguments logical(lk), intent(out) :: bwork(*) integer(ilp), intent(out) :: iwork(*) - real(qp), intent(out) :: lscale(*), rconde(*), rcondv(*), rscale(*), rwork(*) - complex(qp), intent(inout) :: a(lda,*), b(ldb,*) - complex(qp), intent(out) :: alpha(*), beta(*), vl(ldvl,*), vr(ldvr,*), work(*) + real(${ck}$), intent(out) :: lscale(*), rconde(*), rcondv(*), rscale(*), rwork(*) + complex(${ck}$), intent(inout) :: a(lda,*), b(ldb,*) + complex(${ck}$), intent(out) :: alpha(*), beta(*), vl(ldvl,*), vr(ldvr,*), work(*) ! ===================================================================== @@ -19072,16 +19074,16 @@ module stdlib_linalg_lapack_w character :: chtemp integer(ilp) :: i, icols, ierr, ijobvl, ijobvr, in, irows, itau, iwrk, iwrk1, j, jc, & jr, m, maxwrk, minwrk - real(qp) :: anrm, anrmto, bignum, bnrm, bnrmto, eps, smlnum, temp - complex(qp) :: x + real(${ck}$) :: anrm, anrmto, bignum, bnrm, bnrmto, eps, smlnum, temp + complex(${ck}$) :: x ! Local Arrays logical(lk) :: ldumma(1) ! Intrinsic Functions intrinsic :: abs,real,aimag,max,sqrt ! Statement Functions - real(qp) :: abs1 + real(${ck}$) :: abs1 ! Statement Function Definitions - abs1( x ) = abs( real( x,KIND=qp) ) + abs( aimag( x ) ) + abs1( x ) = abs( real( x,KIND=${ck}$) ) + abs( aimag( x ) ) ! Executable Statements ! decode the input arguments if( stdlib_lsame( jobvl, 'N' ) ) then @@ -19175,14 +19177,14 @@ module stdlib_linalg_lapack_w ! quick return if possible if( n==0 )return ! get machine constants - eps = stdlib_qlamch( 'P' ) - smlnum = stdlib_qlamch( 'S' ) + eps = stdlib_${c2ri(ci)}$lamch( 'P' ) + smlnum = stdlib_${c2ri(ci)}$lamch( 'S' ) bignum = one / smlnum - call stdlib_qlabad( smlnum, bignum ) + call stdlib_${c2ri(ci)}$labad( smlnum, bignum ) smlnum = sqrt( smlnum ) / eps bignum = one / smlnum ! scale a if max element outside range [smlnum,bignum] - anrm = stdlib_wlange( 'M', n, n, a, lda, rwork ) + anrm = stdlib_${ci}$lange( 'M', n, n, a, lda, rwork ) ilascl = .false. if( anrm>zero .and. anrmzero .and. bnrm1 ) then - call stdlib_wlacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,vl( ilo+1, ilo ),& + call stdlib_${ci}$lacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,vl( ilo+1, ilo ),& ldvl ) end if - call stdlib_wungqr( irows, irows, irows, vl( ilo, ilo ), ldvl,work( itau ), work( & + call stdlib_${ci}$ungqr( irows, irows, irows, vl( ilo, ilo ), ldvl,work( itau ), work( & iwrk ), lwork+1-iwrk, ierr ) end if - if( ilvr )call stdlib_wlaset( 'FULL', n, n, czero, cone, vr, ldvr ) + if( ilvr )call stdlib_${ci}$laset( 'FULL', n, n, czero, cone, vr, ldvr ) ! reduce to generalized hessenberg form ! (workspace: none needed) if( ilv .or. .not.wantsn ) then ! eigenvectors requested -- work on whole matrix. - call stdlib_wgghrd( jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb, vl,ldvl, vr, ldvr, & + call stdlib_${ci}$gghrd( jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb, vl,ldvl, vr, ldvr, & ierr ) else - call stdlib_wgghrd( 'N', 'N', irows, 1, irows, a( ilo, ilo ), lda,b( ilo, ilo ), & + call stdlib_${ci}$gghrd( 'N', 'N', irows, 1, irows, a( ilo, ilo ), lda,b( ilo, ilo ), & ldb, vl, ldvl, vr, ldvr, ierr ) end if ! perform qz algorithm (compute eigenvalues, and optionally, the @@ -19268,7 +19270,7 @@ module stdlib_linalg_lapack_w else chtemp = 'E' end if - call stdlib_whgeqz( chtemp, jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb,alpha, beta, vl, & + call stdlib_${ci}$hgeqz( chtemp, jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb,alpha, beta, vl, & ldvl, vr, ldvr, work( iwrk ),lwork+1-iwrk, rwork, ierr ) if( ierr/=0 ) then if( ierr>0 .and. ierr<=n ) then @@ -19281,9 +19283,9 @@ module stdlib_linalg_lapack_w go to 90 end if ! compute eigenvectors and estimate condition numbers if desired - ! stdlib_wtgevc: (complex workspace: need 2*n ) + ! stdlib_${ci}$tgevc: (complex workspace: need 2*n ) ! (real workspace: need 2*n ) - ! stdlib_wtgsna: (complex workspace: need 2*n*n if sense='v' or 'b') + ! stdlib_${ci}$tgsna: (complex workspace: need 2*n*n if sense='v' or 'b') ! (integer workspace: need n+2 ) if( ilv .or. .not.wantsn ) then if( ilv ) then @@ -19296,7 +19298,7 @@ module stdlib_linalg_lapack_w else chtemp = 'R' end if - call stdlib_wtgevc( chtemp, 'B', ldumma, n, a, lda, b, ldb, vl,ldvl, vr, ldvr, n,& + call stdlib_${ci}$tgevc( chtemp, 'B', ldumma, n, a, lda, b, ldb, vl,ldvl, vr, ldvr, n,& in, work( iwrk ), rwork,ierr ) if( ierr/=0 ) then info = n + 2 @@ -19304,8 +19306,8 @@ module stdlib_linalg_lapack_w end if end if if( .not.wantsn ) then - ! compute eigenvectors (stdlib_wtgevc) and estimate condition - ! numbers (stdlib_wtgsna). note that the definition of the condition + ! compute eigenvectors (stdlib_${ci}$tgevc) and estimate condition + ! numbers (stdlib_${ci}$tgsna). note that the definition of the condition ! number is not invariant under transformation (u,v) to ! (q*u, z*v), where (u,v) are eigenvectors of the generalized ! schur form (s,t), q and z are orthogonal matrices. in order @@ -19320,14 +19322,14 @@ module stdlib_linalg_lapack_w iwrk = n + 1 iwrk1 = iwrk + n if( wantse .or. wantsb ) then - call stdlib_wtgevc( 'B', 'S', bwork, n, a, lda, b, ldb,work( 1 ), n, work( & + call stdlib_${ci}$tgevc( 'B', 'S', bwork, n, a, lda, b, ldb,work( 1 ), n, work( & iwrk ), n, 1, m,work( iwrk1 ), rwork, ierr ) if( ierr/=0 ) then info = n + 2 go to 90 end if end if - call stdlib_wtgsna( sense, 'S', bwork, n, a, lda, b, ldb,work( 1 ), n, work( & + call stdlib_${ci}$tgsna( sense, 'S', bwork, n, a, lda, b, ldb,work( 1 ), n, work( & iwrk ), n, rconde( i ),rcondv( i ), 1, m, work( iwrk1 ),lwork-iwrk1+1, iwork, & ierr ) end do @@ -19336,7 +19338,7 @@ module stdlib_linalg_lapack_w ! undo balancing on vl and vr and normalization ! (workspace: none needed) if( ilvl ) then - call stdlib_wggbak( balanc, 'L', n, ilo, ihi, lscale, rscale, n, vl,ldvl, ierr ) + call stdlib_${ci}$ggbak( balanc, 'L', n, ilo, ihi, lscale, rscale, n, vl,ldvl, ierr ) loop_50: do jc = 1, n temp = zero @@ -19351,7 +19353,7 @@ module stdlib_linalg_lapack_w end do loop_50 end if if( ilvr ) then - call stdlib_wggbak( balanc, 'R', n, ilo, ihi, lscale, rscale, n, vr,ldvr, ierr ) + call stdlib_${ci}$ggbak( balanc, 'R', n, ilo, ihi, lscale, rscale, n, vr,ldvr, ierr ) loop_80: do jc = 1, n temp = zero @@ -19367,14 +19369,14 @@ module stdlib_linalg_lapack_w end if ! undo scaling if necessary 90 continue - if( ilascl )call stdlib_wlascl( 'G', 0, 0, anrmto, anrm, n, 1, alpha, n, ierr ) - if( ilbscl )call stdlib_wlascl( 'G', 0, 0, bnrmto, bnrm, n, 1, beta, n, ierr ) + if( ilascl )call stdlib_${ci}$lascl( 'G', 0, 0, anrmto, anrm, n, 1, alpha, n, ierr ) + if( ilbscl )call stdlib_${ci}$lascl( 'G', 0, 0, bnrmto, bnrm, n, 1, beta, n, ierr ) work( 1 ) = maxwrk return - end subroutine stdlib_wggevx + end subroutine stdlib_${ci}$ggevx - pure subroutine stdlib_wggglm( n, m, p, a, lda, b, ldb, d, x, y, work, lwork,info ) + pure subroutine stdlib_${ci}$ggglm( n, m, p, a, lda, b, ldb, d, x, y, work, lwork,info ) !! ZGGGLM: solves a general Gauss-Markov linear model (GLM) problem: !! minimize || y ||_2 subject to d = A*x + B*y !! x @@ -19400,8 +19402,8 @@ module stdlib_linalg_lapack_w integer(ilp), intent(out) :: info integer(ilp), intent(in) :: lda, ldb, lwork, m, n, p ! Array Arguments - complex(qp), intent(inout) :: a(lda,*), b(ldb,*), d(*) - complex(qp), intent(out) :: work(*), x(*), y(*) + complex(${ck}$), intent(inout) :: a(lda,*), b(ldb,*), d(*) + complex(${ck}$), intent(out) :: work(*), x(*), y(*) ! =================================================================== ! Local Scalars @@ -19466,51 +19468,51 @@ module stdlib_linalg_lapack_w ! m m+p-n n-m ! where r11 and t22 are upper triangular, and q and z are ! unitary. - call stdlib_wggqrf( n, m, p, a, lda, work, b, ldb, work( m+1 ),work( m+np+1 ), lwork-m-& + call stdlib_${ci}$ggqrf( n, m, p, a, lda, work, b, ldb, work( m+1 ),work( m+np+1 ), lwork-m-& np, info ) - lopt = real( work( m+np+1 ),KIND=qp) + lopt = real( work( m+np+1 ),KIND=${ck}$) ! update left-hand-side vector d = q**h*d = ( d1 ) m ! ( d2 ) n-m - call stdlib_wunmqr( 'LEFT', 'CONJUGATE TRANSPOSE', n, 1, m, a, lda, work,d, max( 1, n )& + call stdlib_${ci}$unmqr( 'LEFT', 'CONJUGATE TRANSPOSE', n, 1, m, a, lda, work,d, max( 1, n )& , work( m+np+1 ), lwork-m-np, info ) lopt = max( lopt, int( work( m+np+1 ),KIND=ilp) ) ! solve t22*y2 = d2 for y2 if( n>m ) then - call stdlib_wtrtrs( 'UPPER', 'NO TRANSPOSE', 'NON UNIT', n-m, 1,b( m+1, m+p-n+1 ), & + call stdlib_${ci}$trtrs( 'UPPER', 'NO TRANSPOSE', 'NON UNIT', n-m, 1,b( m+1, m+p-n+1 ), & ldb, d( m+1 ), n-m, info ) if( info>0 ) then info = 1 return end if - call stdlib_wcopy( n-m, d( m+1 ), 1, y( m+p-n+1 ), 1 ) + call stdlib_${ci}$copy( n-m, d( m+1 ), 1, y( m+p-n+1 ), 1 ) end if ! set y1 = 0 do i = 1, m + p - n y( i ) = czero end do ! update d1 = d1 - t12*y2 - call stdlib_wgemv( 'NO TRANSPOSE', m, n-m, -cone, b( 1, m+p-n+1 ), ldb,y( m+p-n+1 ), 1,& + call stdlib_${ci}$gemv( 'NO TRANSPOSE', m, n-m, -cone, b( 1, m+p-n+1 ), ldb,y( m+p-n+1 ), 1,& cone, d, 1 ) ! solve triangular system: r11*x = d1 if( m>0 ) then - call stdlib_wtrtrs( 'UPPER', 'NO TRANSPOSE', 'NON UNIT', m, 1, a, lda,d, m, info ) + call stdlib_${ci}$trtrs( 'UPPER', 'NO TRANSPOSE', 'NON UNIT', m, 1, a, lda,d, m, info ) if( info>0 ) then info = 2 return end if ! copy d to x - call stdlib_wcopy( m, d, 1, x, 1 ) + call stdlib_${ci}$copy( m, d, 1, x, 1 ) end if ! backward transformation y = z**h *y - call stdlib_wunmrq( 'LEFT', 'CONJUGATE TRANSPOSE', p, 1, np,b( max( 1, n-p+1 ), 1 ), & + call stdlib_${ci}$unmrq( 'LEFT', 'CONJUGATE TRANSPOSE', p, 1, np,b( max( 1, n-p+1 ), 1 ), & ldb, work( m+1 ), y,max( 1, p ), work( m+np+1 ), lwork-m-np, info ) work( 1 ) = m + np + max( lopt, int( work( m+np+1 ),KIND=ilp) ) return - end subroutine stdlib_wggglm + end subroutine stdlib_${ci}$ggglm - pure subroutine stdlib_wgghd3( compq, compz, n, ilo, ihi, a, lda, b, ldb, q,ldq, z, ldz, & + pure subroutine stdlib_${ci}$gghd3( compq, compz, n, ilo, ihi, a, lda, b, ldb, q,ldq, z, ldz, & !! ZGGHD3: reduces a pair of complex matrices (A,B) to generalized upper !! Hessenberg form using unitary transformations, where A is a !! general matrix and B is upper triangular. The form of the @@ -19545,8 +19547,8 @@ module stdlib_linalg_lapack_w integer(ilp), intent(in) :: ihi, ilo, lda, ldb, ldq, ldz, n, lwork integer(ilp), intent(out) :: info ! Array Arguments - complex(qp), intent(inout) :: a(lda,*), b(ldb,*), q(ldq,*), z(ldz,*) - complex(qp), intent(out) :: work(*) + complex(${ck}$), intent(inout) :: a(lda,*), b(ldb,*), q(ldq,*), z(ldz,*) + complex(${ck}$), intent(out) :: work(*) ! ===================================================================== ! Local Scalars @@ -19554,8 +19556,8 @@ module stdlib_linalg_lapack_w character :: compq2, compz2 integer(ilp) :: cola, i, ierr, j, j0, jcol, jj, jrow, k, kacc22, len, lwkopt, n2nb, nb,& nblst, nbmin, nh, nnb, nx, ppw, ppwo, pw, top, topq - real(qp) :: c - complex(qp) :: c1, c2, ctemp, s, s1, s2, temp, temp1, temp2, temp3 + real(${ck}$) :: c + complex(${ck}$) :: c1, c2, ctemp, s, s1, s2, temp, temp1, temp2, temp3 ! Intrinsic Functions intrinsic :: real,cmplx,conjg,max ! Executable Statements @@ -19563,7 +19565,7 @@ module stdlib_linalg_lapack_w info = 0 nb = stdlib_ilaenv( 1, 'ZGGHD3', ' ', n, ilo, ihi, -1 ) lwkopt = max( 6*n*nb, 1 ) - work( 1 ) = cmplx( lwkopt,KIND=qp) + work( 1 ) = cmplx( lwkopt,KIND=${ck}$) initq = stdlib_lsame( compq, 'I' ) wantq = initq .or. stdlib_lsame( compq, 'V' ) initz = stdlib_lsame( compz, 'I' ) @@ -19597,10 +19599,10 @@ module stdlib_linalg_lapack_w return end if ! initialize q and z if desired. - if( initq )call stdlib_wlaset( 'ALL', n, n, czero, cone, q, ldq ) - if( initz )call stdlib_wlaset( 'ALL', n, n, czero, cone, z, ldz ) + if( initq )call stdlib_${ci}$laset( 'ALL', n, n, czero, cone, q, ldq ) + if( initz )call stdlib_${ci}$laset( 'ALL', n, n, czero, cone, z, ldz ) ! zero out lower triangle of b. - if( n>1 )call stdlib_wlaset( 'LOWER', n-1, n-1, czero, czero, b(2, 1), ldb ) + if( n>1 )call stdlib_${ci}$laset( 'LOWER', n-1, n-1, czero, czero, b(2, 1), ldb ) ! quick return if possible nh = ihi - ilo + 1 if( nh<=1 ) then @@ -19643,10 +19645,10 @@ module stdlib_linalg_lapack_w ! factor. n2nb = ( ihi-jcol-1 ) / nnb - 1 nblst = ihi - jcol - n2nb*nnb - call stdlib_wlaset( 'ALL', nblst, nblst, czero, cone, work, nblst ) + call stdlib_${ci}$laset( 'ALL', nblst, nblst, czero, cone, work, nblst ) pw = nblst * nblst + 1 do i = 1, n2nb - call stdlib_wlaset( 'ALL', 2*nnb, 2*nnb, czero, cone,work( pw ), 2*nnb ) + call stdlib_${ci}$laset( 'ALL', 2*nnb, 2*nnb, czero, cone,work( pw ), 2*nnb ) pw = pw + 4*nnb*nnb end do @@ -19656,8 +19658,8 @@ module stdlib_linalg_lapack_w ! column of a and b, respectively. do i = ihi, j+2, -1 temp = a( i-1, j ) - call stdlib_wlartg( temp, a( i, j ), c, s, a( i-1, j ) ) - a( i, j ) = cmplx( c,KIND=qp) + call stdlib_${ci}$lartg( temp, a( i, j ), c, s, a( i-1, j ) ) + a( i, j ) = cmplx( c,KIND=${ck}$) b( i, j ) = s end do ! accumulate givens rotations into workspace array. @@ -19714,11 +19716,11 @@ module stdlib_linalg_lapack_w ! annihilate b( jj+1, jj ). if( jj0 ) then do i = jj, 1, -1 - c = real( a( j+1+i, j ),KIND=qp) - call stdlib_wrot( ihi-top, a( top+1, j+i+1 ), 1,a( top+1, j+i ), 1, c,-& + c = real( a( j+1+i, j ),KIND=${ck}$) + call stdlib_${ci}$rot( ihi-top, a( top+1, j+i+1 ), 1,a( top+1, j+i ), 1, c,-& conjg( b( j+1+i, j ) ) ) end do end if @@ -19762,16 +19764,16 @@ module stdlib_linalg_lapack_w ! where u21 is a len-by-len matrix and u12 is lower ! triangular. jrow = ihi - nblst + 1 - call stdlib_wgemv( 'CONJUGATE', nblst, len, cone, work,nblst, a( jrow, j+1 & + call stdlib_${ci}$gemv( 'CONJUGATE', nblst, len, cone, work,nblst, a( jrow, j+1 & ), 1, czero,work( pw ), 1 ) ppw = pw + len do i = jrow, jrow+nblst-len-1 work( ppw ) = a( i, j+1 ) ppw = ppw + 1 end do - call stdlib_wtrmv( 'LOWER', 'CONJUGATE', 'NON-UNIT',nblst-len, work( & + call stdlib_${ci}$trmv( 'LOWER', 'CONJUGATE', 'NON-UNIT',nblst-len, work( & len*nblst + 1 ), nblst,work( pw+len ), 1 ) - call stdlib_wgemv( 'CONJUGATE', len, nblst-len, cone,work( (len+1)*nblst - & + call stdlib_${ci}$gemv( 'CONJUGATE', len, nblst-len, cone,work( (len+1)*nblst - & len + 1 ), nblst,a( jrow+nblst-len, j+1 ), 1, cone,work( pw+len ), 1 ) ppw = pw @@ -19802,13 +19804,13 @@ module stdlib_linalg_lapack_w work( ppw ) = a( i, j+1 ) ppw = ppw + 1 end do - call stdlib_wtrmv( 'UPPER', 'CONJUGATE', 'NON-UNIT', len,work( ppwo + & + call stdlib_${ci}$trmv( 'UPPER', 'CONJUGATE', 'NON-UNIT', len,work( ppwo + & nnb ), 2*nnb, work( pw ),1 ) - call stdlib_wtrmv( 'LOWER', 'CONJUGATE', 'NON-UNIT', nnb,work( ppwo + & + call stdlib_${ci}$trmv( 'LOWER', 'CONJUGATE', 'NON-UNIT', nnb,work( ppwo + & 2*len*nnb ),2*nnb, work( pw + len ), 1 ) - call stdlib_wgemv( 'CONJUGATE', nnb, len, cone,work( ppwo ), 2*nnb, a( & + call stdlib_${ci}$gemv( 'CONJUGATE', nnb, len, cone,work( ppwo ), 2*nnb, a( & jrow, j+1 ), 1,cone, work( pw ), 1 ) - call stdlib_wgemv( 'CONJUGATE', len, nnb, cone,work( ppwo + 2*len*nnb + & + call stdlib_${ci}$gemv( 'CONJUGATE', len, nnb, cone,work( ppwo + 2*len*nnb + & nnb ), 2*nnb,a( jrow+nnb, j+1 ), 1, cone,work( pw+len ), 1 ) ppw = pw do i = jrow, jrow+len+nnb-1 @@ -19822,9 +19824,9 @@ module stdlib_linalg_lapack_w ! apply accumulated unitary matrices to a. cola = n - jcol - nnb + 1 j = ihi - nblst + 1 - call stdlib_wgemm( 'CONJUGATE', 'NO TRANSPOSE', nblst,cola, nblst, cone, work, & + call stdlib_${ci}$gemm( 'CONJUGATE', 'NO TRANSPOSE', nblst,cola, nblst, cone, work, & nblst,a( j, jcol+nnb ), lda, czero, work( pw ),nblst ) - call stdlib_wlacpy( 'ALL', nblst, cola, work( pw ), nblst,a( j, jcol+nnb ), lda ) + call stdlib_${ci}$lacpy( 'ALL', nblst, cola, work( pw ), nblst,a( j, jcol+nnb ), lda ) ppwo = nblst*nblst + 1 j0 = j - nnb @@ -19836,14 +19838,14 @@ module stdlib_linalg_lapack_w ! [ u21 u22 ], ! where all blocks are nnb-by-nnb, u21 is upper ! triangular and u12 is lower triangular. - call stdlib_wunm22( 'LEFT', 'CONJUGATE', 2*nnb, cola, nnb,nnb, work( ppwo )& + call stdlib_${ci}$unm22( 'LEFT', 'CONJUGATE', 2*nnb, cola, nnb,nnb, work( ppwo )& , 2*nnb,a( j, jcol+nnb ), lda, work( pw ),lwork-pw+1, ierr ) else ! ignore the structure of u. - call stdlib_wgemm( 'CONJUGATE', 'NO TRANSPOSE', 2*nnb,cola, 2*nnb, cone, & + call stdlib_${ci}$gemm( 'CONJUGATE', 'NO TRANSPOSE', 2*nnb,cola, 2*nnb, cone, & work( ppwo ), 2*nnb,a( j, jcol+nnb ), lda, czero, work( pw ),2*nnb ) - call stdlib_wlacpy( 'ALL', 2*nnb, cola, work( pw ), 2*nnb,a( j, jcol+nnb ),& + call stdlib_${ci}$lacpy( 'ALL', 2*nnb, cola, work( pw ), 2*nnb,a( j, jcol+nnb ),& lda ) end if ppwo = ppwo + 4*nnb*nnb @@ -19858,9 +19860,9 @@ module stdlib_linalg_lapack_w topq = 1 nh = n end if - call stdlib_wgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', nh,nblst, nblst, cone, q( & + call stdlib_${ci}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', nh,nblst, nblst, cone, q( & topq, j ), ldq,work, nblst, czero, work( pw ), nh ) - call stdlib_wlacpy( 'ALL', nh, nblst, work( pw ), nh,q( topq, j ), ldq ) + call stdlib_${ci}$lacpy( 'ALL', nh, nblst, work( pw ), nh,q( topq, j ), ldq ) ppwo = nblst*nblst + 1 j0 = j - nnb @@ -19871,14 +19873,14 @@ module stdlib_linalg_lapack_w end if if ( blk22 ) then ! exploit the structure of u. - call stdlib_wunm22( 'RIGHT', 'NO TRANSPOSE', nh, 2*nnb,nnb, nnb, work( & + call stdlib_${ci}$unm22( 'RIGHT', 'NO TRANSPOSE', nh, 2*nnb,nnb, nnb, work( & ppwo ), 2*nnb,q( topq, j ), ldq, work( pw ),lwork-pw+1, ierr ) else ! ignore the structure of u. - call stdlib_wgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', nh,2*nnb, 2*nnb, & + call stdlib_${ci}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', nh,2*nnb, 2*nnb, & cone, q( topq, j ), ldq,work( ppwo ), 2*nnb, czero, work( pw ),nh ) - call stdlib_wlacpy( 'ALL', nh, 2*nnb, work( pw ), nh,q( topq, j ), ldq ) + call stdlib_${ci}$lacpy( 'ALL', nh, 2*nnb, work( pw ), nh,q( topq, j ), ldq ) end if ppwo = ppwo + 4*nnb*nnb @@ -19888,10 +19890,10 @@ module stdlib_linalg_lapack_w if ( wantz .or. top>0 ) then ! initialize small unitary factors that will hold the ! accumulated givens rotations in workspace. - call stdlib_wlaset( 'ALL', nblst, nblst, czero, cone, work,nblst ) + call stdlib_${ci}$laset( 'ALL', nblst, nblst, czero, cone, work,nblst ) pw = nblst * nblst + 1 do i = 1, n2nb - call stdlib_wlaset( 'ALL', 2*nnb, 2*nnb, czero, cone,work( pw ), 2*nnb ) + call stdlib_${ci}$laset( 'ALL', 2*nnb, 2*nnb, czero, cone,work( pw ), 2*nnb ) pw = pw + 4*nnb*nnb end do @@ -19935,53 +19937,53 @@ module stdlib_linalg_lapack_w end do end do else - call stdlib_wlaset( 'LOWER', ihi - jcol - 1, nnb, czero, czero,a( jcol + 2, & + call stdlib_${ci}$laset( 'LOWER', ihi - jcol - 1, nnb, czero, czero,a( jcol + 2, & jcol ), lda ) - call stdlib_wlaset( 'LOWER', ihi - jcol - 1, nnb, czero, czero,b( jcol + 2, & + call stdlib_${ci}$laset( 'LOWER', ihi - jcol - 1, nnb, czero, czero,b( jcol + 2, & jcol ), ldb ) end if ! apply accumulated unitary matrices to a and b. if ( top>0 ) then j = ihi - nblst + 1 - call stdlib_wgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', top,nblst, nblst, cone, a( & + call stdlib_${ci}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', top,nblst, nblst, cone, a( & 1, j ), lda,work, nblst, czero, work( pw ), top ) - call stdlib_wlacpy( 'ALL', top, nblst, work( pw ), top,a( 1, j ), lda ) + call stdlib_${ci}$lacpy( 'ALL', top, nblst, work( pw ), top,a( 1, j ), lda ) ppwo = nblst*nblst + 1 j0 = j - nnb do j = j0, jcol+1, -nnb if ( blk22 ) then ! exploit the structure of u. - call stdlib_wunm22( 'RIGHT', 'NO TRANSPOSE', top, 2*nnb,nnb, nnb, work( & + call stdlib_${ci}$unm22( 'RIGHT', 'NO TRANSPOSE', top, 2*nnb,nnb, nnb, work( & ppwo ), 2*nnb,a( 1, j ), lda, work( pw ),lwork-pw+1, ierr ) else ! ignore the structure of u. - call stdlib_wgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', top,2*nnb, 2*nnb, & + call stdlib_${ci}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', top,2*nnb, 2*nnb, & cone, a( 1, j ), lda,work( ppwo ), 2*nnb, czero,work( pw ), top ) - call stdlib_wlacpy( 'ALL', top, 2*nnb, work( pw ), top,a( 1, j ), lda ) + call stdlib_${ci}$lacpy( 'ALL', top, 2*nnb, work( pw ), top,a( 1, j ), lda ) end if ppwo = ppwo + 4*nnb*nnb end do j = ihi - nblst + 1 - call stdlib_wgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', top,nblst, nblst, cone, b( & + call stdlib_${ci}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', top,nblst, nblst, cone, b( & 1, j ), ldb,work, nblst, czero, work( pw ), top ) - call stdlib_wlacpy( 'ALL', top, nblst, work( pw ), top,b( 1, j ), ldb ) + call stdlib_${ci}$lacpy( 'ALL', top, nblst, work( pw ), top,b( 1, j ), ldb ) ppwo = nblst*nblst + 1 j0 = j - nnb do j = j0, jcol+1, -nnb if ( blk22 ) then ! exploit the structure of u. - call stdlib_wunm22( 'RIGHT', 'NO TRANSPOSE', top, 2*nnb,nnb, nnb, work( & + call stdlib_${ci}$unm22( 'RIGHT', 'NO TRANSPOSE', top, 2*nnb,nnb, nnb, work( & ppwo ), 2*nnb,b( 1, j ), ldb, work( pw ),lwork-pw+1, ierr ) else ! ignore the structure of u. - call stdlib_wgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', top,2*nnb, 2*nnb, & + call stdlib_${ci}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', top,2*nnb, 2*nnb, & cone, b( 1, j ), ldb,work( ppwo ), 2*nnb, czero,work( pw ), top ) - call stdlib_wlacpy( 'ALL', top, 2*nnb, work( pw ), top,b( 1, j ), ldb ) + call stdlib_${ci}$lacpy( 'ALL', top, 2*nnb, work( pw ), top,b( 1, j ), ldb ) end if ppwo = ppwo + 4*nnb*nnb @@ -19997,9 +19999,9 @@ module stdlib_linalg_lapack_w topq = 1 nh = n end if - call stdlib_wgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', nh,nblst, nblst, cone, z( & + call stdlib_${ci}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', nh,nblst, nblst, cone, z( & topq, j ), ldz,work, nblst, czero, work( pw ), nh ) - call stdlib_wlacpy( 'ALL', nh, nblst, work( pw ), nh,z( topq, j ), ldz ) + call stdlib_${ci}$lacpy( 'ALL', nh, nblst, work( pw ), nh,z( topq, j ), ldz ) ppwo = nblst*nblst + 1 j0 = j - nnb @@ -20010,14 +20012,14 @@ module stdlib_linalg_lapack_w end if if ( blk22 ) then ! exploit the structure of u. - call stdlib_wunm22( 'RIGHT', 'NO TRANSPOSE', nh, 2*nnb,nnb, nnb, work( & + call stdlib_${ci}$unm22( 'RIGHT', 'NO TRANSPOSE', nh, 2*nnb,nnb, nnb, work( & ppwo ), 2*nnb,z( topq, j ), ldz, work( pw ),lwork-pw+1, ierr ) else ! ignore the structure of u. - call stdlib_wgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', nh,2*nnb, 2*nnb, & + call stdlib_${ci}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', nh,2*nnb, 2*nnb, & cone, z( topq, j ), ldz,work( ppwo ), 2*nnb, czero, work( pw ),nh ) - call stdlib_wlacpy( 'ALL', nh, 2*nnb, work( pw ), nh,z( topq, j ), ldz ) + call stdlib_${ci}$lacpy( 'ALL', nh, 2*nnb, work( pw ), nh,z( topq, j ), ldz ) end if ppwo = ppwo + 4*nnb*nnb @@ -20033,14 +20035,14 @@ module stdlib_linalg_lapack_w if ( wantq )compq2 = 'V' if ( wantz )compz2 = 'V' end if - if ( jcol0 ) then - call stdlib_wtrtrs( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', p, 1,b( 1, n-p+1 ), ldb, d,& + call stdlib_${ci}$trtrs( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', p, 1,b( 1, n-p+1 ), ldb, d,& p, info ) if( info>0 ) then info = 1 return end if ! put the solution in x - call stdlib_wcopy( p, d, 1, x( n-p+1 ), 1 ) + call stdlib_${ci}$copy( p, d, 1, x( n-p+1 ), 1 ) ! update c1 - call stdlib_wgemv( 'NO TRANSPOSE', n-p, p, -cone, a( 1, n-p+1 ), lda,d, 1, cone, c, & + call stdlib_${ci}$gemv( 'NO TRANSPOSE', n-p, p, -cone, a( 1, n-p+1 ), lda,d, 1, cone, c, & 1 ) end if ! solve r11*x1 = c1 for x1 if( n>p ) then - call stdlib_wtrtrs( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', n-p, 1,a, lda, c, n-p, & + call stdlib_${ci}$trtrs( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', n-p, 1,a, lda, c, n-p, & info ) if( info>0 ) then info = 2 return end if ! put the solutions in x - call stdlib_wcopy( n-p, c, 1, x, 1 ) + call stdlib_${ci}$copy( n-p, c, 1, x, 1 ) end if ! compute the residual vector: if( m0 )call stdlib_wgemv( 'NO TRANSPOSE', nr, n-m, -cone, a( n-p+1, m+1 ),lda, d(& + if( nr>0 )call stdlib_${ci}$gemv( 'NO TRANSPOSE', nr, n-m, -cone, a( n-p+1, m+1 ),lda, d(& nr+1 ), 1, cone, c( n-p+1 ), 1 ) else nr = p end if if( nr>0 ) then - call stdlib_wtrmv( 'UPPER', 'NO TRANSPOSE', 'NON UNIT', nr,a( n-p+1, n-p+1 ), lda, & + call stdlib_${ci}$trmv( 'UPPER', 'NO TRANSPOSE', 'NON UNIT', nr,a( n-p+1, n-p+1 ), lda, & d, 1 ) - call stdlib_waxpy( nr, -cone, d, 1, c( n-p+1 ), 1 ) + call stdlib_${ci}$axpy( nr, -cone, d, 1, c( n-p+1 ), 1 ) end if ! backward transformation x = q**h*x - call stdlib_wunmrq( 'LEFT', 'CONJUGATE TRANSPOSE', n, 1, p, b, ldb,work( 1 ), x, n, & + call stdlib_${ci}$unmrq( 'LEFT', 'CONJUGATE TRANSPOSE', n, 1, p, b, ldb,work( 1 ), x, n, & work( p+mn+1 ), lwork-p-mn, info ) work( 1 ) = p + mn + max( lopt, int( work( p+mn+1 ),KIND=ilp) ) return - end subroutine stdlib_wgglse + end subroutine stdlib_${ci}$gglse - pure subroutine stdlib_wggqrf( n, m, p, a, lda, taua, b, ldb, taub, work,lwork, info ) + pure subroutine stdlib_${ci}$ggqrf( n, m, p, a, lda, taua, b, ldb, taub, work,lwork, info ) !! ZGGQRF: computes a generalized QR factorization of an N-by-M matrix A !! and an N-by-P matrix B: !! A = Q*R, B = Q*T*Z, @@ -20331,8 +20333,8 @@ module stdlib_linalg_lapack_w integer(ilp), intent(out) :: info integer(ilp), intent(in) :: lda, ldb, lwork, m, n, p ! Array Arguments - complex(qp), intent(inout) :: a(lda,*), b(ldb,*) - complex(qp), intent(out) :: taua(*), taub(*), work(*) + complex(${ck}$), intent(inout) :: a(lda,*), b(ldb,*) + complex(${ck}$), intent(out) :: taua(*), taub(*), work(*) ! ===================================================================== ! Local Scalars logical(lk) :: lquery @@ -20369,20 +20371,20 @@ module stdlib_linalg_lapack_w return end if ! qr factorization of n-by-m matrix a: a = q*r - call stdlib_wgeqrf( n, m, a, lda, taua, work, lwork, info ) - lopt = real( work( 1 ),KIND=qp) + call stdlib_${ci}$geqrf( n, m, a, lda, taua, work, lwork, info ) + lopt = real( work( 1 ),KIND=${ck}$) ! update b := q**h*b. - call stdlib_wunmqr( 'LEFT', 'CONJUGATE TRANSPOSE', n, p, min( n, m ), a,lda, taua, b, & + call stdlib_${ci}$unmqr( 'LEFT', 'CONJUGATE TRANSPOSE', n, p, min( n, m ), a,lda, taua, b, & ldb, work, lwork, info ) lopt = max( lopt, int( work( 1 ),KIND=ilp) ) ! rq factorization of n-by-p matrix b: b = t*z. - call stdlib_wgerqf( n, p, b, ldb, taub, work, lwork, info ) + call stdlib_${ci}$gerqf( n, p, b, ldb, taub, work, lwork, info ) work( 1 ) = max( lopt, int( work( 1 ),KIND=ilp) ) return - end subroutine stdlib_wggqrf + end subroutine stdlib_${ci}$ggqrf - pure subroutine stdlib_wggrqf( m, p, n, a, lda, taua, b, ldb, taub, work,lwork, info ) + pure subroutine stdlib_${ci}$ggrqf( m, p, n, a, lda, taua, b, ldb, taub, work,lwork, info ) !! ZGGRQF: computes a generalized RQ factorization of an M-by-N matrix A !! and a P-by-N matrix B: !! A = R*Q, B = Z*T*Q, @@ -20409,8 +20411,8 @@ module stdlib_linalg_lapack_w integer(ilp), intent(out) :: info integer(ilp), intent(in) :: lda, ldb, lwork, m, n, p ! Array Arguments - complex(qp), intent(inout) :: a(lda,*), b(ldb,*) - complex(qp), intent(out) :: taua(*), taub(*), work(*) + complex(${ck}$), intent(inout) :: a(lda,*), b(ldb,*) + complex(${ck}$), intent(out) :: taua(*), taub(*), work(*) ! ===================================================================== ! Local Scalars logical(lk) :: lquery @@ -20447,20 +20449,20 @@ module stdlib_linalg_lapack_w return end if ! rq factorization of m-by-n matrix a: a = r*q - call stdlib_wgerqf( m, n, a, lda, taua, work, lwork, info ) - lopt = real( work( 1 ),KIND=qp) + call stdlib_${ci}$gerqf( m, n, a, lda, taua, work, lwork, info ) + lopt = real( work( 1 ),KIND=${ck}$) ! update b := b*q**h - call stdlib_wunmrq( 'RIGHT', 'CONJUGATE TRANSPOSE', p, n, min( m, n ),a( max( 1, m-n+1 & + call stdlib_${ci}$unmrq( 'RIGHT', 'CONJUGATE TRANSPOSE', p, n, min( m, n ),a( max( 1, m-n+1 & ), 1 ), lda, taua, b, ldb, work,lwork, info ) lopt = max( lopt, int( work( 1 ),KIND=ilp) ) ! qr factorization of p-by-n matrix b: b = z*t - call stdlib_wgeqrf( p, n, b, ldb, taub, work, lwork, info ) + call stdlib_${ci}$geqrf( p, n, b, ldb, taub, work, lwork, info ) work( 1 ) = max( lopt, int( work( 1 ),KIND=ilp) ) return - end subroutine stdlib_wggrqf + end subroutine stdlib_${ci}$ggrqf - pure subroutine stdlib_wgsvj0( jobv, m, n, a, lda, d, sva, mv, v, ldv, eps,sfmin, tol, & + pure subroutine stdlib_${ci}$gsvj0( jobv, m, n, a, lda, d, sva, mv, v, ldv, eps,sfmin, tol, & !! ZGSVJ0: is called from ZGESVJ as a pre-processor and that is its main !! purpose. It applies Jacobi rotations in the same way as ZGESVJ does, but !! it does not check convergence (stopping criterion). Few tuning @@ -20472,18 +20474,18 @@ module stdlib_linalg_lapack_w ! Scalar Arguments integer(ilp), intent(out) :: info integer(ilp), intent(in) :: lda, ldv, lwork, m, mv, n, nsweep - real(qp), intent(in) :: eps, sfmin, tol + real(${ck}$), intent(in) :: eps, sfmin, tol character, intent(in) :: jobv ! Array Arguments - complex(qp), intent(inout) :: a(lda,*), d(n), v(ldv,*) - complex(qp), intent(out) :: work(lwork) - real(qp), intent(inout) :: sva(n) + complex(${ck}$), intent(inout) :: a(lda,*), d(n), v(ldv,*) + complex(${ck}$), intent(out) :: work(lwork) + real(${ck}$), intent(inout) :: sva(n) ! ===================================================================== ! Local Scalars - complex(qp) :: aapq, ompq - real(qp) :: aapp, aapp0, aapq1, aaqq, apoaq, aqoap, big, bigtheta, cs, mxaapq, mxsinj, & + complex(${ck}$) :: aapq, ompq + real(${ck}$) :: aapp, aapp0, aapq1, aaqq, apoaq, aqoap, big, bigtheta, cs, mxaapq, mxsinj, & rootbig, rooteps, rootsfmin, roottol, small, sn, t, temp1, theta, thsign integer(ilp) :: blskip, emptsw, i, ibr, ierr, igl, ijblsk, ir1, iswrot, jbc, jgl, kbl, & lkahead, mvl, nbl, notrot, p, pskipped, q, rowskip, swband @@ -20540,8 +20542,8 @@ module stdlib_linalg_lapack_w ! .. row-cyclic pivot strategy with de rijk's pivoting .. swband = 0 ! [tp] swband is a tuning parameter [tp]. it is meaningful and effective - ! if stdlib_wgesvj is used as a computational routine in the preconditioned - ! jacobi svd algorithm stdlib_wgejsv. for sweeps i=1:swband the procedure + ! if stdlib_${ci}$gesvj is used as a computational routine in the preconditioned + ! jacobi svd algorithm stdlib_${ci}$gejsv. for sweeps i=1:swband the procedure ! works on pivots inside a band-like region around the diagonal. ! the boundaries are determined dynamically, based on the number of ! pivots above a threshold. @@ -20580,10 +20582,10 @@ module stdlib_linalg_lapack_w igl = igl + ir1*kbl loop_2001: do p = igl, min( igl+kbl-1, n-1 ) ! .. de rijk's pivoting - q = stdlib_iqamax( n-p+1, sva( p ), 1 ) + p - 1 + q = stdlib_i${c2ri(ci)}$amax( n-p+1, sva( p ), 1 ) + p - 1 if( p/=q ) then - call stdlib_wswap( m, a( 1, p ), 1, a( 1, q ), 1 ) - if( rsvec )call stdlib_wswap( mvl, v( 1, p ), 1,v( 1, q ), 1 ) + call stdlib_${ci}$swap( m, a( 1, p ), 1, a( 1, q ), 1 ) + if( rsvec )call stdlib_${ci}$swap( mvl, v( 1, p ), 1,v( 1, q ), 1 ) temp1 = sva( p ) sva( p ) = sva( q ) sva( q ) = temp1 @@ -20596,19 +20598,19 @@ module stdlib_linalg_lapack_w ! norm computation. ! caveat: ! unfortunately, some blas implementations compute sncrm2(m,a(1,p),1) - ! as sqrt(s=stdlib_wdotc(m,a(1,p),1,a(1,p),1)), which may cause the result to + ! as sqrt(s=stdlib_${ci}$dotc(m,a(1,p),1,a(1,p),1)), which may cause the result to ! overflow for ||a(:,p)||_2 > sqrt(overflow_threshold), and to ! underflow for ||a(:,p)||_2 < sqrt(underflow_threshold). - ! hence, stdlib_qznrm2 cannot be trusted, not even in the case when + ! hence, stdlib_${c2ri(ci)}$znrm2 cannot be trusted, not even in the case when ! the true norm is far from the under(over)flow boundaries. - ! if properly implemented stdlib_qznrm2 is available, the if-then-else-end if - ! below should be replaced with "aapp = stdlib_qznrm2( m, a(1,p), 1 )". + ! if properly implemented stdlib_${c2ri(ci)}$znrm2 is available, the if-then-else-end if + ! below should be replaced with "aapp = stdlib_${c2ri(ci)}$znrm2( m, a(1,p), 1 )". if( ( sva( p )rootsfmin ) ) then - sva( p ) = stdlib_qznrm2( m, a( 1, p ), 1 ) + sva( p ) = stdlib_${c2ri(ci)}$znrm2( m, a( 1, p ), 1 ) else temp1 = zero aapp = one - call stdlib_wlassq( m, a( 1, p ), 1, temp1, aapp ) + call stdlib_${ci}$lassq( m, a( 1, p ), 1, temp1, aapp ) sva( p ) = temp1*sqrt( aapp ) end if aapp = sva( p ) @@ -20624,25 +20626,25 @@ module stdlib_linalg_lapack_w if( aaqq>=one ) then rotok = ( small*aapp )<=aaqq if( aapp<( big / aaqq ) ) then - aapq = ( stdlib_wdotc( m, a( 1, p ), 1,a( 1, q ), 1 ) / & + aapq = ( stdlib_${ci}$dotc( m, a( 1, p ), 1,a( 1, q ), 1 ) / & aaqq ) / aapp else - call stdlib_wcopy( m, a( 1, p ), 1,work, 1 ) - call stdlib_wlascl( 'G', 0, 0, aapp, one,m, 1, work, lda, & + call stdlib_${ci}$copy( m, a( 1, p ), 1,work, 1 ) + call stdlib_${ci}$lascl( 'G', 0, 0, aapp, one,m, 1, work, lda, & ierr ) - aapq = stdlib_wdotc( m, work, 1,a( 1, q ), 1 ) / & + aapq = stdlib_${ci}$dotc( m, work, 1,a( 1, q ), 1 ) / & aaqq end if else rotok = aapp<=( aaqq / small ) if( aapp>( small / aaqq ) ) then - aapq = ( stdlib_wdotc( m, a( 1, p ), 1,a( 1, q ), 1 ) / & + aapq = ( stdlib_${ci}$dotc( m, a( 1, p ), 1,a( 1, q ), 1 ) / & aapp ) / aaqq else - call stdlib_wcopy( m, a( 1, q ), 1,work, 1 ) - call stdlib_wlascl( 'G', 0, 0, aaqq,one, m, 1,work, lda, & + call stdlib_${ci}$copy( m, a( 1, q ), 1,work, 1 ) + call stdlib_${ci}$lascl( 'G', 0, 0, aaqq,one, m, 1,work, lda, & ierr ) - aapq = stdlib_wdotc( m, a( 1, p ), 1,work, 1 ) / & + aapq = stdlib_${ci}$dotc( m, a( 1, p ), 1,work, 1 ) / & aapp end if end if @@ -20666,10 +20668,10 @@ module stdlib_linalg_lapack_w if( abs( theta )>bigtheta ) then t = half / theta cs = one - call stdlib_wrot( m, a(1,p), 1, a(1,q), 1,cs, conjg(ompq)& + call stdlib_${ci}$rot( m, a(1,p), 1, a(1,q), 1,cs, conjg(ompq)& *t ) if ( rsvec ) then - call stdlib_wrot( mvl, v(1,p), 1,v(1,q), 1, cs, & + call stdlib_${ci}$rot( mvl, v(1,p), 1,v(1,q), 1, cs, & conjg(ompq)*t ) end if sva( q ) = aaqq*sqrt( max( zero,one+t*apoaq*aapq1 ) ) @@ -20687,23 +20689,23 @@ module stdlib_linalg_lapack_w sva( q ) = aaqq*sqrt( max( zero,one+t*apoaq*aapq1 ) ) aapp = aapp*sqrt( max( zero,one-t*aqoap*aapq1 ) ) - call stdlib_wrot( m, a(1,p), 1, a(1,q), 1,cs, conjg(ompq)& + call stdlib_${ci}$rot( m, a(1,p), 1, a(1,q), 1,cs, conjg(ompq)& *sn ) if ( rsvec ) then - call stdlib_wrot( mvl, v(1,p), 1,v(1,q), 1, cs, & + call stdlib_${ci}$rot( mvl, v(1,p), 1,v(1,q), 1, cs, & conjg(ompq)*sn ) end if end if d(p) = -d(q) * ompq else ! .. have to use modified gram-schmidt like transformation - call stdlib_wcopy( m, a( 1, p ), 1,work, 1 ) - call stdlib_wlascl( 'G', 0, 0, aapp, one, m,1, work, lda,& + call stdlib_${ci}$copy( m, a( 1, p ), 1,work, 1 ) + call stdlib_${ci}$lascl( 'G', 0, 0, aapp, one, m,1, work, lda,& ierr ) - call stdlib_wlascl( 'G', 0, 0, aaqq, one, m,1, a( 1, q ), & + call stdlib_${ci}$lascl( 'G', 0, 0, aaqq, one, m,1, a( 1, q ), & lda, ierr ) - call stdlib_waxpy( m, -aapq, work, 1,a( 1, q ), 1 ) - call stdlib_wlascl( 'G', 0, 0, one, aaqq, m,1, a( 1, q ), & + call stdlib_${ci}$axpy( m, -aapq, work, 1,a( 1, q ), 1 ) + call stdlib_${ci}$lascl( 'G', 0, 0, one, aaqq, m,1, a( 1, q ), & lda, ierr ) sva( q ) = aaqq*sqrt( max( zero,one-aapq1*aapq1 ) ) mxsinj = max( mxsinj, sfmin ) @@ -20713,21 +20715,21 @@ module stdlib_linalg_lapack_w ! recompute sva(q), sva(p). if( ( sva( q ) / aaqq )**2<=rooteps )then if( ( aaqqrootsfmin ) ) then - sva( q ) = stdlib_qznrm2( m, a( 1, q ), 1 ) + sva( q ) = stdlib_${c2ri(ci)}$znrm2( m, a( 1, q ), 1 ) else t = zero aaqq = one - call stdlib_wlassq( m, a( 1, q ), 1, t,aaqq ) + call stdlib_${ci}$lassq( m, a( 1, q ), 1, t,aaqq ) sva( q ) = t*sqrt( aaqq ) end if end if if( ( aapp / aapp0 )<=rooteps ) then if( ( aapprootsfmin ) ) then - aapp = stdlib_qznrm2( m, a( 1, p ), 1 ) + aapp = stdlib_${c2ri(ci)}$znrm2( m, a( 1, p ), 1 ) else t = zero aapp = one - call stdlib_wlassq( m, a( 1, p ), 1, t,aapp ) + call stdlib_${ci}$lassq( m, a( 1, p ), 1, t,aapp ) aapp = t*sqrt( aapp ) end if sva( p ) = aapp @@ -20786,13 +20788,13 @@ module stdlib_linalg_lapack_w rotok = ( small*aaqq )<=aapp end if if( aapp<( big / aaqq ) ) then - aapq = ( stdlib_wdotc( m, a( 1, p ), 1,a( 1, q ), 1 ) / & + aapq = ( stdlib_${ci}$dotc( m, a( 1, p ), 1,a( 1, q ), 1 ) / & aaqq ) / aapp else - call stdlib_wcopy( m, a( 1, p ), 1,work, 1 ) - call stdlib_wlascl( 'G', 0, 0, aapp,one, m, 1,work, lda, & + call stdlib_${ci}$copy( m, a( 1, p ), 1,work, 1 ) + call stdlib_${ci}$lascl( 'G', 0, 0, aapp,one, m, 1,work, lda, & ierr ) - aapq = stdlib_wdotc( m, work, 1,a( 1, q ), 1 ) / & + aapq = stdlib_${ci}$dotc( m, work, 1,a( 1, q ), 1 ) / & aaqq end if else @@ -20802,13 +20804,13 @@ module stdlib_linalg_lapack_w rotok = aaqq<=( aapp / small ) end if if( aapp>( small / aaqq ) ) then - aapq = ( stdlib_wdotc( m, a( 1, p ), 1,a( 1, q ), 1 ) / max(& + aapq = ( stdlib_${ci}$dotc( m, a( 1, p ), 1,a( 1, q ), 1 ) / max(& aaqq,aapp) )/ min(aaqq,aapp) else - call stdlib_wcopy( m, a( 1, q ), 1,work, 1 ) - call stdlib_wlascl( 'G', 0, 0, aaqq,one, m, 1,work, lda, & + call stdlib_${ci}$copy( m, a( 1, q ), 1,work, 1 ) + call stdlib_${ci}$lascl( 'G', 0, 0, aaqq,one, m, 1,work, lda, & ierr ) - aapq = stdlib_wdotc( m, a( 1, p ), 1,work, 1 ) / & + aapq = stdlib_${ci}$dotc( m, a( 1, p ), 1,work, 1 ) / & aapp end if end if @@ -20830,10 +20832,10 @@ module stdlib_linalg_lapack_w if( abs( theta )>bigtheta ) then t = half / theta cs = one - call stdlib_wrot( m, a(1,p), 1, a(1,q), 1,cs, conjg(ompq)& + call stdlib_${ci}$rot( m, a(1,p), 1, a(1,q), 1,cs, conjg(ompq)& *t ) if( rsvec ) then - call stdlib_wrot( mvl, v(1,p), 1,v(1,q), 1, cs, & + call stdlib_${ci}$rot( mvl, v(1,p), 1,v(1,q), 1, cs, & conjg(ompq)*t ) end if sva( q ) = aaqq*sqrt( max( zero,one+t*apoaq*aapq1 ) ) @@ -20852,10 +20854,10 @@ module stdlib_linalg_lapack_w sva( q ) = aaqq*sqrt( max( zero,one+t*apoaq*aapq1 ) ) aapp = aapp*sqrt( max( zero,one-t*aqoap*aapq1 ) ) - call stdlib_wrot( m, a(1,p), 1, a(1,q), 1,cs, conjg(ompq)& + call stdlib_${ci}$rot( m, a(1,p), 1, a(1,q), 1,cs, conjg(ompq)& *sn ) if( rsvec ) then - call stdlib_wrot( mvl, v(1,p), 1,v(1,q), 1, cs, & + call stdlib_${ci}$rot( mvl, v(1,p), 1,v(1,q), 1, cs, & conjg(ompq)*sn ) end if end if @@ -20863,27 +20865,27 @@ module stdlib_linalg_lapack_w else ! .. have to use modified gram-schmidt like transformation if( aapp>aaqq ) then - call stdlib_wcopy( m, a( 1, p ), 1,work, 1 ) - call stdlib_wlascl( 'G', 0, 0, aapp, one,m, 1, work,lda,& + call stdlib_${ci}$copy( m, a( 1, p ), 1,work, 1 ) + call stdlib_${ci}$lascl( 'G', 0, 0, aapp, one,m, 1, work,lda,& ierr ) - call stdlib_wlascl( 'G', 0, 0, aaqq, one,m, 1, a( 1, q ),& + call stdlib_${ci}$lascl( 'G', 0, 0, aaqq, one,m, 1, a( 1, q ),& lda,ierr ) - call stdlib_waxpy( m, -aapq, work,1, a( 1, q ), 1 ) + call stdlib_${ci}$axpy( m, -aapq, work,1, a( 1, q ), 1 ) - call stdlib_wlascl( 'G', 0, 0, one, aaqq,m, 1, a( 1, q ),& + call stdlib_${ci}$lascl( 'G', 0, 0, one, aaqq,m, 1, a( 1, q ),& lda,ierr ) sva( q ) = aaqq*sqrt( max( zero,one-aapq1*aapq1 ) ) mxsinj = max( mxsinj, sfmin ) else - call stdlib_wcopy( m, a( 1, q ), 1,work, 1 ) - call stdlib_wlascl( 'G', 0, 0, aaqq, one,m, 1, work,lda,& + call stdlib_${ci}$copy( m, a( 1, q ), 1,work, 1 ) + call stdlib_${ci}$lascl( 'G', 0, 0, aaqq, one,m, 1, work,lda,& ierr ) - call stdlib_wlascl( 'G', 0, 0, aapp, one,m, 1, a( 1, p ),& + call stdlib_${ci}$lascl( 'G', 0, 0, aapp, one,m, 1, a( 1, p ),& lda,ierr ) - call stdlib_waxpy( m, -conjg(aapq),work, 1, a( 1, p ), 1 & + call stdlib_${ci}$axpy( m, -conjg(aapq),work, 1, a( 1, p ), 1 & ) - call stdlib_wlascl( 'G', 0, 0, one, aapp,m, 1, a( 1, p ),& + call stdlib_${ci}$lascl( 'G', 0, 0, one, aapp,m, 1, a( 1, p ),& lda,ierr ) sva( p ) = aapp*sqrt( max( zero,one-aapq1*aapq1 ) ) @@ -20895,21 +20897,21 @@ module stdlib_linalg_lapack_w ! .. recompute sva(q), sva(p) if( ( sva( q ) / aaqq )**2<=rooteps )then if( ( aaqqrootsfmin ) ) then - sva( q ) = stdlib_qznrm2( m, a( 1, q ), 1) + sva( q ) = stdlib_${c2ri(ci)}$znrm2( m, a( 1, q ), 1) else t = zero aaqq = one - call stdlib_wlassq( m, a( 1, q ), 1, t,aaqq ) + call stdlib_${ci}$lassq( m, a( 1, q ), 1, t,aaqq ) sva( q ) = t*sqrt( aaqq ) end if end if if( ( aapp / aapp0 )**2<=rooteps ) then if( ( aapprootsfmin ) ) then - aapp = stdlib_qznrm2( m, a( 1, p ), 1 ) + aapp = stdlib_${c2ri(ci)}$znrm2( m, a( 1, p ), 1 ) else t = zero aapp = one - call stdlib_wlassq( m, a( 1, p ), 1, t,aapp ) + call stdlib_${ci}$lassq( m, a( 1, p ), 1, t,aapp ) aapp = t*sqrt( aapp ) end if sva( p ) = aapp @@ -20958,17 +20960,17 @@ module stdlib_linalg_lapack_w ! 2000 :: end of the ibr-loop ! .. update sva(n) if( ( sva( n )rootsfmin ) )then - sva( n ) = stdlib_qznrm2( m, a( 1, n ), 1 ) + sva( n ) = stdlib_${c2ri(ci)}$znrm2( m, a( 1, n ), 1 ) else t = zero aapp = one - call stdlib_wlassq( m, a( 1, n ), 1, t, aapp ) + call stdlib_${ci}$lassq( m, a( 1, n ), 1, t, aapp ) sva( n ) = t*sqrt( aapp ) end if ! additional steering devices if( ( iswband+1 ) .and. ( mxaapqswband+1 ) .and. ( mxaapq=emptsw )go to 1994 @@ -20985,7 +20987,7 @@ module stdlib_linalg_lapack_w 1995 continue ! sort the vector sva() of column norms. do p = 1, n - 1 - q = stdlib_iqamax( n-p+1, sva( p ), 1 ) + p - 1 + q = stdlib_i${c2ri(ci)}$amax( n-p+1, sva( p ), 1 ) + p - 1 if( p/=q ) then temp1 = sva( p ) sva( p ) = sva( q ) @@ -20993,15 +20995,15 @@ module stdlib_linalg_lapack_w aapq = d( p ) d( p ) = d( q ) d( q ) = aapq - call stdlib_wswap( m, a( 1, p ), 1, a( 1, q ), 1 ) - if( rsvec )call stdlib_wswap( mvl, v( 1, p ), 1, v( 1, q ), 1 ) + call stdlib_${ci}$swap( m, a( 1, p ), 1, a( 1, q ), 1 ) + if( rsvec )call stdlib_${ci}$swap( mvl, v( 1, p ), 1, v( 1, q ), 1 ) end if end do return - end subroutine stdlib_wgsvj0 + end subroutine stdlib_${ci}$gsvj0 - pure subroutine stdlib_wgsvj1( jobv, m, n, n1, a, lda, d, sva, mv, v, ldv,eps, sfmin, tol, & + pure subroutine stdlib_${ci}$gsvj1( jobv, m, n, n1, a, lda, d, sva, mv, v, ldv,eps, sfmin, tol, & !! ZGSVJ1: is called from ZGESVJ as a pre-processor and that is its main !! purpose. It applies Jacobi rotations in the same way as ZGESVJ does, but !! it targets only particular pivots and it does not check convergence @@ -21031,19 +21033,19 @@ module stdlib_linalg_lapack_w ! -- lapack is a software package provided by univ. of tennessee, -- ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments - real(qp), intent(in) :: eps, sfmin, tol + real(${ck}$), intent(in) :: eps, sfmin, tol integer(ilp), intent(out) :: info integer(ilp), intent(in) :: lda, ldv, lwork, m, mv, n, n1, nsweep character, intent(in) :: jobv ! Array Arguments - complex(qp), intent(inout) :: a(lda,*), d(n), v(ldv,*) - complex(qp), intent(out) :: work(lwork) - real(qp), intent(inout) :: sva(n) + complex(${ck}$), intent(inout) :: a(lda,*), d(n), v(ldv,*) + complex(${ck}$), intent(out) :: work(lwork) + real(${ck}$), intent(inout) :: sva(n) ! ===================================================================== ! Local Scalars - complex(qp) :: aapq, ompq - real(qp) :: aapp, aapp0, aapq1, aaqq, apoaq, aqoap, big, bigtheta, cs, mxaapq, mxsinj, & + complex(${ck}$) :: aapq, ompq + real(${ck}$) :: aapp, aapp0, aapq1, aaqq, apoaq, aqoap, big, bigtheta, cs, mxaapq, mxsinj, & rootbig, rooteps, rootsfmin, roottol, small, sn, t, temp1, theta, thsign integer(ilp) :: blskip, emptsw, i, ibr, igl, ierr, ijblsk, iswrot, jbc, jgl, kbl, mvl, & notrot, nblc, nblr, p, pskipped, q, rowskip, swband @@ -21094,7 +21096,7 @@ module stdlib_linalg_lapack_w small = sfmin / eps big = one / sfmin rootbig = one / rootsfmin - ! large = big / sqrt( real( m*n,KIND=qp) ) + ! large = big / sqrt( real( m*n,KIND=${ck}$) ) bigtheta = one / rooteps roottol = sqrt( tol ) ! Initialize The Right Singular Vector Matrix @@ -21114,8 +21116,8 @@ module stdlib_linalg_lapack_w ! [tp] rowskip is a tuning parameter. swband = 0 ! [tp] swband is a tuning parameter. it is meaningful and effective - ! if stdlib_wgesvj is used as a computational routine in the preconditioned - ! jacobi svd algorithm stdlib_wgejsv. + ! if stdlib_${ci}$gesvj is used as a computational routine in the preconditioned + ! jacobi svd algorithm stdlib_${ci}$gejsv. ! | * * * [x] [x] [x]| ! | * * * [x] [x] [x]| row-cycling in the nblr-by-nblc [x] blocks. ! | * * * [x] [x] [x]| row-cyclic pivoting inside each [x] block. @@ -21159,13 +21161,13 @@ module stdlib_linalg_lapack_w rotok = ( small*aaqq )<=aapp end if if( aapp<( big / aaqq ) ) then - aapq = ( stdlib_wdotc( m, a( 1, p ), 1,a( 1, q ), 1 ) / & + aapq = ( stdlib_${ci}$dotc( m, a( 1, p ), 1,a( 1, q ), 1 ) / & aaqq ) / aapp else - call stdlib_wcopy( m, a( 1, p ), 1,work, 1 ) - call stdlib_wlascl( 'G', 0, 0, aapp,one, m, 1,work, lda, & + call stdlib_${ci}$copy( m, a( 1, p ), 1,work, 1 ) + call stdlib_${ci}$lascl( 'G', 0, 0, aapp,one, m, 1,work, lda, & ierr ) - aapq = stdlib_wdotc( m, work, 1,a( 1, q ), 1 ) / & + aapq = stdlib_${ci}$dotc( m, work, 1,a( 1, q ), 1 ) / & aaqq end if else @@ -21175,13 +21177,13 @@ module stdlib_linalg_lapack_w rotok = aaqq<=( aapp / small ) end if if( aapp>( small / aaqq ) ) then - aapq = ( stdlib_wdotc( m, a( 1, p ), 1,a( 1, q ), 1 ) / max(& + aapq = ( stdlib_${ci}$dotc( m, a( 1, p ), 1,a( 1, q ), 1 ) / max(& aaqq,aapp) )/ min(aaqq,aapp) else - call stdlib_wcopy( m, a( 1, q ), 1,work, 1 ) - call stdlib_wlascl( 'G', 0, 0, aaqq,one, m, 1,work, lda, & + call stdlib_${ci}$copy( m, a( 1, q ), 1,work, 1 ) + call stdlib_${ci}$lascl( 'G', 0, 0, aaqq,one, m, 1,work, lda, & ierr ) - aapq = stdlib_wdotc( m, a( 1, p ), 1,work, 1 ) / & + aapq = stdlib_${ci}$dotc( m, a( 1, p ), 1,work, 1 ) / & aapp end if end if @@ -21203,10 +21205,10 @@ module stdlib_linalg_lapack_w if( abs( theta )>bigtheta ) then t = half / theta cs = one - call stdlib_wrot( m, a(1,p), 1, a(1,q), 1,cs, conjg(ompq)& + call stdlib_${ci}$rot( m, a(1,p), 1, a(1,q), 1,cs, conjg(ompq)& *t ) if( rsvec ) then - call stdlib_wrot( mvl, v(1,p), 1,v(1,q), 1, cs, & + call stdlib_${ci}$rot( mvl, v(1,p), 1,v(1,q), 1, cs, & conjg(ompq)*t ) end if sva( q ) = aaqq*sqrt( max( zero,one+t*apoaq*aapq1 ) ) @@ -21225,10 +21227,10 @@ module stdlib_linalg_lapack_w sva( q ) = aaqq*sqrt( max( zero,one+t*apoaq*aapq1 ) ) aapp = aapp*sqrt( max( zero,one-t*aqoap*aapq1 ) ) - call stdlib_wrot( m, a(1,p), 1, a(1,q), 1,cs, conjg(ompq)& + call stdlib_${ci}$rot( m, a(1,p), 1, a(1,q), 1,cs, conjg(ompq)& *sn ) if( rsvec ) then - call stdlib_wrot( mvl, v(1,p), 1,v(1,q), 1, cs, & + call stdlib_${ci}$rot( mvl, v(1,p), 1,v(1,q), 1, cs, & conjg(ompq)*sn ) end if end if @@ -21236,27 +21238,27 @@ module stdlib_linalg_lapack_w else ! .. have to use modified gram-schmidt like transformation if( aapp>aaqq ) then - call stdlib_wcopy( m, a( 1, p ), 1,work, 1 ) - call stdlib_wlascl( 'G', 0, 0, aapp, one,m, 1, work,lda,& + call stdlib_${ci}$copy( m, a( 1, p ), 1,work, 1 ) + call stdlib_${ci}$lascl( 'G', 0, 0, aapp, one,m, 1, work,lda,& ierr ) - call stdlib_wlascl( 'G', 0, 0, aaqq, one,m, 1, a( 1, q ),& + call stdlib_${ci}$lascl( 'G', 0, 0, aaqq, one,m, 1, a( 1, q ),& lda,ierr ) - call stdlib_waxpy( m, -aapq, work,1, a( 1, q ), 1 ) + call stdlib_${ci}$axpy( m, -aapq, work,1, a( 1, q ), 1 ) - call stdlib_wlascl( 'G', 0, 0, one, aaqq,m, 1, a( 1, q ),& + call stdlib_${ci}$lascl( 'G', 0, 0, one, aaqq,m, 1, a( 1, q ),& lda,ierr ) sva( q ) = aaqq*sqrt( max( zero,one-aapq1*aapq1 ) ) mxsinj = max( mxsinj, sfmin ) else - call stdlib_wcopy( m, a( 1, q ), 1,work, 1 ) - call stdlib_wlascl( 'G', 0, 0, aaqq, one,m, 1, work,lda,& + call stdlib_${ci}$copy( m, a( 1, q ), 1,work, 1 ) + call stdlib_${ci}$lascl( 'G', 0, 0, aaqq, one,m, 1, work,lda,& ierr ) - call stdlib_wlascl( 'G', 0, 0, aapp, one,m, 1, a( 1, p ),& + call stdlib_${ci}$lascl( 'G', 0, 0, aapp, one,m, 1, a( 1, p ),& lda,ierr ) - call stdlib_waxpy( m, -conjg(aapq),work, 1, a( 1, p ), 1 & + call stdlib_${ci}$axpy( m, -conjg(aapq),work, 1, a( 1, p ), 1 & ) - call stdlib_wlascl( 'G', 0, 0, one, aapp,m, 1, a( 1, p ),& + call stdlib_${ci}$lascl( 'G', 0, 0, one, aapp,m, 1, a( 1, p ),& lda,ierr ) sva( p ) = aapp*sqrt( max( zero,one-aapq1*aapq1 ) ) @@ -21268,21 +21270,21 @@ module stdlib_linalg_lapack_w ! .. recompute sva(q), sva(p) if( ( sva( q ) / aaqq )**2<=rooteps )then if( ( aaqqrootsfmin ) ) then - sva( q ) = stdlib_qznrm2( m, a( 1, q ), 1) + sva( q ) = stdlib_${c2ri(ci)}$znrm2( m, a( 1, q ), 1) else t = zero aaqq = one - call stdlib_wlassq( m, a( 1, q ), 1, t,aaqq ) + call stdlib_${ci}$lassq( m, a( 1, q ), 1, t,aaqq ) sva( q ) = t*sqrt( aaqq ) end if end if if( ( aapp / aapp0 )**2<=rooteps ) then if( ( aapprootsfmin ) ) then - aapp = stdlib_qznrm2( m, a( 1, p ), 1 ) + aapp = stdlib_${c2ri(ci)}$znrm2( m, a( 1, p ), 1 ) else t = zero aapp = one - call stdlib_wlassq( m, a( 1, p ), 1, t,aapp ) + call stdlib_${ci}$lassq( m, a( 1, p ), 1, t,aapp ) aapp = t*sqrt( aapp ) end if sva( p ) = aapp @@ -21331,17 +21333,17 @@ module stdlib_linalg_lapack_w ! 2000 :: end of the ibr-loop ! .. update sva(n) if( ( sva( n )rootsfmin ) )then - sva( n ) = stdlib_qznrm2( m, a( 1, n ), 1 ) + sva( n ) = stdlib_${c2ri(ci)}$znrm2( m, a( 1, n ), 1 ) else t = zero aapp = one - call stdlib_wlassq( m, a( 1, n ), 1, t, aapp ) + call stdlib_${ci}$lassq( m, a( 1, n ), 1, t, aapp ) sva( n ) = t*sqrt( aapp ) end if ! additional steering devices if( ( iswband+1 ) .and. ( mxaapqswband+1 ) .and. ( mxaapq=emptsw )go to 1994 @@ -21358,7 +21360,7 @@ module stdlib_linalg_lapack_w 1995 continue ! sort the vector sva() of column norms. do p = 1, n - 1 - q = stdlib_iqamax( n-p+1, sva( p ), 1 ) + p - 1 + q = stdlib_i${c2ri(ci)}$amax( n-p+1, sva( p ), 1 ) + p - 1 if( p/=q ) then temp1 = sva( p ) sva( p ) = sva( q ) @@ -21366,15 +21368,15 @@ module stdlib_linalg_lapack_w aapq = d( p ) d( p ) = d( q ) d( q ) = aapq - call stdlib_wswap( m, a( 1, p ), 1, a( 1, q ), 1 ) - if( rsvec )call stdlib_wswap( mvl, v( 1, p ), 1, v( 1, q ), 1 ) + call stdlib_${ci}$swap( m, a( 1, p ), 1, a( 1, q ), 1 ) + if( rsvec )call stdlib_${ci}$swap( mvl, v( 1, p ), 1, v( 1, q ), 1 ) end if end do return - end subroutine stdlib_wgsvj1 + end subroutine stdlib_${ci}$gsvj1 - pure subroutine stdlib_wgtcon( norm, n, dl, d, du, du2, ipiv, anorm, rcond,work, info ) + pure subroutine stdlib_${ci}$gtcon( norm, n, dl, d, du, du2, ipiv, anorm, rcond,work, info ) !! ZGTCON: estimates the reciprocal of the condition number of a complex !! tridiagonal matrix A using the LU factorization as computed by !! ZGTTRF. @@ -21388,18 +21390,18 @@ module stdlib_linalg_lapack_w character, intent(in) :: norm integer(ilp), intent(out) :: info integer(ilp), intent(in) :: n - real(qp), intent(in) :: anorm - real(qp), intent(out) :: rcond + real(${ck}$), intent(in) :: anorm + real(${ck}$), intent(out) :: rcond ! Array Arguments integer(ilp), intent(in) :: ipiv(*) - complex(qp), intent(in) :: d(*), dl(*), du(*), du2(*) - complex(qp), intent(out) :: work(*) + complex(${ck}$), intent(in) :: d(*), dl(*), du(*), du2(*) + complex(${ck}$), intent(out) :: work(*) ! ===================================================================== ! Local Scalars logical(lk) :: onenrm integer(ilp) :: i, kase, kase1 - real(qp) :: ainvnm + real(${ck}$) :: ainvnm ! Local Arrays integer(ilp) :: isave(3) ! Intrinsic Functions @@ -21429,7 +21431,7 @@ module stdlib_linalg_lapack_w end if ! check that d(1:n) is non-zero. do i = 1, n - if( d( i )==cmplx( zero,KIND=qp) )return + if( d( i )==cmplx( zero,KIND=${ck}$) )return end do ainvnm = zero if( onenrm ) then @@ -21439,15 +21441,15 @@ module stdlib_linalg_lapack_w end if kase = 0 20 continue - call stdlib_wlacn2( n, work( n+1 ), work, ainvnm, kase, isave ) + call stdlib_${ci}$lacn2( n, work( n+1 ), work, ainvnm, kase, isave ) if( kase/=0 ) then if( kase==kase1 ) then ! multiply by inv(u)*inv(l). - call stdlib_wgttrs( 'NO TRANSPOSE', n, 1, dl, d, du, du2, ipiv,work, n, info ) + call stdlib_${ci}$gttrs( 'NO TRANSPOSE', n, 1, dl, d, du, du2, ipiv,work, n, info ) else ! multiply by inv(l**h)*inv(u**h). - call stdlib_wgttrs( 'CONJUGATE TRANSPOSE', n, 1, dl, d, du, du2,ipiv, work, n, & + call stdlib_${ci}$gttrs( 'CONJUGATE TRANSPOSE', n, 1, dl, d, du, du2,ipiv, work, n, & info ) end if go to 20 @@ -21455,10 +21457,10 @@ module stdlib_linalg_lapack_w ! compute the estimate of the reciprocal condition number. if( ainvnm/=zero )rcond = ( one / ainvnm ) / anorm return - end subroutine stdlib_wgtcon + end subroutine stdlib_${ci}$gtcon - pure subroutine stdlib_wgtrfs( trans, n, nrhs, dl, d, du, dlf, df, duf, du2,ipiv, b, ldb, x, & + pure subroutine stdlib_${ci}$gtrfs( trans, n, nrhs, dl, d, du, dlf, df, duf, du2,ipiv, b, ldb, x, & !! ZGTRFS: improves the computed solution to a system of linear !! equations when the coefficient matrix is tridiagonal, and provides !! error bounds and backward error estimates for the solution. @@ -21472,11 +21474,11 @@ module stdlib_linalg_lapack_w integer(ilp), intent(in) :: ldb, ldx, n, nrhs ! Array Arguments integer(ilp), intent(in) :: ipiv(*) - real(qp), intent(out) :: berr(*), ferr(*), rwork(*) - complex(qp), intent(in) :: b(ldb,*), d(*), df(*), dl(*), dlf(*), du(*), du2(*), duf(*) + real(${ck}$), intent(out) :: berr(*), ferr(*), rwork(*) + complex(${ck}$), intent(in) :: b(ldb,*), d(*), df(*), dl(*), dlf(*), du(*), du2(*), duf(*) - complex(qp), intent(out) :: work(*) - complex(qp), intent(inout) :: x(ldx,*) + complex(${ck}$), intent(out) :: work(*) + complex(${ck}$), intent(inout) :: x(ldx,*) ! ===================================================================== ! Parameters integer(ilp), parameter :: itmax = 5 @@ -21488,16 +21490,16 @@ module stdlib_linalg_lapack_w logical(lk) :: notran character :: transn, transt integer(ilp) :: count, i, j, kase, nz - real(qp) :: eps, lstres, s, safe1, safe2, safmin - complex(qp) :: zdum + real(${ck}$) :: eps, lstres, s, safe1, safe2, safmin + complex(${ck}$) :: zdum ! Local Arrays integer(ilp) :: isave(3) ! Intrinsic Functions intrinsic :: abs,real,cmplx,aimag,max ! Statement Functions - real(qp) :: cabs1 + real(${ck}$) :: cabs1 ! Statement Function Definitions - cabs1( zdum ) = abs( real( zdum,KIND=qp) ) + abs( aimag( zdum ) ) + cabs1( zdum ) = abs( real( zdum,KIND=${ck}$) ) + abs( aimag( zdum ) ) ! Executable Statements ! test the input parameters. info = 0 @@ -21535,8 +21537,8 @@ module stdlib_linalg_lapack_w end if ! nz = maximum number of nonzero elements in each row of a, plus 1 nz = 4 - eps = stdlib_qlamch( 'EPSILON' ) - safmin = stdlib_qlamch( 'SAFE MINIMUM' ) + eps = stdlib_${c2ri(ci)}$lamch( 'EPSILON' ) + safmin = stdlib_${c2ri(ci)}$lamch( 'SAFE MINIMUM' ) safe1 = nz*safmin safe2 = safe1 / eps ! do for each right hand side @@ -21547,8 +21549,8 @@ module stdlib_linalg_lapack_w ! loop until stopping criterion is satisfied. ! compute residual r = b - op(a) * x, ! where op(a) = a, a**t, or a**h, depending on trans. - call stdlib_wcopy( n, b( 1, j ), 1, work, 1 ) - call stdlib_wlagtm( trans, n, 1, -one, dl, d, du, x( 1, j ), ldx, one,work, n ) + call stdlib_${ci}$copy( n, b( 1, j ), 1, work, 1 ) + call stdlib_${ci}$lagtm( trans, n, 1, -one, dl, d, du, x( 1, j ), ldx, one,work, n ) ! compute abs(op(a))*abs(x) + abs(b) for use in the backward ! error bound. @@ -21603,8 +21605,8 @@ module stdlib_linalg_lapack_w ! 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_wgttrs( trans, n, 1, dlf, df, duf, du2, ipiv, work, n,info ) - call stdlib_waxpy( n, cmplx( one,KIND=qp), work, 1, x( 1, j ), 1 ) + call stdlib_${ci}$gttrs( trans, n, 1, dlf, df, duf, du2, ipiv, work, n,info ) + call stdlib_${ci}$axpy( n, cmplx( one,KIND=${ck}$), work, 1, x( 1, j ), 1 ) lstres = berr( j ) count = count + 1 go to 20 @@ -21623,7 +21625,7 @@ module stdlib_linalg_lapack_w ! the i-th component of abs(r)+nz*eps*(abs(op(a))*abs(x)+abs(b)) ! is incremented by safe1 if the i-th component of ! abs(op(a))*abs(x) + abs(b) is less than safe2. - ! use stdlib_wlacn2 to estimate the infinity-norm of the matrix + ! use stdlib_${ci}$lacn2 to estimate the infinity-norm of the matrix ! inv(op(a)) * diag(w), ! where w = abs(r) + nz*eps*( abs(op(a))*abs(x)+abs(b) ))) do i = 1, n @@ -21635,11 +21637,11 @@ module stdlib_linalg_lapack_w end do kase = 0 70 continue - call stdlib_wlacn2( n, work( n+1 ), work, ferr( j ), kase, isave ) + call stdlib_${ci}$lacn2( n, work( n+1 ), work, ferr( j ), kase, isave ) if( kase/=0 ) then if( kase==1 ) then ! multiply by diag(w)*inv(op(a)**h). - call stdlib_wgttrs( transt, n, 1, dlf, df, duf, du2, ipiv, work,n, info ) + call stdlib_${ci}$gttrs( transt, n, 1, dlf, df, duf, du2, ipiv, work,n, info ) do i = 1, n work( i ) = rwork( i )*work( i ) @@ -21649,7 +21651,7 @@ module stdlib_linalg_lapack_w do i = 1, n work( i ) = rwork( i )*work( i ) end do - call stdlib_wgttrs( transn, n, 1, dlf, df, duf, du2, ipiv, work,n, info ) + call stdlib_${ci}$gttrs( transn, n, 1, dlf, df, duf, du2, ipiv, work,n, info ) end if go to 70 @@ -21662,10 +21664,10 @@ module stdlib_linalg_lapack_w if( lstres/=zero )ferr( j ) = ferr( j ) / lstres end do loop_110 return - end subroutine stdlib_wgtrfs + end subroutine stdlib_${ci}$gtrfs - pure subroutine stdlib_wgtsv( n, nrhs, dl, d, du, b, ldb, info ) + pure subroutine stdlib_${ci}$gtsv( n, nrhs, dl, d, du, b, ldb, info ) !! ZGTSV: solves the equation !! A*X = B, !! where A is an N-by-N tridiagonal matrix, by Gaussian elimination with @@ -21679,18 +21681,18 @@ module stdlib_linalg_lapack_w integer(ilp), intent(out) :: info integer(ilp), intent(in) :: ldb, n, nrhs ! Array Arguments - complex(qp), intent(inout) :: b(ldb,*), d(*), dl(*), du(*) + complex(${ck}$), intent(inout) :: b(ldb,*), d(*), dl(*), du(*) ! ===================================================================== ! Local Scalars integer(ilp) :: j, k - complex(qp) :: mult, temp, zdum + complex(${ck}$) :: mult, temp, zdum ! Intrinsic Functions intrinsic :: abs,real,aimag,max ! Statement Functions - real(qp) :: cabs1 + real(${ck}$) :: cabs1 ! Statement Function Definitions - cabs1( zdum ) = abs( real( zdum,KIND=qp) ) + abs( aimag( zdum ) ) + cabs1( zdum ) = abs( real( zdum,KIND=${ck}$) ) + abs( aimag( zdum ) ) ! Executable Statements info = 0 if( n<0 ) then @@ -21754,10 +21756,10 @@ module stdlib_linalg_lapack_w end do end do return - end subroutine stdlib_wgtsv + end subroutine stdlib_${ci}$gtsv - pure subroutine stdlib_wgtsvx( fact, trans, n, nrhs, dl, d, du, dlf, df, duf,du2, ipiv, b, & + pure subroutine stdlib_${ci}$gtsvx( fact, trans, n, nrhs, dl, d, du, dlf, df, duf,du2, ipiv, b, & !! ZGTSVX: uses the LU factorization to compute the solution to a complex !! system of linear equations A * X = B, A**T * X = B, or A**H * X = B, !! where A is a tridiagonal matrix of order N and X and B are N-by-NRHS @@ -21772,19 +21774,19 @@ module stdlib_linalg_lapack_w character, intent(in) :: fact, trans integer(ilp), intent(out) :: info integer(ilp), intent(in) :: ldb, ldx, n, nrhs - real(qp), intent(out) :: rcond + real(${ck}$), intent(out) :: rcond ! Array Arguments integer(ilp), intent(inout) :: ipiv(*) - real(qp), intent(out) :: berr(*), ferr(*), rwork(*) - complex(qp), intent(in) :: b(ldb,*), d(*), dl(*), du(*) - complex(qp), intent(inout) :: df(*), dlf(*), du2(*), duf(*) - complex(qp), intent(out) :: work(*), x(ldx,*) + real(${ck}$), intent(out) :: berr(*), ferr(*), rwork(*) + complex(${ck}$), intent(in) :: b(ldb,*), d(*), dl(*), du(*) + complex(${ck}$), intent(inout) :: df(*), dlf(*), du2(*), duf(*) + complex(${ck}$), intent(out) :: work(*), x(ldx,*) ! ===================================================================== ! Local Scalars logical(lk) :: nofact, notran character :: norm - real(qp) :: anorm + real(${ck}$) :: anorm ! Intrinsic Functions intrinsic :: max ! Executable Statements @@ -21811,12 +21813,12 @@ module stdlib_linalg_lapack_w end if if( nofact ) then ! compute the lu factorization of a. - call stdlib_wcopy( n, d, 1, df, 1 ) + call stdlib_${ci}$copy( n, d, 1, df, 1 ) if( n>1 ) then - call stdlib_wcopy( n-1, dl, 1, dlf, 1 ) - call stdlib_wcopy( n-1, du, 1, duf, 1 ) + call stdlib_${ci}$copy( n-1, dl, 1, dlf, 1 ) + call stdlib_${ci}$copy( n-1, du, 1, duf, 1 ) end if - call stdlib_wgttrf( n, dlf, df, duf, du2, ipiv, info ) + call stdlib_${ci}$gttrf( n, dlf, df, duf, du2, ipiv, info ) ! return if info is non-zero. if( info>0 )then rcond = zero @@ -21829,23 +21831,23 @@ module stdlib_linalg_lapack_w else norm = 'I' end if - anorm = stdlib_wlangt( norm, n, dl, d, du ) + anorm = stdlib_${ci}$langt( norm, n, dl, d, du ) ! compute the reciprocal of the condition number of a. - call stdlib_wgtcon( norm, n, dlf, df, duf, du2, ipiv, anorm, rcond, work,info ) + call stdlib_${ci}$gtcon( norm, n, dlf, df, duf, du2, ipiv, anorm, rcond, work,info ) ! compute the solution vectors x. - call stdlib_wlacpy( 'FULL', n, nrhs, b, ldb, x, ldx ) - call stdlib_wgttrs( trans, n, nrhs, dlf, df, duf, du2, ipiv, x, ldx,info ) + call stdlib_${ci}$lacpy( 'FULL', n, nrhs, b, ldb, x, ldx ) + call stdlib_${ci}$gttrs( trans, n, nrhs, dlf, df, duf, du2, ipiv, x, ldx,info ) ! use iterative refinement to improve the computed solutions and ! compute error bounds and backward error estimates for them. - call stdlib_wgtrfs( trans, n, nrhs, dl, d, du, dlf, df, duf, du2, ipiv,b, ldb, x, ldx, & + call stdlib_${ci}$gtrfs( trans, n, nrhs, dl, d, du, dlf, df, duf, du2, ipiv,b, ldb, x, ldx, & ferr, berr, work, rwork, info ) ! set info = n+1 if the matrix is singular to working precision. - if( rcond=nrhs ) then - call stdlib_wgtts2( itrans, n, nrhs, dl, d, du, du2, ipiv, b, ldb ) + call stdlib_${ci}$gtts2( itrans, n, nrhs, dl, d, du, du2, ipiv, b, ldb ) else do j = 1, nrhs, nb jb = min( nrhs-j+1, nb ) - call stdlib_wgtts2( itrans, n, jb, dl, d, du, du2, ipiv, b( 1, j ),ldb ) + call stdlib_${ci}$gtts2( itrans, n, jb, dl, d, du, du2, ipiv, b( 1, j ),ldb ) end do end if - end subroutine stdlib_wgttrs + end subroutine stdlib_${ci}$gttrs - pure subroutine stdlib_wgtts2( itrans, n, nrhs, dl, d, du, du2, ipiv, b, ldb ) + pure subroutine stdlib_${ci}$gtts2( itrans, n, nrhs, dl, d, du, du2, ipiv, b, ldb ) !! ZGTTS2: solves one of the systems of equations !! A * X = B, A**T * X = B, or A**H * X = B, !! with a tridiagonal matrix A using the LU factorization computed @@ -22019,12 +22021,12 @@ module stdlib_linalg_lapack_w integer(ilp), intent(in) :: itrans, ldb, n, nrhs ! Array Arguments integer(ilp), intent(in) :: ipiv(*) - complex(qp), intent(inout) :: b(ldb,*) - complex(qp), intent(in) :: d(*), dl(*), du(*), du2(*) + complex(${ck}$), intent(inout) :: b(ldb,*) + complex(${ck}$), intent(in) :: d(*), dl(*), du(*), du2(*) ! ===================================================================== ! Local Scalars integer(ilp) :: i, j - complex(qp) :: temp + complex(${ck}$) :: temp ! Intrinsic Functions intrinsic :: conjg ! Executable Statements @@ -22175,10 +22177,10 @@ module stdlib_linalg_lapack_w end do end if end if - end subroutine stdlib_wgtts2 + end subroutine stdlib_${ci}$gtts2 - pure subroutine stdlib_whb2st_kernels( uplo, wantz, ttype,st, ed, sweep, n, nb, ib,a, lda, & + pure subroutine stdlib_${ci}$hb2st_kernels( uplo, wantz, ttype,st, ed, sweep, n, nb, ib,a, lda, & !! ZHB2ST_KERNELS: is an internal routine used by the ZHETRD_HB2ST !! subroutine. v, tau, ldvt, work) @@ -22190,14 +22192,14 @@ module stdlib_linalg_lapack_w logical(lk), intent(in) :: wantz integer(ilp), intent(in) :: ttype, st, ed, sweep, n, nb, ib, lda, ldvt ! Array Arguments - complex(qp), intent(inout) :: a(lda,*) - complex(qp), intent(out) :: v(*), tau(*), work(*) + complex(${ck}$), intent(inout) :: a(lda,*) + complex(${ck}$), intent(out) :: v(*), tau(*), work(*) ! ===================================================================== ! Local Scalars logical(lk) :: upper integer(ilp) :: i, j1, j2, lm, ln, vpos, taupos, dpos, ofdpos, ajeter - complex(qp) :: ctmp + complex(${ck}$) :: ctmp ! Intrinsic Functions intrinsic :: conjg,mod ! Executable Statements @@ -22227,15 +22229,15 @@ module stdlib_linalg_lapack_w a( ofdpos-i, st+i ) = czero end do ctmp = conjg( a( ofdpos, st ) ) - call stdlib_wlarfg( lm, ctmp, v( vpos+1 ), 1,tau( taupos ) ) + call stdlib_${ci}$larfg( lm, ctmp, v( vpos+1 ), 1,tau( taupos ) ) a( ofdpos, st ) = ctmp lm = ed - st + 1 - call stdlib_wlarfy( uplo, lm, v( vpos ), 1,conjg( tau( taupos ) ),a( dpos, st )& + call stdlib_${ci}$larfy( uplo, lm, v( vpos ), 1,conjg( tau( taupos ) ),a( dpos, st )& , lda-1, work) endif if( ttype==3 ) then lm = ed - st + 1 - call stdlib_wlarfy( uplo, lm, v( vpos ), 1,conjg( tau( taupos ) ),a( dpos, st )& + call stdlib_${ci}$larfy( uplo, lm, v( vpos ), 1,conjg( tau( taupos ) ),a( dpos, st )& , lda-1, work) endif if( ttype==2 ) then @@ -22244,7 +22246,7 @@ module stdlib_linalg_lapack_w ln = ed-st+1 lm = j2-j1+1 if( lm>0) then - call stdlib_wlarfx( 'LEFT', ln, lm, v( vpos ),conjg( tau( taupos ) ),a( & + call stdlib_${ci}$larfx( 'LEFT', ln, lm, v( vpos ),conjg( tau( taupos ) ),a( & dpos-nb, j1 ), lda-1, work) if( wantz ) then vpos = mod( sweep-1, 2 ) * n + j1 @@ -22259,9 +22261,9 @@ module stdlib_linalg_lapack_w a( dpos-nb-i, j1+i ) = czero end do ctmp = conjg( a( dpos-nb, j1 ) ) - call stdlib_wlarfg( lm, ctmp, v( vpos+1 ), 1, tau( taupos ) ) + call stdlib_${ci}$larfg( lm, ctmp, v( vpos+1 ), 1, tau( taupos ) ) a( dpos-nb, j1 ) = ctmp - call stdlib_wlarfx( 'RIGHT', ln-1, lm, v( vpos ),tau( taupos ),a( dpos-nb+& + call stdlib_${ci}$larfx( 'RIGHT', ln-1, lm, v( vpos ),tau( taupos ),a( dpos-nb+& 1, j1 ), lda-1, work) endif endif @@ -22281,15 +22283,15 @@ module stdlib_linalg_lapack_w v( vpos+i ) = a( ofdpos+i, st-1 ) a( ofdpos+i, st-1 ) = czero end do - call stdlib_wlarfg( lm, a( ofdpos, st-1 ), v( vpos+1 ), 1,tau( taupos ) ) + call stdlib_${ci}$larfg( lm, a( ofdpos, st-1 ), v( vpos+1 ), 1,tau( taupos ) ) lm = ed - st + 1 - call stdlib_wlarfy( uplo, lm, v( vpos ), 1,conjg( tau( taupos ) ),a( dpos, st )& + call stdlib_${ci}$larfy( uplo, lm, v( vpos ), 1,conjg( tau( taupos ) ),a( dpos, st )& , lda-1, work) endif if( ttype==3 ) then lm = ed - st + 1 - call stdlib_wlarfy( uplo, lm, v( vpos ), 1,conjg( tau( taupos ) ),a( dpos, st )& + call stdlib_${ci}$larfy( uplo, lm, v( vpos ), 1,conjg( tau( taupos ) ),a( dpos, st )& , lda-1, work) endif if( ttype==2 ) then @@ -22298,7 +22300,7 @@ module stdlib_linalg_lapack_w ln = ed-st+1 lm = j2-j1+1 if( lm>0) then - call stdlib_wlarfx( 'RIGHT', lm, ln, v( vpos ),tau( taupos ), a( dpos+nb, & + call stdlib_${ci}$larfx( 'RIGHT', lm, ln, v( vpos ),tau( taupos ), a( dpos+nb, & st ),lda-1, work) if( wantz ) then vpos = mod( sweep-1, 2 ) * n + j1 @@ -22312,18 +22314,18 @@ module stdlib_linalg_lapack_w v( vpos+i ) = a( dpos+nb+i, st ) a( dpos+nb+i, st ) = czero end do - call stdlib_wlarfg( lm, a( dpos+nb, st ), v( vpos+1 ), 1,tau( taupos ) ) + call stdlib_${ci}$larfg( lm, a( dpos+nb, st ), v( vpos+1 ), 1,tau( taupos ) ) - call stdlib_wlarfx( 'LEFT', lm, ln-1, v( vpos ),conjg( tau( taupos ) ),a( & + call stdlib_${ci}$larfx( 'LEFT', lm, ln-1, v( vpos ),conjg( tau( taupos ) ),a( & dpos+nb-1, st+1 ), lda-1, work) endif endif endif return - end subroutine stdlib_whb2st_kernels + end subroutine stdlib_${ci}$hb2st_kernels - subroutine stdlib_whbev( jobz, uplo, n, kd, ab, ldab, w, z, ldz, work,rwork, info ) + subroutine stdlib_${ci}$hbev( jobz, uplo, n, kd, ab, ldab, w, z, ldz, work,rwork, info ) !! ZHBEV: computes all the eigenvalues and, optionally, eigenvectors of !! a complex Hermitian band matrix A. ! -- lapack driver routine -- @@ -22334,15 +22336,15 @@ module stdlib_linalg_lapack_w integer(ilp), intent(out) :: info integer(ilp), intent(in) :: kd, ldab, ldz, n ! Array Arguments - real(qp), intent(out) :: rwork(*), w(*) - complex(qp), intent(inout) :: ab(ldab,*) - complex(qp), intent(out) :: work(*), z(ldz,*) + real(${ck}$), intent(out) :: rwork(*), w(*) + complex(${ck}$), intent(inout) :: ab(ldab,*) + complex(${ck}$), intent(out) :: work(*), z(ldz,*) ! ===================================================================== ! Local Scalars logical(lk) :: lower, wantz integer(ilp) :: iinfo, imax, inde, indrwk, iscale - real(qp) :: anrm, bignum, eps, rmax, rmin, safmin, sigma, smlnum + real(${ck}$) :: anrm, bignum, eps, rmax, rmin, safmin, sigma, smlnum ! Intrinsic Functions intrinsic :: sqrt ! Executable Statements @@ -22371,22 +22373,22 @@ module stdlib_linalg_lapack_w if( n==0 )return if( n==1 ) then if( lower ) then - w( 1 ) = real( ab( 1, 1 ),KIND=qp) + w( 1 ) = real( ab( 1, 1 ),KIND=${ck}$) else - w( 1 ) = real( ab( kd+1, 1 ),KIND=qp) + w( 1 ) = real( ab( kd+1, 1 ),KIND=${ck}$) end if if( wantz )z( 1, 1 ) = one return end if ! get machine constants. - safmin = stdlib_qlamch( 'SAFE MINIMUM' ) - eps = stdlib_qlamch( 'PRECISION' ) + safmin = stdlib_${c2ri(ci)}$lamch( 'SAFE MINIMUM' ) + eps = stdlib_${c2ri(ci)}$lamch( 'PRECISION' ) smlnum = safmin / eps bignum = one / smlnum rmin = sqrt( smlnum ) rmax = sqrt( bignum ) ! scale matrix to allowable range, if necessary. - anrm = stdlib_wlanhb( 'M', uplo, n, kd, ab, ldab, rwork ) + anrm = stdlib_${ci}$lanhb( 'M', uplo, n, kd, ab, ldab, rwork ) iscale = 0 if( anrm>zero .and. anrmzero .and. anrm=tmp1 ) )m = 0 end if if( m==1 ) then - w( 1 ) = real( ctmp1,KIND=qp) + w( 1 ) = real( ctmp1,KIND=${ck}$) if( wantz )z( 1, 1 ) = cone end if return end if ! get machine constants. - safmin = stdlib_qlamch( 'SAFE MINIMUM' ) - eps = stdlib_qlamch( 'PRECISION' ) + safmin = stdlib_${c2ri(ci)}$lamch( 'SAFE MINIMUM' ) + eps = stdlib_${c2ri(ci)}$lamch( 'PRECISION' ) smlnum = safmin / eps bignum = one / smlnum rmin = sqrt( smlnum ) @@ -22686,7 +22688,7 @@ module stdlib_linalg_lapack_w vll = zero vuu = zero end if - anrm = stdlib_wlanhb( 'M', uplo, n, kd, ab, ldab, rwork ) + anrm = stdlib_${ci}$lanhb( 'M', uplo, n, kd, ab, ldab, rwork ) if( anrm>zero .and. anrm0 )abstll = abstol*sigma if( valeig ) then @@ -22706,16 +22708,16 @@ module stdlib_linalg_lapack_w vuu = vu*sigma end if end if - ! call stdlib_whbtrd to reduce hermitian band matrix to tridiagonal form. + ! call stdlib_${ci}$hbtrd to reduce hermitian band matrix to tridiagonal form. indd = 1 inde = indd + n indrwk = inde + n indwrk = 1 - call stdlib_whbtrd( jobz, uplo, n, kd, ab, ldab, rwork( indd ),rwork( inde ), q, ldq, & + call stdlib_${ci}$hbtrd( jobz, uplo, n, kd, ab, ldab, rwork( indd ),rwork( inde ), q, ldq, & work( indwrk ), iinfo ) ! if all eigenvalues are desired and abstol is less than or equal - ! to zero, then call stdlib_qsterf or stdlib_wsteqr. if this fails for some - ! eigenvalue, then try stdlib_qstebz. + ! to zero, then call stdlib_${c2ri(ci)}$sterf or stdlib_${ci}$steqr. if this fails for some + ! eigenvalue, then try stdlib_${c2ri(ci)}$stebz. test = .false. if (indeig) then if (il==1 .and. iu==n) then @@ -22723,15 +22725,15 @@ module stdlib_linalg_lapack_w end if end if if ((alleig .or. test) .and. (abstol<=zero)) then - call stdlib_qcopy( n, rwork( indd ), 1, w, 1 ) + call stdlib_${c2ri(ci)}$copy( n, rwork( indd ), 1, w, 1 ) indee = indrwk + 2*n if( .not.wantz ) then - call stdlib_qcopy( n-1, rwork( inde ), 1, rwork( indee ), 1 ) - call stdlib_qsterf( n, w, rwork( indee ), info ) + call stdlib_${c2ri(ci)}$copy( n-1, rwork( inde ), 1, rwork( indee ), 1 ) + call stdlib_${c2ri(ci)}$sterf( n, w, rwork( indee ), info ) else - call stdlib_wlacpy( 'A', n, n, q, ldq, z, ldz ) - call stdlib_qcopy( n-1, rwork( inde ), 1, rwork( indee ), 1 ) - call stdlib_wsteqr( jobz, n, w, rwork( indee ), z, ldz,rwork( indrwk ), info ) + call stdlib_${ci}$lacpy( 'A', n, n, q, ldq, z, ldz ) + call stdlib_${c2ri(ci)}$copy( n-1, rwork( inde ), 1, rwork( indee ), 1 ) + call stdlib_${ci}$steqr( jobz, n, w, rwork( indee ), z, ldz,rwork( indrwk ), info ) if( info==0 ) then do i = 1, n @@ -22745,7 +22747,7 @@ module stdlib_linalg_lapack_w end if info = 0 end if - ! otherwise, call stdlib_qstebz and, if eigenvectors are desired, stdlib_wstein. + ! otherwise, call stdlib_${c2ri(ci)}$stebz and, if eigenvectors are desired, stdlib_${ci}$stein. if( wantz ) then order = 'B' else @@ -22754,17 +22756,17 @@ module stdlib_linalg_lapack_w indibl = 1 indisp = indibl + n indiwk = indisp + n - call stdlib_qstebz( range, order, n, vll, vuu, il, iu, abstll,rwork( indd ), rwork( & + call stdlib_${c2ri(ci)}$stebz( range, order, n, vll, vuu, il, iu, abstll,rwork( indd ), rwork( & inde ), m, nsplit, w,iwork( indibl ), iwork( indisp ), rwork( indrwk ),iwork( indiwk ),& info ) if( wantz ) then - call stdlib_wstein( n, rwork( indd ), rwork( inde ), m, w,iwork( indibl ), iwork( & + call stdlib_${ci}$stein( n, rwork( indd ), rwork( inde ), m, w,iwork( indibl ), iwork( & indisp ), z, ldz,rwork( indrwk ), iwork( indiwk ), ifail, info ) ! apply unitary matrix used in reduction to tridiagonal - ! form to eigenvectors returned by stdlib_wstein. + ! form to eigenvectors returned by stdlib_${ci}$stein. do j = 1, m - call stdlib_wcopy( n, z( 1, j ), 1, work( 1 ), 1 ) - call stdlib_wgemv( 'N', n, n, cone, q, ldq, work, 1, czero,z( 1, j ), 1 ) + call stdlib_${ci}$copy( n, z( 1, j ), 1, work( 1 ), 1 ) + call stdlib_${ci}$gemv( 'N', n, n, cone, q, ldq, work, 1, czero,z( 1, j ), 1 ) end do end if ! if matrix was scaled, then rescale eigenvalues appropriately. @@ -22775,7 +22777,7 @@ module stdlib_linalg_lapack_w else imax = info - 1 end if - call stdlib_qscal( imax, one / sigma, w, 1 ) + call stdlib_${c2ri(ci)}$scal( imax, one / sigma, w, 1 ) end if ! if eigenvalues are not in order, then sort them, along with ! eigenvectors. @@ -22795,7 +22797,7 @@ module stdlib_linalg_lapack_w iwork( indibl+i-1 ) = iwork( indibl+j-1 ) w( j ) = tmp1 iwork( indibl+j-1 ) = itmp1 - call stdlib_wswap( n, z( 1, i ), 1, z( 1, j ), 1 ) + call stdlib_${ci}$swap( n, z( 1, i ), 1, z( 1, j ), 1 ) if( info/=0 ) then itmp1 = ifail( i ) ifail( i ) = ifail( j ) @@ -22805,10 +22807,10 @@ module stdlib_linalg_lapack_w end do end if return - end subroutine stdlib_whbevx + end subroutine stdlib_${ci}$hbevx - pure subroutine stdlib_whbgst( vect, uplo, n, ka, kb, ab, ldab, bb, ldbb, x,ldx, work, rwork,& + pure subroutine stdlib_${ci}$hbgst( vect, uplo, n, ka, kb, ab, ldab, bb, ldbb, x,ldx, work, rwork,& !! ZHBGST: reduces a complex Hermitian-definite banded generalized !! eigenproblem A*x = lambda*B*x to standard form C*y = lambda*y, !! such that C has the same bandwidth as A. @@ -22825,10 +22827,10 @@ module stdlib_linalg_lapack_w integer(ilp), intent(out) :: info integer(ilp), intent(in) :: ka, kb, ldab, ldbb, ldx, n ! Array Arguments - real(qp), intent(out) :: rwork(*) - complex(qp), intent(inout) :: ab(ldab,*) - complex(qp), intent(in) :: bb(ldbb,*) - complex(qp), intent(out) :: work(*), x(ldx,*) + real(${ck}$), intent(out) :: rwork(*) + complex(${ck}$), intent(inout) :: ab(ldab,*) + complex(${ck}$), intent(in) :: bb(ldbb,*) + complex(${ck}$), intent(out) :: work(*), x(ldx,*) ! ===================================================================== @@ -22836,8 +22838,8 @@ module stdlib_linalg_lapack_w logical(lk) :: update, upper, wantx integer(ilp) :: i, i0, i1, i2, inca, j, j1, j1t, j2, j2t, k, ka1, kb1, kbt, l, m, nr, & nrt, nx - real(qp) :: bii - complex(qp) :: ra, ra1, t + real(${ck}$) :: bii + complex(${ck}$) :: ra, ra1, t ! Intrinsic Functions intrinsic :: real,conjg,max,min ! Executable Statements @@ -22872,9 +22874,9 @@ module stdlib_linalg_lapack_w if( n==0 )return inca = ldab*ka1 ! initialize x to the unit matrix, if needed - if( wantx )call stdlib_wlaset( 'FULL', n, n, czero, cone, x, ldx ) + if( wantx )call stdlib_${ci}$laset( 'FULL', n, n, czero, cone, x, ldx ) ! set m to the splitting point m. it must be the same value as is - ! used in stdlib_wpbstf. the chosen value allows the arrays work and rwork + ! used in stdlib_${ci}$pbstf. the chosen value allows the arrays work and rwork ! to be of dimension (n). m = ( n+kb ) / 2 ! the routine works in two phases, corresponding to the two halves @@ -22944,8 +22946,8 @@ module stdlib_linalg_lapack_w ! transform a, working with the upper triangle if( update ) then ! form inv(s(i))**h * a * inv(s(i)) - bii = real( bb( kb1, i ),KIND=qp) - ab( ka1, i ) = ( real( ab( ka1, i ),KIND=qp) / bii ) / bii + bii = real( bb( kb1, i ),KIND=${ck}$) + ab( ka1, i ) = ( real( ab( ka1, i ),KIND=${ck}$) / bii ) / bii do j = i + 1, i1 ab( i-j+ka1, j ) = ab( i-j+ka1, j ) / bii end do @@ -22956,7 +22958,7 @@ module stdlib_linalg_lapack_w do j = i - kbt, k ab( j-k+ka1, k ) = ab( j-k+ka1, k ) -bb( j-i+kb1, i )*conjg( ab( k-i+ka1, & i ) ) -conjg( bb( k-i+kb1, i ) )*ab( j-i+ka1, i ) +real( ab( ka1, i ),& - KIND=qp)*bb( j-i+kb1, i )*conjg( bb( k-i+kb1, i ) ) + KIND=${ck}$)*bb( j-i+kb1, i )*conjg( bb( k-i+kb1, i ) ) end do do j = max( 1, i-ka ), i - kbt - 1 ab( j-k+ka1, k ) = ab( j-k+ka1, k ) -conjg( bb( k-i+kb1, i ) )*ab( j-i+ka1,& @@ -22971,8 +22973,8 @@ module stdlib_linalg_lapack_w end do if( wantx ) then ! post-multiply x by inv(s(i)) - call stdlib_wdscal( n-m, one / bii, x( m+1, i ), 1 ) - if( kbt>0 )call stdlib_wgerc( n-m, kbt, -cone, x( m+1, i ), 1,bb( kb1-kbt, i )& + call stdlib_${ci}$dscal( n-m, one / bii, x( m+1, i ), 1 ) + if( kbt>0 )call stdlib_${ci}$gerc( n-m, kbt, -cone, x( m+1, i ), 1,bb( kb1-kbt, i )& , 1, x( m+1, i-kbt ),ldx ) end if ! store a(i,i1) in ra1 for use in next loop over k @@ -22987,7 +22989,7 @@ module stdlib_linalg_lapack_w ! which has in theory just been created if( i-k+ka1 ) then ! generate rotation to annihilate a(i,i-k+ka+1) - call stdlib_wlartg( ab( k+1, i-k+ka ), ra1,rwork( i-k+ka-m ), work( i-k+ka-& + call stdlib_${ci}$lartg( ab( k+1, i-k+ka ), ra1,rwork( i-k+ka-m ), work( i-k+ka-& m ), ra ) ! create nonzero element a(i-k,i-k+ka+1) outside the ! band and store it in work(i-k) @@ -23016,30 +23018,30 @@ module stdlib_linalg_lapack_w end do ! generate rotations in 1st set to annihilate elements which ! have been created outside the band - if( nrt>0 )call stdlib_wlargv( nrt, ab( 1, j2t ), inca, work( j2t-m ), ka1,rwork(& + if( nrt>0 )call stdlib_${ci}$largv( nrt, ab( 1, j2t ), inca, work( j2t-m ), ka1,rwork(& j2t-m ), ka1 ) if( nr>0 ) then ! apply rotations in 1st set from the right do l = 1, ka - 1 - call stdlib_wlartv( nr, ab( ka1-l, j2 ), inca,ab( ka-l, j2+1 ), inca, & + call stdlib_${ci}$lartv( nr, ab( ka1-l, j2 ), inca,ab( ka-l, j2+1 ), inca, & rwork( j2-m ),work( j2-m ), ka1 ) end do ! apply rotations in 1st set from both sides to diagonal ! blocks - call stdlib_wlar2v( nr, ab( ka1, j2 ), ab( ka1, j2+1 ),ab( ka, j2+1 ), inca, & + call stdlib_${ci}$lar2v( nr, ab( ka1, j2 ), ab( ka1, j2+1 ),ab( ka, j2+1 ), inca, & rwork( j2-m ),work( j2-m ), ka1 ) - call stdlib_wlacgv( nr, work( j2-m ), ka1 ) + call stdlib_${ci}$lacgv( nr, work( j2-m ), ka1 ) end if ! start applying rotations in 1st set from the left do l = ka - 1, kb - k + 1, -1 nrt = ( n-j2+l ) / ka1 - if( nrt>0 )call stdlib_wlartv( nrt, ab( l, j2+ka1-l ), inca,ab( l+1, j2+ka1-l & + if( nrt>0 )call stdlib_${ci}$lartv( nrt, ab( l, j2+ka1-l ), inca,ab( l+1, j2+ka1-l & ), inca, rwork( j2-m ),work( j2-m ), ka1 ) end do if( wantx ) then ! post-multiply x by product of rotations in 1st set do j = j2, j1, ka1 - call stdlib_wrot( n-m, x( m+1, j ), 1, x( m+1, j+1 ), 1,rwork( j-m ), & + call stdlib_${ci}$rot( n-m, x( m+1, j ), 1, x( m+1, j+1 ), 1,rwork( j-m ), & conjg( work( j-m ) ) ) end do end if @@ -23060,7 +23062,7 @@ module stdlib_linalg_lapack_w ! finish applying rotations in 2nd set from the left do l = kb - k, 1, -1 nrt = ( n-j2+ka+l ) / ka1 - if( nrt>0 )call stdlib_wlartv( nrt, ab( l, j2-l+1 ), inca,ab( l+1, j2-l+1 ), & + if( nrt>0 )call stdlib_${ci}$lartv( nrt, ab( l, j2-l+1 ), inca,ab( l+1, j2-l+1 ), & inca, rwork( j2-ka ),work( j2-ka ), ka1 ) end do nr = ( n-j2+ka ) / ka1 @@ -23086,29 +23088,29 @@ module stdlib_linalg_lapack_w if( nr>0 ) then ! generate rotations in 2nd set to annihilate elements ! which have been created outside the band - call stdlib_wlargv( nr, ab( 1, j2 ), inca, work( j2 ), ka1,rwork( j2 ), ka1 ) + call stdlib_${ci}$largv( nr, ab( 1, j2 ), inca, work( j2 ), ka1,rwork( j2 ), ka1 ) ! apply rotations in 2nd set from the right do l = 1, ka - 1 - call stdlib_wlartv( nr, ab( ka1-l, j2 ), inca,ab( ka-l, j2+1 ), inca, & + call stdlib_${ci}$lartv( nr, ab( ka1-l, j2 ), inca,ab( ka-l, j2+1 ), inca, & rwork( j2 ),work( j2 ), ka1 ) end do ! apply rotations in 2nd set from both sides to diagonal ! blocks - call stdlib_wlar2v( nr, ab( ka1, j2 ), ab( ka1, j2+1 ),ab( ka, j2+1 ), inca, & + call stdlib_${ci}$lar2v( nr, ab( ka1, j2 ), ab( ka1, j2+1 ),ab( ka, j2+1 ), inca, & rwork( j2 ),work( j2 ), ka1 ) - call stdlib_wlacgv( nr, work( j2 ), ka1 ) + call stdlib_${ci}$lacgv( nr, work( j2 ), ka1 ) end if ! start applying rotations in 2nd set from the left do l = ka - 1, kb - k + 1, -1 nrt = ( n-j2+l ) / ka1 - if( nrt>0 )call stdlib_wlartv( nrt, ab( l, j2+ka1-l ), inca,ab( l+1, j2+ka1-l & + if( nrt>0 )call stdlib_${ci}$lartv( nrt, ab( l, j2+ka1-l ), inca,ab( l+1, j2+ka1-l & ), inca, rwork( j2 ),work( j2 ), ka1 ) end do if( wantx ) then ! post-multiply x by product of rotations in 2nd set do j = j2, j1, ka1 - call stdlib_wrot( n-m, x( m+1, j ), 1, x( m+1, j+1 ), 1,rwork( j ), conjg( & + call stdlib_${ci}$rot( n-m, x( m+1, j ), 1, x( m+1, j+1 ), 1,rwork( j ), conjg( & work( j ) ) ) end do end if @@ -23118,7 +23120,7 @@ module stdlib_linalg_lapack_w ! finish applying rotations in 1st set from the left do l = kb - k, 1, -1 nrt = ( n-j2+l ) / ka1 - if( nrt>0 )call stdlib_wlartv( nrt, ab( l, j2+ka1-l ), inca,ab( l+1, j2+ka1-l & + if( nrt>0 )call stdlib_${ci}$lartv( nrt, ab( l, j2+ka1-l ), inca,ab( l+1, j2+ka1-l & ), inca, rwork( j2-m ),work( j2-m ), ka1 ) end do end do @@ -23132,8 +23134,8 @@ module stdlib_linalg_lapack_w ! transform a, working with the lower triangle if( update ) then ! form inv(s(i))**h * a * inv(s(i)) - bii = real( bb( 1, i ),KIND=qp) - ab( 1, i ) = ( real( ab( 1, i ),KIND=qp) / bii ) / bii + bii = real( bb( 1, i ),KIND=${ck}$) + ab( 1, i ) = ( real( ab( 1, i ),KIND=${ck}$) / bii ) / bii do j = i + 1, i1 ab( j-i+1, i ) = ab( j-i+1, i ) / bii end do @@ -23143,7 +23145,7 @@ module stdlib_linalg_lapack_w do k = i - kbt, i - 1 do j = i - kbt, k ab( k-j+1, j ) = ab( k-j+1, j ) -bb( i-j+1, j )*conjg( ab( i-k+1,k ) ) - & - conjg( bb( i-k+1, k ) )*ab( i-j+1, j ) + real( ab( 1, i ),KIND=qp)*bb( i-j+& + conjg( bb( i-k+1, k ) )*ab( i-j+1, j ) + real( ab( 1, i ),KIND=${ck}$)*bb( i-j+& 1, j )*conjg( bb( i-k+1,k ) ) end do do j = max( 1, i-ka ), i - kbt - 1 @@ -23158,8 +23160,8 @@ module stdlib_linalg_lapack_w end do if( wantx ) then ! post-multiply x by inv(s(i)) - call stdlib_wdscal( n-m, one / bii, x( m+1, i ), 1 ) - if( kbt>0 )call stdlib_wgeru( n-m, kbt, -cone, x( m+1, i ), 1,bb( kbt+1, i-& + call stdlib_${ci}$dscal( n-m, one / bii, x( m+1, i ), 1 ) + if( kbt>0 )call stdlib_${ci}$geru( n-m, kbt, -cone, x( m+1, i ), 1,bb( kbt+1, i-& kbt ), ldbb-1,x( m+1, i-kbt ), ldx ) end if ! store a(i1,i) in ra1 for use in next loop over k @@ -23174,7 +23176,7 @@ module stdlib_linalg_lapack_w ! which has in theory just been created if( i-k+ka1 ) then ! generate rotation to annihilate a(i-k+ka+1,i) - call stdlib_wlartg( ab( ka1-k, i ), ra1, rwork( i-k+ka-m ),work( i-k+ka-m )& + call stdlib_${ci}$lartg( ab( ka1-k, i ), ra1, rwork( i-k+ka-m ),work( i-k+ka-m )& , ra ) ! create nonzero element a(i-k+ka+1,i-k) outside the ! band and store it in work(i-k) @@ -23203,30 +23205,30 @@ module stdlib_linalg_lapack_w end do ! generate rotations in 1st set to annihilate elements which ! have been created outside the band - if( nrt>0 )call stdlib_wlargv( nrt, ab( ka1, j2t-ka ), inca, work( j2t-m ),ka1, & + if( nrt>0 )call stdlib_${ci}$largv( nrt, ab( ka1, j2t-ka ), inca, work( j2t-m ),ka1, & rwork( j2t-m ), ka1 ) if( nr>0 ) then ! apply rotations in 1st set from the left do l = 1, ka - 1 - call stdlib_wlartv( nr, ab( l+1, j2-l ), inca,ab( l+2, j2-l ), inca, rwork(& + call stdlib_${ci}$lartv( nr, ab( l+1, j2-l ), inca,ab( l+2, j2-l ), inca, rwork(& j2-m ),work( j2-m ), ka1 ) end do ! apply rotations in 1st set from both sides to diagonal ! blocks - call stdlib_wlar2v( nr, ab( 1, j2 ), ab( 1, j2+1 ), ab( 2, j2 ),inca, rwork( & + call stdlib_${ci}$lar2v( nr, ab( 1, j2 ), ab( 1, j2+1 ), ab( 2, j2 ),inca, rwork( & j2-m ), work( j2-m ), ka1 ) - call stdlib_wlacgv( nr, work( j2-m ), ka1 ) + call stdlib_${ci}$lacgv( nr, work( j2-m ), ka1 ) end if ! start applying rotations in 1st set from the right do l = ka - 1, kb - k + 1, -1 nrt = ( n-j2+l ) / ka1 - if( nrt>0 )call stdlib_wlartv( nrt, ab( ka1-l+1, j2 ), inca,ab( ka1-l, j2+1 ),& + if( nrt>0 )call stdlib_${ci}$lartv( nrt, ab( ka1-l+1, j2 ), inca,ab( ka1-l, j2+1 ),& inca, rwork( j2-m ),work( j2-m ), ka1 ) end do if( wantx ) then ! post-multiply x by product of rotations in 1st set do j = j2, j1, ka1 - call stdlib_wrot( n-m, x( m+1, j ), 1, x( m+1, j+1 ), 1,rwork( j-m ), work(& + call stdlib_${ci}$rot( n-m, x( m+1, j ), 1, x( m+1, j+1 ), 1,rwork( j-m ), work(& j-m ) ) end do end if @@ -23247,7 +23249,7 @@ module stdlib_linalg_lapack_w ! finish applying rotations in 2nd set from the right do l = kb - k, 1, -1 nrt = ( n-j2+ka+l ) / ka1 - if( nrt>0 )call stdlib_wlartv( nrt, ab( ka1-l+1, j2-ka ), inca,ab( ka1-l, j2-& + if( nrt>0 )call stdlib_${ci}$lartv( nrt, ab( ka1-l+1, j2-ka ), inca,ab( ka1-l, j2-& ka+1 ), inca,rwork( j2-ka ), work( j2-ka ), ka1 ) end do nr = ( n-j2+ka ) / ka1 @@ -23273,29 +23275,29 @@ module stdlib_linalg_lapack_w if( nr>0 ) then ! generate rotations in 2nd set to annihilate elements ! which have been created outside the band - call stdlib_wlargv( nr, ab( ka1, j2-ka ), inca, work( j2 ), ka1,rwork( j2 ), & + call stdlib_${ci}$largv( nr, ab( ka1, j2-ka ), inca, work( j2 ), ka1,rwork( j2 ), & ka1 ) ! apply rotations in 2nd set from the left do l = 1, ka - 1 - call stdlib_wlartv( nr, ab( l+1, j2-l ), inca,ab( l+2, j2-l ), inca, rwork(& + call stdlib_${ci}$lartv( nr, ab( l+1, j2-l ), inca,ab( l+2, j2-l ), inca, rwork(& j2 ),work( j2 ), ka1 ) end do ! apply rotations in 2nd set from both sides to diagonal ! blocks - call stdlib_wlar2v( nr, ab( 1, j2 ), ab( 1, j2+1 ), ab( 2, j2 ),inca, rwork( & + call stdlib_${ci}$lar2v( nr, ab( 1, j2 ), ab( 1, j2+1 ), ab( 2, j2 ),inca, rwork( & j2 ), work( j2 ), ka1 ) - call stdlib_wlacgv( nr, work( j2 ), ka1 ) + call stdlib_${ci}$lacgv( nr, work( j2 ), ka1 ) end if ! start applying rotations in 2nd set from the right do l = ka - 1, kb - k + 1, -1 nrt = ( n-j2+l ) / ka1 - if( nrt>0 )call stdlib_wlartv( nrt, ab( ka1-l+1, j2 ), inca,ab( ka1-l, j2+1 ),& + if( nrt>0 )call stdlib_${ci}$lartv( nrt, ab( ka1-l+1, j2 ), inca,ab( ka1-l, j2+1 ),& inca, rwork( j2 ),work( j2 ), ka1 ) end do if( wantx ) then ! post-multiply x by product of rotations in 2nd set do j = j2, j1, ka1 - call stdlib_wrot( n-m, x( m+1, j ), 1, x( m+1, j+1 ), 1,rwork( j ), work( & + call stdlib_${ci}$rot( n-m, x( m+1, j ), 1, x( m+1, j+1 ), 1,rwork( j ), work( & j ) ) end do end if @@ -23305,7 +23307,7 @@ module stdlib_linalg_lapack_w ! finish applying rotations in 1st set from the right do l = kb - k, 1, -1 nrt = ( n-j2+l ) / ka1 - if( nrt>0 )call stdlib_wlartv( nrt, ab( ka1-l+1, j2 ), inca,ab( ka1-l, j2+1 ),& + if( nrt>0 )call stdlib_${ci}$lartv( nrt, ab( ka1-l+1, j2 ), inca,ab( ka1-l, j2+1 ),& inca, rwork( j2-m ),work( j2-m ), ka1 ) end do end do @@ -23359,8 +23361,8 @@ module stdlib_linalg_lapack_w ! transform a, working with the upper triangle if( update ) then ! form inv(s(i))**h * a * inv(s(i)) - bii = real( bb( kb1, i ),KIND=qp) - ab( ka1, i ) = ( real( ab( ka1, i ),KIND=qp) / bii ) / bii + bii = real( bb( kb1, i ),KIND=${ck}$) + ab( ka1, i ) = ( real( ab( ka1, i ),KIND=${ck}$) / bii ) / bii do j = i1, i - 1 ab( j-i+ka1, i ) = ab( j-i+ka1, i ) / bii end do @@ -23371,7 +23373,7 @@ module stdlib_linalg_lapack_w do j = k, i + kbt ab( k-j+ka1, j ) = ab( k-j+ka1, j ) -bb( i-j+kb1, j )*conjg( ab( i-k+ka1, & k ) ) -conjg( bb( i-k+kb1, k ) )*ab( i-j+ka1, j ) +real( ab( ka1, i ),& - KIND=qp)*bb( i-j+kb1, j )*conjg( bb( i-k+kb1, k ) ) + KIND=${ck}$)*bb( i-j+kb1, j )*conjg( bb( i-k+kb1, k ) ) end do do j = i + kbt + 1, min( n, i+ka ) ab( k-j+ka1, j ) = ab( k-j+ka1, j ) -conjg( bb( i-k+kb1, k ) )*ab( i-j+ka1,& @@ -23386,8 +23388,8 @@ module stdlib_linalg_lapack_w end do if( wantx ) then ! post-multiply x by inv(s(i)) - call stdlib_wdscal( nx, one / bii, x( 1, i ), 1 ) - if( kbt>0 )call stdlib_wgeru( nx, kbt, -cone, x( 1, i ), 1,bb( kb, i+1 ), & + call stdlib_${ci}$dscal( nx, one / bii, x( 1, i ), 1 ) + if( kbt>0 )call stdlib_${ci}$geru( nx, kbt, -cone, x( 1, i ), 1,bb( kb, i+1 ), & ldbb-1, x( 1, i+1 ), ldx ) end if ! store a(i1,i) in ra1 for use in next loop over k @@ -23401,7 +23403,7 @@ module stdlib_linalg_lapack_w ! which has in theory just been created if( i+k-ka1>0 .and. i+k0 )call stdlib_wlargv( nrt, ab( 1, j1+ka ), inca, work( j1 ), ka1,rwork( & + if( nrt>0 )call stdlib_${ci}$largv( nrt, ab( 1, j1+ka ), inca, work( j1 ), ka1,rwork( & j1 ), ka1 ) if( nr>0 ) then ! apply rotations in 1st set from the left do l = 1, ka - 1 - call stdlib_wlartv( nr, ab( ka1-l, j1+l ), inca,ab( ka-l, j1+l ), inca, & + call stdlib_${ci}$lartv( nr, ab( ka1-l, j1+l ), inca,ab( ka-l, j1+l ), inca, & rwork( j1 ),work( j1 ), ka1 ) end do ! apply rotations in 1st set from both sides to diagonal ! blocks - call stdlib_wlar2v( nr, ab( ka1, j1 ), ab( ka1, j1-1 ),ab( ka, j1 ), inca, & + call stdlib_${ci}$lar2v( nr, ab( ka1, j1 ), ab( ka1, j1-1 ),ab( ka, j1 ), inca, & rwork( j1 ), work( j1 ),ka1 ) - call stdlib_wlacgv( nr, work( j1 ), ka1 ) + call stdlib_${ci}$lacgv( nr, work( j1 ), ka1 ) end if ! start applying rotations in 1st set from the right do l = ka - 1, kb - k + 1, -1 nrt = ( j2+l-1 ) / ka1 j1t = j2 - ( nrt-1 )*ka1 - if( nrt>0 )call stdlib_wlartv( nrt, ab( l, j1t ), inca,ab( l+1, j1t-1 ), inca,& + if( nrt>0 )call stdlib_${ci}$lartv( nrt, ab( l, j1t ), inca,ab( l+1, j1t-1 ), inca,& rwork( j1t ),work( j1t ), ka1 ) end do if( wantx ) then ! post-multiply x by product of rotations in 1st set do j = j1, j2, ka1 - call stdlib_wrot( nx, x( 1, j ), 1, x( 1, j-1 ), 1,rwork( j ), work( j ) ) + call stdlib_${ci}$rot( nx, x( 1, j ), 1, x( 1, j-1 ), 1,rwork( j ), work( j ) ) end do end if @@ -23475,7 +23477,7 @@ module stdlib_linalg_lapack_w do l = kb - k, 1, -1 nrt = ( j2+ka+l-1 ) / ka1 j1t = j2 - ( nrt-1 )*ka1 - if( nrt>0 )call stdlib_wlartv( nrt, ab( l, j1t+ka ), inca,ab( l+1, j1t+ka-1 ),& + if( nrt>0 )call stdlib_${ci}$lartv( nrt, ab( l, j1t+ka ), inca,ab( l+1, j1t+ka-1 ),& inca,rwork( m-kb+j1t+ka ),work( m-kb+j1t+ka ), ka1 ) end do nr = ( j2+ka-1 ) / ka1 @@ -23501,30 +23503,30 @@ module stdlib_linalg_lapack_w if( nr>0 ) then ! generate rotations in 2nd set to annihilate elements ! which have been created outside the band - call stdlib_wlargv( nr, ab( 1, j1+ka ), inca, work( m-kb+j1 ),ka1, rwork( m-& + call stdlib_${ci}$largv( nr, ab( 1, j1+ka ), inca, work( m-kb+j1 ),ka1, rwork( m-& kb+j1 ), ka1 ) ! apply rotations in 2nd set from the left do l = 1, ka - 1 - call stdlib_wlartv( nr, ab( ka1-l, j1+l ), inca,ab( ka-l, j1+l ), inca, & + call stdlib_${ci}$lartv( nr, ab( ka1-l, j1+l ), inca,ab( ka-l, j1+l ), inca, & rwork( m-kb+j1 ),work( m-kb+j1 ), ka1 ) end do ! apply rotations in 2nd set from both sides to diagonal ! blocks - call stdlib_wlar2v( nr, ab( ka1, j1 ), ab( ka1, j1-1 ),ab( ka, j1 ), inca, & + call stdlib_${ci}$lar2v( nr, ab( ka1, j1 ), ab( ka1, j1-1 ),ab( ka, j1 ), inca, & rwork( m-kb+j1 ),work( m-kb+j1 ), ka1 ) - call stdlib_wlacgv( nr, work( m-kb+j1 ), ka1 ) + call stdlib_${ci}$lacgv( nr, work( m-kb+j1 ), ka1 ) end if ! start applying rotations in 2nd set from the right do l = ka - 1, kb - k + 1, -1 nrt = ( j2+l-1 ) / ka1 j1t = j2 - ( nrt-1 )*ka1 - if( nrt>0 )call stdlib_wlartv( nrt, ab( l, j1t ), inca,ab( l+1, j1t-1 ), inca,& + if( nrt>0 )call stdlib_${ci}$lartv( nrt, ab( l, j1t ), inca,ab( l+1, j1t-1 ), inca,& rwork( m-kb+j1t ), work( m-kb+j1t ),ka1 ) end do if( wantx ) then ! post-multiply x by product of rotations in 2nd set do j = j1, j2, ka1 - call stdlib_wrot( nx, x( 1, j ), 1, x( 1, j-1 ), 1,rwork( m-kb+j ), work( & + call stdlib_${ci}$rot( nx, x( 1, j ), 1, x( 1, j-1 ), 1,rwork( m-kb+j ), work( & m-kb+j ) ) end do end if @@ -23535,7 +23537,7 @@ module stdlib_linalg_lapack_w do l = kb - k, 1, -1 nrt = ( j2+l-1 ) / ka1 j1t = j2 - ( nrt-1 )*ka1 - if( nrt>0 )call stdlib_wlartv( nrt, ab( l, j1t ), inca,ab( l+1, j1t-1 ), inca,& + if( nrt>0 )call stdlib_${ci}$lartv( nrt, ab( l, j1t ), inca,ab( l+1, j1t-1 ), inca,& rwork( j1t ),work( j1t ), ka1 ) end do end do @@ -23549,8 +23551,8 @@ module stdlib_linalg_lapack_w ! transform a, working with the lower triangle if( update ) then ! form inv(s(i))**h * a * inv(s(i)) - bii = real( bb( 1, i ),KIND=qp) - ab( 1, i ) = ( real( ab( 1, i ),KIND=qp) / bii ) / bii + bii = real( bb( 1, i ),KIND=${ck}$) + ab( 1, i ) = ( real( ab( 1, i ),KIND=${ck}$) / bii ) / bii do j = i1, i - 1 ab( i-j+1, j ) = ab( i-j+1, j ) / bii end do @@ -23560,7 +23562,7 @@ module stdlib_linalg_lapack_w do k = i + 1, i + kbt do j = k, i + kbt ab( j-k+1, k ) = ab( j-k+1, k ) -bb( j-i+1, i )*conjg( ab( k-i+1,i ) ) - & - conjg( bb( k-i+1, i ) )*ab( j-i+1, i ) + real( ab( 1, i ),KIND=qp)*bb( j-i+& + conjg( bb( k-i+1, i ) )*ab( j-i+1, i ) + real( ab( 1, i ),KIND=${ck}$)*bb( j-i+& 1, i )*conjg( bb( k-i+1,i ) ) end do do j = i + kbt + 1, min( n, i+ka ) @@ -23575,8 +23577,8 @@ module stdlib_linalg_lapack_w end do if( wantx ) then ! post-multiply x by inv(s(i)) - call stdlib_wdscal( nx, one / bii, x( 1, i ), 1 ) - if( kbt>0 )call stdlib_wgerc( nx, kbt, -cone, x( 1, i ), 1, bb( 2, i ),1, x( & + call stdlib_${ci}$dscal( nx, one / bii, x( 1, i ), 1 ) + if( kbt>0 )call stdlib_${ci}$gerc( nx, kbt, -cone, x( 1, i ), 1, bb( 2, i ),1, x( & 1, i+1 ), ldx ) end if ! store a(i,i1) in ra1 for use in next loop over k @@ -23590,7 +23592,7 @@ module stdlib_linalg_lapack_w ! which has in theory just been created if( i+k-ka1>0 .and. i+k0 )call stdlib_wlargv( nrt, ab( ka1, j1 ), inca, work( j1 ), ka1,rwork( & + if( nrt>0 )call stdlib_${ci}$largv( nrt, ab( ka1, j1 ), inca, work( j1 ), ka1,rwork( & j1 ), ka1 ) if( nr>0 ) then ! apply rotations in 1st set from the right do l = 1, ka - 1 - call stdlib_wlartv( nr, ab( l+1, j1 ), inca, ab( l+2, j1-1 ),inca, rwork( & + call stdlib_${ci}$lartv( nr, ab( l+1, j1 ), inca, ab( l+2, j1-1 ),inca, rwork( & j1 ), work( j1 ), ka1 ) end do ! apply rotations in 1st set from both sides to diagonal ! blocks - call stdlib_wlar2v( nr, ab( 1, j1 ), ab( 1, j1-1 ),ab( 2, j1-1 ), inca, rwork(& + call stdlib_${ci}$lar2v( nr, ab( 1, j1 ), ab( 1, j1-1 ),ab( 2, j1-1 ), inca, rwork(& j1 ),work( j1 ), ka1 ) - call stdlib_wlacgv( nr, work( j1 ), ka1 ) + call stdlib_${ci}$lacgv( nr, work( j1 ), ka1 ) end if ! start applying rotations in 1st set from the left do l = ka - 1, kb - k + 1, -1 nrt = ( j2+l-1 ) / ka1 j1t = j2 - ( nrt-1 )*ka1 - if( nrt>0 )call stdlib_wlartv( nrt, ab( ka1-l+1, j1t-ka1+l ), inca,ab( ka1-l, & + if( nrt>0 )call stdlib_${ci}$lartv( nrt, ab( ka1-l+1, j1t-ka1+l ), inca,ab( ka1-l, & j1t-ka1+l ), inca,rwork( j1t ), work( j1t ), ka1 ) end do if( wantx ) then ! post-multiply x by product of rotations in 1st set do j = j1, j2, ka1 - call stdlib_wrot( nx, x( 1, j ), 1, x( 1, j-1 ), 1,rwork( j ), conjg( work(& + call stdlib_${ci}$rot( nx, x( 1, j ), 1, x( 1, j-1 ), 1,rwork( j ), conjg( work(& j ) ) ) end do end if @@ -23665,7 +23667,7 @@ module stdlib_linalg_lapack_w do l = kb - k, 1, -1 nrt = ( j2+ka+l-1 ) / ka1 j1t = j2 - ( nrt-1 )*ka1 - if( nrt>0 )call stdlib_wlartv( nrt, ab( ka1-l+1, j1t+l-1 ), inca,ab( ka1-l, & + if( nrt>0 )call stdlib_${ci}$lartv( nrt, ab( ka1-l+1, j1t+l-1 ), inca,ab( ka1-l, & j1t+l-1 ), inca,rwork( m-kb+j1t+ka ),work( m-kb+j1t+ka ), ka1 ) end do nr = ( j2+ka-1 ) / ka1 @@ -23691,30 +23693,30 @@ module stdlib_linalg_lapack_w if( nr>0 ) then ! generate rotations in 2nd set to annihilate elements ! which have been created outside the band - call stdlib_wlargv( nr, ab( ka1, j1 ), inca, work( m-kb+j1 ),ka1, rwork( m-kb+& + call stdlib_${ci}$largv( nr, ab( ka1, j1 ), inca, work( m-kb+j1 ),ka1, rwork( m-kb+& j1 ), ka1 ) ! apply rotations in 2nd set from the right do l = 1, ka - 1 - call stdlib_wlartv( nr, ab( l+1, j1 ), inca, ab( l+2, j1-1 ),inca, rwork( & + call stdlib_${ci}$lartv( nr, ab( l+1, j1 ), inca, ab( l+2, j1-1 ),inca, rwork( & m-kb+j1 ), work( m-kb+j1 ),ka1 ) end do ! apply rotations in 2nd set from both sides to diagonal ! blocks - call stdlib_wlar2v( nr, ab( 1, j1 ), ab( 1, j1-1 ),ab( 2, j1-1 ), inca, rwork(& + call stdlib_${ci}$lar2v( nr, ab( 1, j1 ), ab( 1, j1-1 ),ab( 2, j1-1 ), inca, rwork(& m-kb+j1 ),work( m-kb+j1 ), ka1 ) - call stdlib_wlacgv( nr, work( m-kb+j1 ), ka1 ) + call stdlib_${ci}$lacgv( nr, work( m-kb+j1 ), ka1 ) end if ! start applying rotations in 2nd set from the left do l = ka - 1, kb - k + 1, -1 nrt = ( j2+l-1 ) / ka1 j1t = j2 - ( nrt-1 )*ka1 - if( nrt>0 )call stdlib_wlartv( nrt, ab( ka1-l+1, j1t-ka1+l ), inca,ab( ka1-l, & + if( nrt>0 )call stdlib_${ci}$lartv( nrt, ab( ka1-l+1, j1t-ka1+l ), inca,ab( ka1-l, & j1t-ka1+l ), inca,rwork( m-kb+j1t ), work( m-kb+j1t ),ka1 ) end do if( wantx ) then ! post-multiply x by product of rotations in 2nd set do j = j1, j2, ka1 - call stdlib_wrot( nx, x( 1, j ), 1, x( 1, j-1 ), 1,rwork( m-kb+j ), conjg( & + call stdlib_${ci}$rot( nx, x( 1, j ), 1, x( 1, j-1 ), 1,rwork( m-kb+j ), conjg( & work( m-kb+j ) ) ) end do end if @@ -23725,7 +23727,7 @@ module stdlib_linalg_lapack_w do l = kb - k, 1, -1 nrt = ( j2+l-1 ) / ka1 j1t = j2 - ( nrt-1 )*ka1 - if( nrt>0 )call stdlib_wlartv( nrt, ab( ka1-l+1, j1t-ka1+l ), inca,ab( ka1-l, & + if( nrt>0 )call stdlib_${ci}$lartv( nrt, ab( ka1-l+1, j1t-ka1+l ), inca,ab( ka1-l, & j1t-ka1+l ), inca,rwork( j1t ), work( j1t ), ka1 ) end do end do @@ -23737,10 +23739,10 @@ module stdlib_linalg_lapack_w end if end if go to 490 - end subroutine stdlib_whbgst + end subroutine stdlib_${ci}$hbgst - pure subroutine stdlib_whbgv( jobz, uplo, n, ka, kb, ab, ldab, bb, ldbb, w, z,ldz, work, & + pure subroutine stdlib_${ci}$hbgv( jobz, uplo, n, ka, kb, ab, ldab, bb, ldbb, w, z,ldz, work, & !! ZHBGV: computes all the eigenvalues, and optionally, the eigenvectors !! of a complex generalized Hermitian-definite banded eigenproblem, of !! the form A*x=(lambda)*B*x. Here A and B are assumed to be Hermitian @@ -23754,9 +23756,9 @@ module stdlib_linalg_lapack_w integer(ilp), intent(out) :: info integer(ilp), intent(in) :: ka, kb, ldab, ldbb, ldz, n ! Array Arguments - real(qp), intent(out) :: rwork(*), w(*) - complex(qp), intent(inout) :: ab(ldab,*), bb(ldbb,*) - complex(qp), intent(out) :: work(*), z(ldz,*) + real(${ck}$), intent(out) :: rwork(*), w(*) + complex(${ck}$), intent(inout) :: ab(ldab,*), bb(ldbb,*) + complex(${ck}$), intent(out) :: work(*), z(ldz,*) ! ===================================================================== ! Local Scalars logical(lk) :: upper, wantz @@ -23791,7 +23793,7 @@ module stdlib_linalg_lapack_w ! quick return if possible if( n==0 )return ! form a split cholesky factorization of b. - call stdlib_wpbstf( uplo, n, kb, bb, ldbb, info ) + call stdlib_${ci}$pbstf( uplo, n, kb, bb, ldbb, info ) if( info/=0 ) then info = n + info return @@ -23799,7 +23801,7 @@ module stdlib_linalg_lapack_w ! transform problem to standard eigenvalue problem. inde = 1 indwrk = inde + n - call stdlib_whbgst( jobz, uplo, n, ka, kb, ab, ldab, bb, ldbb, z, ldz,work, rwork( & + call stdlib_${ci}$hbgst( jobz, uplo, n, ka, kb, ab, ldab, bb, ldbb, z, ldz,work, rwork( & indwrk ), iinfo ) ! reduce to tridiagonal form. if( wantz ) then @@ -23807,20 +23809,20 @@ module stdlib_linalg_lapack_w else vect = 'N' end if - call stdlib_whbtrd( vect, uplo, n, ka, ab, ldab, w, rwork( inde ), z,ldz, work, iinfo ) + call stdlib_${ci}$hbtrd( vect, uplo, n, ka, ab, ldab, w, rwork( inde ), z,ldz, work, iinfo ) - ! for eigenvalues only, call stdlib_qsterf. for eigenvectors, call stdlib_wsteqr. + ! for eigenvalues only, call stdlib_${c2ri(ci)}$sterf. for eigenvectors, call stdlib_${ci}$steqr. if( .not.wantz ) then - call stdlib_qsterf( n, w, rwork( inde ), info ) + call stdlib_${c2ri(ci)}$sterf( n, w, rwork( inde ), info ) else - call stdlib_wsteqr( jobz, n, w, rwork( inde ), z, ldz,rwork( indwrk ), info ) + call stdlib_${ci}$steqr( jobz, n, w, rwork( inde ), z, ldz,rwork( indwrk ), info ) end if return - end subroutine stdlib_whbgv + end subroutine stdlib_${ci}$hbgv - pure subroutine stdlib_whbgvd( jobz, uplo, n, ka, kb, ab, ldab, bb, ldbb, w,z, ldz, work, & + pure subroutine stdlib_${ci}$hbgvd( jobz, uplo, n, ka, kb, ab, ldab, bb, ldbb, w,z, ldz, work, & !! ZHBGVD: computes all the eigenvalues, and optionally, the eigenvectors !! of a complex generalized Hermitian-definite banded eigenproblem, of !! the form A*x=(lambda)*B*x. Here A and B are assumed to be Hermitian @@ -23842,9 +23844,9 @@ module stdlib_linalg_lapack_w integer(ilp), intent(in) :: ka, kb, ldab, ldbb, ldz, liwork, lrwork, lwork, n ! Array Arguments integer(ilp), intent(out) :: iwork(*) - real(qp), intent(out) :: rwork(*), w(*) - complex(qp), intent(inout) :: ab(ldab,*), bb(ldbb,*) - complex(qp), intent(out) :: work(*), z(ldz,*) + real(${ck}$), intent(out) :: rwork(*), w(*) + complex(${ck}$), intent(inout) :: ab(ldab,*), bb(ldbb,*) + complex(${ck}$), intent(out) :: work(*), z(ldz,*) ! ===================================================================== ! Local Scalars @@ -23909,7 +23911,7 @@ module stdlib_linalg_lapack_w ! quick return if possible if( n==0 )return ! form a split cholesky factorization of b. - call stdlib_wpbstf( uplo, n, kb, bb, ldbb, info ) + call stdlib_${ci}$pbstf( uplo, n, kb, bb, ldbb, info ) if( info/=0 ) then info = n + info return @@ -23920,7 +23922,7 @@ module stdlib_linalg_lapack_w indwk2 = 1 + n*n llwk2 = lwork - indwk2 + 2 llrwk = lrwork - indwrk + 2 - call stdlib_whbgst( jobz, uplo, n, ka, kb, ab, ldab, bb, ldbb, z, ldz,work, rwork, & + call stdlib_${ci}$hbgst( jobz, uplo, n, ka, kb, ab, ldab, bb, ldbb, z, ldz,work, rwork, & iinfo ) ! reduce hermitian band matrix to tridiagonal form. if( wantz ) then @@ -23928,26 +23930,26 @@ module stdlib_linalg_lapack_w else vect = 'N' end if - call stdlib_whbtrd( vect, uplo, n, ka, ab, ldab, w, rwork( inde ), z,ldz, work, iinfo ) + call stdlib_${ci}$hbtrd( vect, uplo, n, ka, ab, ldab, w, rwork( inde ), z,ldz, work, iinfo ) - ! for eigenvalues only, call stdlib_qsterf. for eigenvectors, call stdlib_wstedc. + ! for eigenvalues only, call stdlib_${c2ri(ci)}$sterf. for eigenvectors, call stdlib_${ci}$stedc. if( .not.wantz ) then - call stdlib_qsterf( n, w, rwork( inde ), info ) + call stdlib_${c2ri(ci)}$sterf( n, w, rwork( inde ), info ) else - call stdlib_wstedc( 'I', n, w, rwork( inde ), work, n, work( indwk2 ),llwk2, rwork( & + call stdlib_${ci}$stedc( 'I', n, w, rwork( inde ), work, n, work( indwk2 ),llwk2, rwork( & indwrk ), llrwk, iwork, liwork,info ) - call stdlib_wgemm( 'N', 'N', n, n, n, cone, z, ldz, work, n, czero,work( indwk2 ), & + call stdlib_${ci}$gemm( 'N', 'N', n, n, n, cone, z, ldz, work, n, czero,work( indwk2 ), & n ) - call stdlib_wlacpy( 'A', n, n, work( indwk2 ), n, z, ldz ) + call stdlib_${ci}$lacpy( 'A', n, n, work( indwk2 ), n, z, ldz ) end if work( 1 ) = lwmin rwork( 1 ) = lrwmin iwork( 1 ) = liwmin return - end subroutine stdlib_whbgvd + end subroutine stdlib_${ci}$hbgvd - pure subroutine stdlib_whbgvx( jobz, range, uplo, n, ka, kb, ab, ldab, bb,ldbb, q, ldq, vl, & + pure subroutine stdlib_${ci}$hbgvx( jobz, range, uplo, n, ka, kb, ab, ldab, bb,ldbb, q, ldq, vl, & !! ZHBGVX: computes all the eigenvalues, and optionally, the eigenvectors !! of a complex generalized Hermitian-definite banded eigenproblem, of !! the form A*x=(lambda)*B*x. Here A and B are assumed to be Hermitian @@ -23962,12 +23964,12 @@ module stdlib_linalg_lapack_w character, intent(in) :: jobz, range, uplo integer(ilp), intent(in) :: il, iu, ka, kb, ldab, ldbb, ldq, ldz, n integer(ilp), intent(out) :: info, m - real(qp), intent(in) :: abstol, vl, vu + real(${ck}$), intent(in) :: abstol, vl, vu ! Array Arguments integer(ilp), intent(out) :: ifail(*), iwork(*) - real(qp), intent(out) :: rwork(*), w(*) - complex(qp), intent(inout) :: ab(ldab,*), bb(ldbb,*) - complex(qp), intent(out) :: q(ldq,*), work(*), z(ldz,*) + real(${ck}$), intent(out) :: rwork(*), w(*) + complex(${ck}$), intent(inout) :: ab(ldab,*), bb(ldbb,*) + complex(${ck}$), intent(out) :: q(ldq,*), work(*), z(ldz,*) ! ===================================================================== @@ -23976,7 +23978,7 @@ module stdlib_linalg_lapack_w character :: order, vect integer(ilp) :: i, iinfo, indd, inde, indee, indibl, indisp, indiwk, indrwk, indwrk, & itmp1, j, jj, nsplit - real(qp) :: tmp1 + real(${ck}$) :: tmp1 ! Intrinsic Functions intrinsic :: min ! Executable Statements @@ -24029,13 +24031,13 @@ module stdlib_linalg_lapack_w m = 0 if( n==0 )return ! form a split cholesky factorization of b. - call stdlib_wpbstf( uplo, n, kb, bb, ldbb, info ) + call stdlib_${ci}$pbstf( uplo, n, kb, bb, ldbb, info ) if( info/=0 ) then info = n + info return end if ! transform problem to standard eigenvalue problem. - call stdlib_whbgst( jobz, uplo, n, ka, kb, ab, ldab, bb, ldbb, q, ldq,work, rwork, & + call stdlib_${ci}$hbgst( jobz, uplo, n, ka, kb, ab, ldab, bb, ldbb, q, ldq,work, rwork, & iinfo ) ! solve the standard eigenvalue problem. ! reduce hermitian band matrix to tridiagonal form. @@ -24048,11 +24050,11 @@ module stdlib_linalg_lapack_w else vect = 'N' end if - call stdlib_whbtrd( vect, uplo, n, ka, ab, ldab, rwork( indd ),rwork( inde ), q, ldq, & + call stdlib_${ci}$hbtrd( vect, uplo, n, ka, ab, ldab, rwork( indd ),rwork( inde ), q, ldq, & work( indwrk ), iinfo ) ! if all eigenvalues are desired and abstol is less than or equal - ! to zero, then call stdlib_qsterf or stdlib_wsteqr. if this fails for some - ! eigenvalue, then try stdlib_qstebz. + ! to zero, then call stdlib_${c2ri(ci)}$sterf or stdlib_${ci}$steqr. if this fails for some + ! eigenvalue, then try stdlib_${c2ri(ci)}$stebz. test = .false. if( indeig ) then if( il==1 .and. iu==n ) then @@ -24060,14 +24062,14 @@ module stdlib_linalg_lapack_w end if end if if( ( alleig .or. test ) .and. ( abstol<=zero ) ) then - call stdlib_qcopy( n, rwork( indd ), 1, w, 1 ) + call stdlib_${c2ri(ci)}$copy( n, rwork( indd ), 1, w, 1 ) indee = indrwk + 2*n - call stdlib_qcopy( n-1, rwork( inde ), 1, rwork( indee ), 1 ) + call stdlib_${c2ri(ci)}$copy( n-1, rwork( inde ), 1, rwork( indee ), 1 ) if( .not.wantz ) then - call stdlib_qsterf( n, w, rwork( indee ), info ) + call stdlib_${c2ri(ci)}$sterf( n, w, rwork( indee ), info ) else - call stdlib_wlacpy( 'A', n, n, q, ldq, z, ldz ) - call stdlib_wsteqr( jobz, n, w, rwork( indee ), z, ldz,rwork( indrwk ), info ) + call stdlib_${ci}$lacpy( 'A', n, n, q, ldq, z, ldz ) + call stdlib_${ci}$steqr( jobz, n, w, rwork( indee ), z, ldz,rwork( indrwk ), info ) if( info==0 ) then do i = 1, n @@ -24081,8 +24083,8 @@ module stdlib_linalg_lapack_w end if info = 0 end if - ! otherwise, call stdlib_qstebz and, if eigenvectors are desired, - ! call stdlib_wstein. + ! otherwise, call stdlib_${c2ri(ci)}$stebz and, if eigenvectors are desired, + ! call stdlib_${ci}$stein. if( wantz ) then order = 'B' else @@ -24091,17 +24093,17 @@ module stdlib_linalg_lapack_w indibl = 1 indisp = indibl + n indiwk = indisp + n - call stdlib_qstebz( range, order, n, vl, vu, il, iu, abstol,rwork( indd ), rwork( inde & + call stdlib_${c2ri(ci)}$stebz( range, order, n, vl, vu, il, iu, abstol,rwork( indd ), rwork( inde & ), m, nsplit, w,iwork( indibl ), iwork( indisp ), rwork( indrwk ),iwork( indiwk ), & info ) if( wantz ) then - call stdlib_wstein( n, rwork( indd ), rwork( inde ), m, w,iwork( indibl ), iwork( & + call stdlib_${ci}$stein( n, rwork( indd ), rwork( inde ), m, w,iwork( indibl ), iwork( & indisp ), z, ldz,rwork( indrwk ), iwork( indiwk ), ifail, info ) ! apply unitary matrix used in reduction to tridiagonal - ! form to eigenvectors returned by stdlib_wstein. + ! form to eigenvectors returned by stdlib_${ci}$stein. do j = 1, m - call stdlib_wcopy( n, z( 1, j ), 1, work( 1 ), 1 ) - call stdlib_wgemv( 'N', n, n, cone, q, ldq, work, 1, czero,z( 1, j ), 1 ) + call stdlib_${ci}$copy( n, z( 1, j ), 1, work( 1 ), 1 ) + call stdlib_${ci}$gemv( 'N', n, n, cone, q, ldq, work, 1, czero,z( 1, j ), 1 ) end do end if 30 continue @@ -24123,7 +24125,7 @@ module stdlib_linalg_lapack_w iwork( indibl+i-1 ) = iwork( indibl+j-1 ) w( j ) = tmp1 iwork( indibl+j-1 ) = itmp1 - call stdlib_wswap( n, z( 1, i ), 1, z( 1, j ), 1 ) + call stdlib_${ci}$swap( n, z( 1, i ), 1, z( 1, j ), 1 ) if( info/=0 ) then itmp1 = ifail( i ) ifail( i ) = ifail( j ) @@ -24133,10 +24135,10 @@ module stdlib_linalg_lapack_w end do end if return - end subroutine stdlib_whbgvx + end subroutine stdlib_${ci}$hbgvx - pure subroutine stdlib_whbtrd( vect, uplo, n, kd, ab, ldab, d, e, q, ldq,work, info ) + pure subroutine stdlib_${ci}$hbtrd( vect, uplo, n, kd, ab, ldab, d, e, q, ldq,work, info ) !! ZHBTRD: reduces a complex Hermitian band matrix A to real symmetric !! tridiagonal form T by a unitary similarity transformation: !! Q**H * A * Q = T. @@ -24148,9 +24150,9 @@ module stdlib_linalg_lapack_w integer(ilp), intent(out) :: info integer(ilp), intent(in) :: kd, ldab, ldq, n ! Array Arguments - real(qp), intent(out) :: d(*), e(*) - complex(qp), intent(inout) :: ab(ldab,*), q(ldq,*) - complex(qp), intent(out) :: work(*) + real(${ck}$), intent(out) :: d(*), e(*) + complex(${ck}$), intent(inout) :: ab(ldab,*), q(ldq,*) + complex(${ck}$), intent(out) :: work(*) ! ===================================================================== @@ -24158,8 +24160,8 @@ module stdlib_linalg_lapack_w logical(lk) :: initq, upper, wantq integer(ilp) :: i, i2, ibl, inca, incx, iqaend, iqb, iqend, j, j1, j1end, j1inc, j2, & jend, jin, jinc, k, kd1, kdm1, kdn, l, last, lend, nq, nr, nrt - real(qp) :: abst - complex(qp) :: t, temp + real(${ck}$) :: abst + complex(${ck}$) :: t, temp ! Intrinsic Functions intrinsic :: abs,real,conjg,max,min ! Executable Statements @@ -24192,7 +24194,7 @@ module stdlib_linalg_lapack_w ! quick return if possible if( n==0 )return ! initialize q to the unit matrix, if needed - if( initq )call stdlib_wlaset( 'FULL', n, n, czero, cone, q, ldq ) + if( initq )call stdlib_${ci}$laset( 'FULL', n, n, czero, cone, q, ldq ) ! wherever possible, plane rotations are generated and applied in ! vector operations of length nr over the index set j1:j2:kd1. ! the real cosines and complex sines of the plane rotations are @@ -24206,7 +24208,7 @@ module stdlib_linalg_lapack_w nr = 0 j1 = kdn + 2 j2 = 1 - ab( kd1, 1 ) = real( ab( kd1, 1 ),KIND=qp) + ab( kd1, 1 ) = real( ab( kd1, 1 ),KIND=${ck}$) loop_90: do i = 1, n - 2 ! reduce i-th row of matrix to tridiagonal form loop_80: do k = kdn + 1, 2, -1 @@ -24215,20 +24217,20 @@ module stdlib_linalg_lapack_w if( nr>0 ) then ! generate plane rotations to annihilate nonzero ! elements which have been created outside the band - call stdlib_wlargv( nr, ab( 1, j1-1 ), inca, work( j1 ),kd1, d( j1 ), & + call stdlib_${ci}$largv( nr, ab( 1, j1-1 ), inca, work( j1 ),kd1, d( j1 ), & kd1 ) ! apply rotations from the right ! dependent on the the number of diagonals either - ! stdlib_wlartv or stdlib_wrot is used + ! stdlib_${ci}$lartv or stdlib_${ci}$rot is used if( nr>=2*kd-1 ) then do l = 1, kd - 1 - call stdlib_wlartv( nr, ab( l+1, j1-1 ), inca,ab( l, j1 ), inca, & + call stdlib_${ci}$lartv( nr, ab( l+1, j1-1 ), inca,ab( l, j1 ), inca, & d( j1 ),work( j1 ), kd1 ) end do else jend = j1 + ( nr-1 )*kd1 do jinc = j1, jend, kd1 - call stdlib_wrot( kdm1, ab( 2, jinc-1 ), 1,ab( 1, jinc ), 1, d( & + call stdlib_${ci}$rot( kdm1, ab( 2, jinc-1 ), 1,ab( 1, jinc ), 1, d( & jinc ),work( jinc ) ) end do end if @@ -24237,11 +24239,11 @@ module stdlib_linalg_lapack_w if( k<=n-i+1 ) then ! generate plane rotation to annihilate a(i,i+k-1) ! within the band - call stdlib_wlartg( ab( kd-k+3, i+k-2 ),ab( kd-k+2, i+k-1 ), d( i+k-& + call stdlib_${ci}$lartg( ab( kd-k+3, i+k-2 ),ab( kd-k+2, i+k-1 ), d( i+k-& 1 ),work( i+k-1 ), temp ) ab( kd-k+3, i+k-2 ) = temp ! apply rotation from the right - call stdlib_wrot( k-3, ab( kd-k+4, i+k-2 ), 1,ab( kd-k+3, i+k-1 ), 1,& + call stdlib_${ci}$rot( k-3, ab( kd-k+4, i+k-2 ), 1,ab( kd-k+3, i+k-1 ), 1,& d( i+k-1 ),work( i+k-1 ) ) end if nr = nr + 1 @@ -24249,34 +24251,34 @@ module stdlib_linalg_lapack_w end if ! apply plane rotations from both sides to diagonal ! blocks - if( nr>0 )call stdlib_wlar2v( nr, ab( kd1, j1-1 ), ab( kd1, j1 ),ab( kd, & + if( nr>0 )call stdlib_${ci}$lar2v( nr, ab( kd1, j1-1 ), ab( kd1, j1 ),ab( kd, & j1 ), inca, d( j1 ),work( j1 ), kd1 ) ! apply plane rotations from the left if( nr>0 ) then - call stdlib_wlacgv( nr, work( j1 ), kd1 ) + call stdlib_${ci}$lacgv( nr, work( j1 ), kd1 ) if( 2*kd-1n ) then nrt = nr - 1 else nrt = nr end if - if( nrt>0 )call stdlib_wlartv( nrt, ab( kd-l, j1+l ), inca,ab( kd-& + if( nrt>0 )call stdlib_${ci}$lartv( nrt, ab( kd-l, j1+l ), inca,ab( kd-& l+1, j1+l ), inca,d( j1 ), work( j1 ), kd1 ) end do else j1end = j1 + kd1*( nr-2 ) if( j1end>=j1 ) then do jin = j1, j1end, kd1 - call stdlib_wrot( kd-1, ab( kd-1, jin+1 ), incx,ab( kd, jin+1 )& + call stdlib_${ci}$rot( kd-1, ab( kd-1, jin+1 ), incx,ab( kd, jin+1 )& , incx,d( jin ), work( jin ) ) end do end if lend = min( kdm1, n-j2 ) last = j1end + kd1 - if( lend>0 )call stdlib_wrot( lend, ab( kd-1, last+1 ), incx,ab( kd, & + if( lend>0 )call stdlib_${ci}$rot( lend, ab( kd-1, last+1 ), incx,ab( kd, & last+1 ), incx, d( last ),work( last ) ) end if end if @@ -24296,12 +24298,12 @@ module stdlib_linalg_lapack_w iqb = max( 1, j-ibl ) nq = 1 + iqaend - iqb iqaend = min( iqaend+kd, iqend ) - call stdlib_wrot( nq, q( iqb, j-1 ), 1, q( iqb, j ),1, d( j ), & + call stdlib_${ci}$rot( nq, q( iqb, j-1 ), 1, q( iqb, j ),1, d( j ), & conjg( work( j ) ) ) end do else do j = j1, j2, kd1 - call stdlib_wrot( n, q( 1, j-1 ), 1, q( 1, j ), 1,d( j ), conjg( & + call stdlib_${ci}$rot( n, q( 1, j-1 ), 1, q( 1, j ), 1,d( j ), conjg( & work( j ) ) ) end do end if @@ -24334,7 +24336,7 @@ module stdlib_linalg_lapack_w end if if( i1 ) then @@ -24354,7 +24356,7 @@ module stdlib_linalg_lapack_w nr = 0 j1 = kdn + 2 j2 = 1 - ab( 1, 1 ) = real( ab( 1, 1 ),KIND=qp) + ab( 1, 1 ) = real( ab( 1, 1 ),KIND=${ck}$) loop_210: do i = 1, n - 2 ! reduce i-th column of matrix to tridiagonal form loop_200: do k = kdn + 1, 2, -1 @@ -24363,20 +24365,20 @@ module stdlib_linalg_lapack_w if( nr>0 ) then ! generate plane rotations to annihilate nonzero ! elements which have been created outside the band - call stdlib_wlargv( nr, ab( kd1, j1-kd1 ), inca,work( j1 ), kd1, d( j1 )& + call stdlib_${ci}$largv( nr, ab( kd1, j1-kd1 ), inca,work( j1 ), kd1, d( j1 )& , kd1 ) ! apply plane rotations from one side ! dependent on the the number of diagonals either - ! stdlib_wlartv or stdlib_wrot is used + ! stdlib_${ci}$lartv or stdlib_${ci}$rot is used if( nr>2*kd-1 ) then do l = 1, kd - 1 - call stdlib_wlartv( nr, ab( kd1-l, j1-kd1+l ), inca,ab( kd1-l+1, & + call stdlib_${ci}$lartv( nr, ab( kd1-l, j1-kd1+l ), inca,ab( kd1-l+1, & j1-kd1+l ), inca,d( j1 ), work( j1 ), kd1 ) end do else jend = j1 + kd1*( nr-1 ) do jinc = j1, jend, kd1 - call stdlib_wrot( kdm1, ab( kd, jinc-kd ), incx,ab( kd1, jinc-kd )& + call stdlib_${ci}$rot( kdm1, ab( kd, jinc-kd ), incx,ab( kd1, jinc-kd )& , incx,d( jinc ), work( jinc ) ) end do end if @@ -24385,11 +24387,11 @@ module stdlib_linalg_lapack_w if( k<=n-i+1 ) then ! generate plane rotation to annihilate a(i+k-1,i) ! within the band - call stdlib_wlartg( ab( k-1, i ), ab( k, i ),d( i+k-1 ), work( i+k-1 & + call stdlib_${ci}$lartg( ab( k-1, i ), ab( k, i ),d( i+k-1 ), work( i+k-1 & ), temp ) ab( k-1, i ) = temp ! apply rotation from the left - call stdlib_wrot( k-3, ab( k-2, i+1 ), ldab-1,ab( k-1, i+1 ), ldab-1,& + call stdlib_${ci}$rot( k-3, ab( k-2, i+1 ), ldab-1,ab( k-1, i+1 ), ldab-1,& d( i+k-1 ),work( i+k-1 ) ) end if nr = nr + 1 @@ -24397,13 +24399,13 @@ module stdlib_linalg_lapack_w end if ! apply plane rotations from both sides to diagonal ! blocks - if( nr>0 )call stdlib_wlar2v( nr, ab( 1, j1-1 ), ab( 1, j1 ),ab( 2, j1-1 ),& + if( nr>0 )call stdlib_${ci}$lar2v( nr, ab( 1, j1-1 ), ab( 1, j1 ),ab( 2, j1-1 ),& inca, d( j1 ),work( j1 ), kd1 ) ! apply plane rotations from the right ! dependent on the the number of diagonals either - ! stdlib_wlartv or stdlib_wrot is used + ! stdlib_${ci}$lartv or stdlib_${ci}$rot is used if( nr>0 ) then - call stdlib_wlacgv( nr, work( j1 ), kd1 ) + call stdlib_${ci}$lacgv( nr, work( j1 ), kd1 ) if( nr>2*kd-1 ) then do l = 1, kd - 1 if( j2+l>n ) then @@ -24411,20 +24413,20 @@ module stdlib_linalg_lapack_w else nrt = nr end if - if( nrt>0 )call stdlib_wlartv( nrt, ab( l+2, j1-1 ), inca,ab( l+1,& + if( nrt>0 )call stdlib_${ci}$lartv( nrt, ab( l+2, j1-1 ), inca,ab( l+1,& j1 ), inca, d( j1 ),work( j1 ), kd1 ) end do else j1end = j1 + kd1*( nr-2 ) if( j1end>=j1 ) then do j1inc = j1, j1end, kd1 - call stdlib_wrot( kdm1, ab( 3, j1inc-1 ), 1,ab( 2, j1inc ), 1, & + call stdlib_${ci}$rot( kdm1, ab( 3, j1inc-1 ), 1,ab( 2, j1inc ), 1, & d( j1inc ),work( j1inc ) ) end do end if lend = min( kdm1, n-j2 ) last = j1end + kd1 - if( lend>0 )call stdlib_wrot( lend, ab( 3, last-1 ), 1,ab( 2, last ),& + if( lend>0 )call stdlib_${ci}$rot( lend, ab( 3, last-1 ), 1,ab( 2, last ),& 1, d( last ),work( last ) ) end if end if @@ -24444,12 +24446,12 @@ module stdlib_linalg_lapack_w iqb = max( 1, j-ibl ) nq = 1 + iqaend - iqb iqaend = min( iqaend+kd, iqend ) - call stdlib_wrot( nq, q( iqb, j-1 ), 1, q( iqb, j ),1, d( j ), & + call stdlib_${ci}$rot( nq, q( iqb, j-1 ), 1, q( iqb, j ),1, d( j ), & work( j ) ) end do else do j = j1, j2, kd1 - call stdlib_wrot( n, q( 1, j-1 ), 1, q( 1, j ), 1,d( j ), work( j & + call stdlib_${ci}$rot( n, q( 1, j-1 ), 1, q( 1, j ), 1,d( j ), work( j & ) ) end do end if @@ -24482,7 +24484,7 @@ module stdlib_linalg_lapack_w end if if( izero .and. anrmzero .and. anrm=real( a( 1, 1 ),KIND=qp) )then + if( vl=real( a( 1, 1 ),KIND=${ck}$) )then m = 1 - w( 1 ) = real( a( 1, 1 ),KIND=qp) + w( 1 ) = real( a( 1, 1 ),KIND=${ck}$) end if end if if( wantz ) then @@ -25270,8 +25272,8 @@ module stdlib_linalg_lapack_w return end if ! get machine constants. - safmin = stdlib_qlamch( 'SAFE MINIMUM' ) - eps = stdlib_qlamch( 'PRECISION' ) + safmin = stdlib_${c2ri(ci)}$lamch( 'SAFE MINIMUM' ) + eps = stdlib_${c2ri(ci)}$lamch( 'PRECISION' ) smlnum = safmin / eps bignum = one / smlnum rmin = sqrt( smlnum ) @@ -25283,7 +25285,7 @@ module stdlib_linalg_lapack_w vll = vl vuu = vu end if - anrm = stdlib_wlansy( 'M', uplo, n, a, lda, rwork ) + anrm = stdlib_${ci}$lansy( 'M', uplo, n, a, lda, rwork ) if( anrm>zero .and. anrm0 )abstll = abstol*sigma @@ -25308,9 +25310,9 @@ module stdlib_linalg_lapack_w end if end if ! initialize indices into workspaces. note: the iwork indices are - ! used only if stdlib_qsterf or stdlib_wstemr fail. + ! used only if stdlib_${c2ri(ci)}$sterf or stdlib_${ci}$stemr fail. ! work(indtau:indtau+n-1) stores the complex scalar factors of the - ! elementary reflectors used in stdlib_whetrd. + ! elementary reflectors used in stdlib_${ci}$hetrd. indtau = 1 ! indwk is the starting offset of the remaining complex workspace, ! and llwork is the remaining complex workspace size. @@ -25320,36 +25322,36 @@ module stdlib_linalg_lapack_w ! entries. indrd = 1 ! rwork(indre:indre+n-1) stores the off-diagonal entries of the - ! tridiagonal matrix from stdlib_whetrd. + ! tridiagonal matrix from stdlib_${ci}$hetrd. indre = indrd + n ! rwork(indrdd:indrdd+n-1) is a copy of the diagonal entries over - ! -written by stdlib_wstemr (the stdlib_qsterf path copies the diagonal to w). + ! -written by stdlib_${ci}$stemr (the stdlib_${c2ri(ci)}$sterf path copies the diagonal to w). indrdd = indre + n ! rwork(indree:indree+n-1) is a copy of the off-diagonal entries over - ! -written while computing the eigenvalues in stdlib_qsterf and stdlib_wstemr. + ! -written while computing the eigenvalues in stdlib_${c2ri(ci)}$sterf and stdlib_${ci}$stemr. indree = indrdd + n ! indrwk is the starting offset of the left-over real workspace, and ! llrwork is the remaining workspace size. indrwk = indree + n llrwork = lrwork - indrwk + 1 - ! iwork(indibl:indibl+m-1) corresponds to iblock in stdlib_qstebz and + ! iwork(indibl:indibl+m-1) corresponds to iblock in stdlib_${c2ri(ci)}$stebz and ! stores the block indices of each of the m<=n eigenvalues. indibl = 1 - ! iwork(indisp:indisp+nsplit-1) corresponds to isplit in stdlib_qstebz and + ! iwork(indisp:indisp+nsplit-1) corresponds to isplit in stdlib_${c2ri(ci)}$stebz and ! stores the starting and finishing indices of each block. indisp = indibl + n ! iwork(indifl:indifl+n-1) stores the indices of eigenvectors ! that corresponding to eigenvectors that fail to converge in - ! stdlib_qstein. this information is discarded; if any fail, the driver + ! stdlib_${c2ri(ci)}$stein. this information is discarded; if any fail, the driver ! returns info > 0. indifl = indisp + n ! indiwo is the offset of the remaining integer workspace. indiwo = indifl + n - ! call stdlib_whetrd to reduce hermitian matrix to tridiagonal form. - call stdlib_whetrd( uplo, n, a, lda, rwork( indrd ), rwork( indre ),work( indtau ), & + ! call stdlib_${ci}$hetrd to reduce hermitian matrix to tridiagonal form. + call stdlib_${ci}$hetrd( uplo, n, a, lda, rwork( indrd ), rwork( indre ),work( indtau ), & work( indwk ), llwork, iinfo ) ! if all eigenvalues are desired - ! then call stdlib_qsterf or stdlib_wstemr and stdlib_wunmtr. + ! then call stdlib_${c2ri(ci)}$sterf or stdlib_${ci}$stemr and stdlib_${ci}$unmtr. test = .false. if( indeig ) then if( il==1 .and. iu==n ) then @@ -25358,26 +25360,26 @@ module stdlib_linalg_lapack_w end if if( ( alleig.or.test ) .and. ( ieeeok==1 ) ) then if( .not.wantz ) then - call stdlib_qcopy( n, rwork( indrd ), 1, w, 1 ) - call stdlib_qcopy( n-1, rwork( indre ), 1, rwork( indree ), 1 ) - call stdlib_qsterf( n, w, rwork( indree ), info ) + call stdlib_${c2ri(ci)}$copy( n, rwork( indrd ), 1, w, 1 ) + call stdlib_${c2ri(ci)}$copy( n-1, rwork( indre ), 1, rwork( indree ), 1 ) + call stdlib_${c2ri(ci)}$sterf( n, w, rwork( indree ), info ) else - call stdlib_qcopy( n-1, rwork( indre ), 1, rwork( indree ), 1 ) - call stdlib_qcopy( n, rwork( indrd ), 1, rwork( indrdd ), 1 ) + call stdlib_${c2ri(ci)}$copy( n-1, rwork( indre ), 1, rwork( indree ), 1 ) + call stdlib_${c2ri(ci)}$copy( n, rwork( indrd ), 1, rwork( indrdd ), 1 ) if (abstol <= two*n*eps) then tryrac = .true. else tryrac = .false. end if - call stdlib_wstemr( jobz, 'A', n, rwork( indrdd ),rwork( indree ), vl, vu, il, & + call stdlib_${ci}$stemr( jobz, 'A', n, rwork( indrdd ),rwork( indree ), vl, vu, il, & iu, m, w,z, ldz, n, isuppz, tryrac,rwork( indrwk ), llrwork,iwork, liwork, info ) ! apply unitary matrix used in reduction to tridiagonal - ! form to eigenvectors returned by stdlib_wstemr. + ! form to eigenvectors returned by stdlib_${ci}$stemr. if( wantz .and. info==0 ) then indwkn = indwk llwrkn = lwork - indwkn + 1 - call stdlib_wunmtr( 'L', uplo, 'N', n, m, a, lda,work( indtau ), z, ldz, work(& + call stdlib_${ci}$unmtr( 'L', uplo, 'N', n, m, a, lda,work( indtau ), z, ldz, work(& indwkn ),llwrkn, iinfo ) end if end if @@ -25387,24 +25389,24 @@ module stdlib_linalg_lapack_w end if info = 0 end if - ! otherwise, call stdlib_qstebz and, if eigenvectors are desired, stdlib_wstein. - ! also call stdlib_qstebz and stdlib_wstein if stdlib_wstemr fails. + ! otherwise, call stdlib_${c2ri(ci)}$stebz and, if eigenvectors are desired, stdlib_${ci}$stein. + ! also call stdlib_${c2ri(ci)}$stebz and stdlib_${ci}$stein if stdlib_${ci}$stemr fails. if( wantz ) then order = 'B' else order = 'E' end if - call stdlib_qstebz( range, order, n, vll, vuu, il, iu, abstll,rwork( indrd ), rwork( & + call stdlib_${c2ri(ci)}$stebz( range, order, n, vll, vuu, il, iu, abstll,rwork( indrd ), rwork( & indre ), m, nsplit, w,iwork( indibl ), iwork( indisp ), rwork( indrwk ),iwork( indiwo )& , info ) if( wantz ) then - call stdlib_wstein( n, rwork( indrd ), rwork( indre ), m, w,iwork( indibl ), iwork( & + call stdlib_${ci}$stein( n, rwork( indrd ), rwork( indre ), m, w,iwork( indibl ), iwork( & indisp ), z, ldz,rwork( indrwk ), iwork( indiwo ), iwork( indifl ),info ) ! apply unitary matrix used in reduction to tridiagonal - ! form to eigenvectors returned by stdlib_wstein. + ! form to eigenvectors returned by stdlib_${ci}$stein. indwkn = indwk llwrkn = lwork - indwkn + 1 - call stdlib_wunmtr( 'L', uplo, 'N', n, m, a, lda, work( indtau ), z,ldz, work( & + call stdlib_${ci}$unmtr( 'L', uplo, 'N', n, m, a, lda, work( indtau ), z,ldz, work( & indwkn ), llwrkn, iinfo ) end if ! if matrix was scaled, then rescale eigenvalues appropriately. @@ -25415,7 +25417,7 @@ module stdlib_linalg_lapack_w else imax = info - 1 end if - call stdlib_qscal( imax, one / sigma, w, 1 ) + call stdlib_${c2ri(ci)}$scal( imax, one / sigma, w, 1 ) end if ! if eigenvalues are not in order, then sort them, along with ! eigenvectors. @@ -25435,7 +25437,7 @@ module stdlib_linalg_lapack_w iwork( indibl+i-1 ) = iwork( indibl+j-1 ) w( j ) = tmp1 iwork( indibl+j-1 ) = itmp1 - call stdlib_wswap( n, z( 1, i ), 1, z( 1, j ), 1 ) + call stdlib_${ci}$swap( n, z( 1, i ), 1, z( 1, j ), 1 ) end if end do end if @@ -25444,10 +25446,10 @@ module stdlib_linalg_lapack_w rwork( 1 ) = lrwmin iwork( 1 ) = liwmin return - end subroutine stdlib_wheevr + end subroutine stdlib_${ci}$heevr - subroutine stdlib_wheevx( jobz, range, uplo, n, a, lda, vl, vu, il, iu,abstol, m, w, z, ldz, & + subroutine stdlib_${ci}$heevx( jobz, range, uplo, n, a, lda, vl, vu, il, iu,abstol, m, w, z, ldz, & !! ZHEEVX: computes selected eigenvalues and, optionally, eigenvectors !! of a complex Hermitian matrix A. Eigenvalues and eigenvectors can !! be selected by specifying either a range of values or a range of @@ -25460,12 +25462,12 @@ module stdlib_linalg_lapack_w character, intent(in) :: jobz, range, uplo integer(ilp), intent(in) :: il, iu, lda, ldz, lwork, n integer(ilp), intent(out) :: info, m - real(qp), intent(in) :: abstol, vl, vu + real(${ck}$), intent(in) :: abstol, vl, vu ! Array Arguments integer(ilp), intent(out) :: ifail(*), iwork(*) - real(qp), intent(out) :: rwork(*), w(*) - complex(qp), intent(inout) :: a(lda,*) - complex(qp), intent(out) :: work(*), z(ldz,*) + real(${ck}$), intent(out) :: rwork(*), w(*) + complex(${ck}$), intent(inout) :: a(lda,*) + complex(${ck}$), intent(out) :: work(*), z(ldz,*) ! ===================================================================== @@ -25474,7 +25476,7 @@ module stdlib_linalg_lapack_w character :: order integer(ilp) :: i, iinfo, imax, indd, inde, indee, indibl, indisp, indiwk, indrwk, & indtau, indwrk, iscale, itmp1, j, jj, llwork, lwkmin, lwkopt, nb, nsplit - real(qp) :: abstll, anrm, bignum, eps, rmax, rmin, safmin, sigma, smlnum, tmp1, vll, & + real(${ck}$) :: abstll, anrm, bignum, eps, rmax, rmin, safmin, sigma, smlnum, tmp1, vll, & vuu ! Intrinsic Functions intrinsic :: real,max,min,sqrt @@ -25540,19 +25542,19 @@ module stdlib_linalg_lapack_w if( n==1 ) then if( alleig .or. indeig ) then m = 1 - w( 1 ) = real( a( 1, 1 ),KIND=qp) + w( 1 ) = real( a( 1, 1 ),KIND=${ck}$) else if( valeig ) then - if( vl=real( a( 1, 1 ),KIND=qp) )then + if( vl=real( a( 1, 1 ),KIND=${ck}$) )then m = 1 - w( 1 ) = real( a( 1, 1 ),KIND=qp) + w( 1 ) = real( a( 1, 1 ),KIND=${ck}$) end if end if if( wantz )z( 1, 1 ) = cone return end if ! get machine constants. - safmin = stdlib_qlamch( 'SAFE MINIMUM' ) - eps = stdlib_qlamch( 'PRECISION' ) + safmin = stdlib_${c2ri(ci)}$lamch( 'SAFE MINIMUM' ) + eps = stdlib_${c2ri(ci)}$lamch( 'PRECISION' ) smlnum = safmin / eps bignum = one / smlnum rmin = sqrt( smlnum ) @@ -25564,7 +25566,7 @@ module stdlib_linalg_lapack_w vll = vl vuu = vu end if - anrm = stdlib_wlanhe( 'M', uplo, n, a, lda, rwork ) + anrm = stdlib_${ci}$lanhe( 'M', uplo, n, a, lda, rwork ) if( anrm>zero .and. anrm0 )abstll = abstol*sigma @@ -25588,18 +25590,18 @@ module stdlib_linalg_lapack_w vuu = vu*sigma end if end if - ! call stdlib_whetrd to reduce hermitian matrix to tridiagonal form. + ! call stdlib_${ci}$hetrd to reduce hermitian matrix to tridiagonal form. indd = 1 inde = indd + n indrwk = inde + n indtau = 1 indwrk = indtau + n llwork = lwork - indwrk + 1 - call stdlib_whetrd( uplo, n, a, lda, rwork( indd ), rwork( inde ),work( indtau ), work(& + call stdlib_${ci}$hetrd( uplo, n, a, lda, rwork( indd ), rwork( inde ),work( indtau ), work(& indwrk ), llwork, iinfo ) ! if all eigenvalues are desired and abstol is less than or equal to - ! zero, then call stdlib_qsterf or stdlib_wungtr and stdlib_wsteqr. if this fails for - ! some eigenvalue, then try stdlib_qstebz. + ! zero, then call stdlib_${c2ri(ci)}$sterf or stdlib_${ci}$ungtr and stdlib_${ci}$steqr. if this fails for + ! some eigenvalue, then try stdlib_${c2ri(ci)}$stebz. test = .false. if( indeig ) then if( il==1 .and. iu==n ) then @@ -25607,17 +25609,17 @@ module stdlib_linalg_lapack_w end if end if if( ( alleig .or. test ) .and. ( abstol<=zero ) ) then - call stdlib_qcopy( n, rwork( indd ), 1, w, 1 ) + call stdlib_${c2ri(ci)}$copy( n, rwork( indd ), 1, w, 1 ) indee = indrwk + 2*n if( .not.wantz ) then - call stdlib_qcopy( n-1, rwork( inde ), 1, rwork( indee ), 1 ) - call stdlib_qsterf( n, w, rwork( indee ), info ) + call stdlib_${c2ri(ci)}$copy( n-1, rwork( inde ), 1, rwork( indee ), 1 ) + call stdlib_${c2ri(ci)}$sterf( n, w, rwork( indee ), info ) else - call stdlib_wlacpy( 'A', n, n, a, lda, z, ldz ) - call stdlib_wungtr( uplo, n, z, ldz, work( indtau ),work( indwrk ), llwork, & + call stdlib_${ci}$lacpy( 'A', n, n, a, lda, z, ldz ) + call stdlib_${ci}$ungtr( uplo, n, z, ldz, work( indtau ),work( indwrk ), llwork, & iinfo ) - call stdlib_qcopy( n-1, rwork( inde ), 1, rwork( indee ), 1 ) - call stdlib_wsteqr( jobz, n, w, rwork( indee ), z, ldz,rwork( indrwk ), info ) + call stdlib_${c2ri(ci)}$copy( n-1, rwork( inde ), 1, rwork( indee ), 1 ) + call stdlib_${ci}$steqr( jobz, n, w, rwork( indee ), z, ldz,rwork( indrwk ), info ) if( info==0 ) then do i = 1, n @@ -25631,7 +25633,7 @@ module stdlib_linalg_lapack_w end if info = 0 end if - ! otherwise, call stdlib_qstebz and, if eigenvectors are desired, stdlib_wstein. + ! otherwise, call stdlib_${c2ri(ci)}$stebz and, if eigenvectors are desired, stdlib_${ci}$stein. if( wantz ) then order = 'B' else @@ -25640,15 +25642,15 @@ module stdlib_linalg_lapack_w indibl = 1 indisp = indibl + n indiwk = indisp + n - call stdlib_qstebz( range, order, n, vll, vuu, il, iu, abstll,rwork( indd ), rwork( & + call stdlib_${c2ri(ci)}$stebz( range, order, n, vll, vuu, il, iu, abstll,rwork( indd ), rwork( & inde ), m, nsplit, w,iwork( indibl ), iwork( indisp ), rwork( indrwk ),iwork( indiwk ),& info ) if( wantz ) then - call stdlib_wstein( n, rwork( indd ), rwork( inde ), m, w,iwork( indibl ), iwork( & + call stdlib_${ci}$stein( n, rwork( indd ), rwork( inde ), m, w,iwork( indibl ), iwork( & indisp ), z, ldz,rwork( indrwk ), iwork( indiwk ), ifail, info ) ! apply unitary matrix used in reduction to tridiagonal - ! form to eigenvectors returned by stdlib_wstein. - call stdlib_wunmtr( 'L', uplo, 'N', n, m, a, lda, work( indtau ), z,ldz, work( & + ! form to eigenvectors returned by stdlib_${ci}$stein. + call stdlib_${ci}$unmtr( 'L', uplo, 'N', n, m, a, lda, work( indtau ), z,ldz, work( & indwrk ), llwork, iinfo ) end if ! if matrix was scaled, then rescale eigenvalues appropriately. @@ -25659,7 +25661,7 @@ module stdlib_linalg_lapack_w else imax = info - 1 end if - call stdlib_qscal( imax, one / sigma, w, 1 ) + call stdlib_${c2ri(ci)}$scal( imax, one / sigma, w, 1 ) end if ! if eigenvalues are not in order, then sort them, along with ! eigenvectors. @@ -25679,7 +25681,7 @@ module stdlib_linalg_lapack_w iwork( indibl+i-1 ) = iwork( indibl+j-1 ) w( j ) = tmp1 iwork( indibl+j-1 ) = itmp1 - call stdlib_wswap( n, z( 1, i ), 1, z( 1, j ), 1 ) + call stdlib_${ci}$swap( n, z( 1, i ), 1, z( 1, j ), 1 ) if( info/=0 ) then itmp1 = ifail( i ) ifail( i ) = ifail( j ) @@ -25691,10 +25693,10 @@ module stdlib_linalg_lapack_w ! set work(1) to optimal complex workspace size. work( 1 ) = lwkopt return - end subroutine stdlib_wheevx + end subroutine stdlib_${ci}$heevx - pure subroutine stdlib_whegs2( itype, uplo, n, a, lda, b, ldb, info ) + pure subroutine stdlib_${ci}$hegs2( itype, uplo, n, a, lda, b, ldb, info ) !! ZHEGS2: reduces a complex Hermitian-definite generalized !! eigenproblem to standard form. !! If ITYPE = 1, the problem is A*x = lambda*B*x, @@ -25710,15 +25712,15 @@ module stdlib_linalg_lapack_w integer(ilp), intent(out) :: info integer(ilp), intent(in) :: itype, lda, ldb, n ! Array Arguments - complex(qp), intent(inout) :: a(lda,*), b(ldb,*) + complex(${ck}$), intent(inout) :: a(lda,*), b(ldb,*) ! ===================================================================== ! Local Scalars logical(lk) :: upper integer(ilp) :: k - real(qp) :: akk, bkk - complex(qp) :: ct + real(${ck}$) :: akk, bkk + complex(${ck}$) :: ct ! Intrinsic Functions intrinsic :: max ! Executable Statements @@ -25745,41 +25747,41 @@ module stdlib_linalg_lapack_w ! compute inv(u**h)*a*inv(u) do k = 1, n ! update the upper triangle of a(k:n,k:n) - akk = real( a( k, k ),KIND=qp) - bkk = real( b( k, k ),KIND=qp) + akk = real( a( k, k ),KIND=${ck}$) + bkk = real( b( k, k ),KIND=${ck}$) akk = akk / bkk**2 a( k, k ) = akk if( k=n ) then ! use unblocked code - call stdlib_whegs2( itype, uplo, n, a, lda, b, ldb, info ) + call stdlib_${ci}$hegs2( itype, uplo, n, a, lda, b, ldb, info ) else ! use blocked code if( itype==1 ) then @@ -25886,18 +25888,18 @@ module stdlib_linalg_lapack_w do k = 1, n, nb kb = min( n-k+1, nb ) ! update the upper triangle of a(k:n,k:n) - call stdlib_whegs2( itype, uplo, kb, a( k, k ), lda,b( k, k ), ldb, info ) + call stdlib_${ci}$hegs2( itype, uplo, kb, a( k, k ), lda,b( k, k ), ldb, info ) if( k+kb<=n ) then - call stdlib_wtrsm( 'LEFT', uplo, 'CONJUGATE TRANSPOSE','NON-UNIT', kb, & + call stdlib_${ci}$trsm( 'LEFT', uplo, 'CONJUGATE TRANSPOSE','NON-UNIT', kb, & n-k-kb+1, cone,b( k, k ), ldb, a( k, k+kb ), lda ) - call stdlib_whemm( 'LEFT', uplo, kb, n-k-kb+1, -chalf,a( k, k ), lda, b(& + call stdlib_${ci}$hemm( 'LEFT', uplo, kb, n-k-kb+1, -chalf,a( k, k ), lda, b(& k, k+kb ), ldb,cone, a( k, k+kb ), lda ) - call stdlib_wher2k( uplo, 'CONJUGATE TRANSPOSE', n-k-kb+1,kb, -cone, a( & + call stdlib_${ci}$her2k( uplo, 'CONJUGATE TRANSPOSE', n-k-kb+1,kb, -cone, a( & k, k+kb ), lda,b( k, k+kb ), ldb, one,a( k+kb, k+kb ), lda ) - call stdlib_whemm( 'LEFT', uplo, kb, n-k-kb+1, -chalf,a( k, k ), lda, b(& + call stdlib_${ci}$hemm( 'LEFT', uplo, kb, n-k-kb+1, -chalf,a( k, k ), lda, b(& k, k+kb ), ldb,cone, a( k, k+kb ), lda ) - call stdlib_wtrsm( 'RIGHT', uplo, 'NO TRANSPOSE','NON-UNIT', kb, n-k-kb+& + call stdlib_${ci}$trsm( 'RIGHT', uplo, 'NO TRANSPOSE','NON-UNIT', kb, n-k-kb+& 1, cone,b( k+kb, k+kb ), ldb, a( k, k+kb ),lda ) end if end do @@ -25906,18 +25908,18 @@ module stdlib_linalg_lapack_w do k = 1, n, nb kb = min( n-k+1, nb ) ! update the lower triangle of a(k:n,k:n) - call stdlib_whegs2( itype, uplo, kb, a( k, k ), lda,b( k, k ), ldb, info ) + call stdlib_${ci}$hegs2( itype, uplo, kb, a( k, k ), lda,b( k, k ), ldb, info ) if( k+kb<=n ) then - call stdlib_wtrsm( 'RIGHT', uplo, 'CONJUGATE TRANSPOSE','NON-UNIT', n-k-& + call stdlib_${ci}$trsm( 'RIGHT', uplo, 'CONJUGATE TRANSPOSE','NON-UNIT', n-k-& kb+1, kb, cone,b( k, k ), ldb, a( k+kb, k ), lda ) - call stdlib_whemm( 'RIGHT', uplo, n-k-kb+1, kb, -chalf,a( k, k ), lda, & + call stdlib_${ci}$hemm( 'RIGHT', uplo, n-k-kb+1, kb, -chalf,a( k, k ), lda, & b( k+kb, k ), ldb,cone, a( k+kb, k ), lda ) - call stdlib_wher2k( uplo, 'NO TRANSPOSE', n-k-kb+1, kb,-cone, a( k+kb, & + call stdlib_${ci}$her2k( uplo, 'NO TRANSPOSE', n-k-kb+1, kb,-cone, a( k+kb, & k ), lda,b( k+kb, k ), ldb, one,a( k+kb, k+kb ), lda ) - call stdlib_whemm( 'RIGHT', uplo, n-k-kb+1, kb, -chalf,a( k, k ), lda, & + call stdlib_${ci}$hemm( 'RIGHT', uplo, n-k-kb+1, kb, -chalf,a( k, k ), lda, & b( k+kb, k ), ldb,cone, a( k+kb, k ), lda ) - call stdlib_wtrsm( 'LEFT', uplo, 'NO TRANSPOSE','NON-UNIT', n-k-kb+1, & + call stdlib_${ci}$trsm( 'LEFT', uplo, 'NO TRANSPOSE','NON-UNIT', n-k-kb+1, & kb, cone,b( k+kb, k+kb ), ldb, a( k+kb, k ),lda ) end if end do @@ -25928,17 +25930,17 @@ module stdlib_linalg_lapack_w do k = 1, n, nb kb = min( n-k+1, nb ) ! update the upper triangle of a(1:k+kb-1,1:k+kb-1) - call stdlib_wtrmm( 'LEFT', uplo, 'NO TRANSPOSE', 'NON-UNIT',k-1, kb, cone, & + call stdlib_${ci}$trmm( 'LEFT', uplo, 'NO TRANSPOSE', 'NON-UNIT',k-1, kb, cone, & b, ldb, a( 1, k ), lda ) - call stdlib_whemm( 'RIGHT', uplo, k-1, kb, chalf, a( k, k ),lda, b( 1, k ),& + call stdlib_${ci}$hemm( 'RIGHT', uplo, k-1, kb, chalf, a( k, k ),lda, b( 1, k ),& ldb, cone, a( 1, k ),lda ) - call stdlib_wher2k( uplo, 'NO TRANSPOSE', k-1, kb, cone,a( 1, k ), lda, b( & + call stdlib_${ci}$her2k( uplo, 'NO TRANSPOSE', k-1, kb, cone,a( 1, k ), lda, b( & 1, k ), ldb, one, a,lda ) - call stdlib_whemm( 'RIGHT', uplo, k-1, kb, chalf, a( k, k ),lda, b( 1, k ),& + call stdlib_${ci}$hemm( 'RIGHT', uplo, k-1, kb, chalf, a( k, k ),lda, b( 1, k ),& ldb, cone, a( 1, k ),lda ) - call stdlib_wtrmm( 'RIGHT', uplo, 'CONJUGATE TRANSPOSE','NON-UNIT', k-1, & + call stdlib_${ci}$trmm( 'RIGHT', uplo, 'CONJUGATE TRANSPOSE','NON-UNIT', k-1, & kb, cone, b( k, k ), ldb,a( 1, k ), lda ) - call stdlib_whegs2( itype, uplo, kb, a( k, k ), lda,b( k, k ), ldb, info ) + call stdlib_${ci}$hegs2( itype, uplo, kb, a( k, k ), lda,b( k, k ), ldb, info ) end do else @@ -25946,27 +25948,27 @@ module stdlib_linalg_lapack_w do k = 1, n, nb kb = min( n-k+1, nb ) ! update the lower triangle of a(1:k+kb-1,1:k+kb-1) - call stdlib_wtrmm( 'RIGHT', uplo, 'NO TRANSPOSE', 'NON-UNIT',kb, k-1, cone,& + call stdlib_${ci}$trmm( 'RIGHT', uplo, 'NO TRANSPOSE', 'NON-UNIT',kb, k-1, cone,& b, ldb, a( k, 1 ), lda ) - call stdlib_whemm( 'LEFT', uplo, kb, k-1, chalf, a( k, k ),lda, b( k, 1 ), & + call stdlib_${ci}$hemm( 'LEFT', uplo, kb, k-1, chalf, a( k, k ),lda, b( k, 1 ), & ldb, cone, a( k, 1 ),lda ) - call stdlib_wher2k( uplo, 'CONJUGATE TRANSPOSE', k-1, kb,cone, a( k, 1 ), & + call stdlib_${ci}$her2k( uplo, 'CONJUGATE TRANSPOSE', k-1, kb,cone, a( k, 1 ), & lda, b( k, 1 ), ldb,one, a, lda ) - call stdlib_whemm( 'LEFT', uplo, kb, k-1, chalf, a( k, k ),lda, b( k, 1 ), & + call stdlib_${ci}$hemm( 'LEFT', uplo, kb, k-1, chalf, a( k, k ),lda, b( k, 1 ), & ldb, cone, a( k, 1 ),lda ) - call stdlib_wtrmm( 'LEFT', uplo, 'CONJUGATE TRANSPOSE','NON-UNIT', kb, k-1,& + call stdlib_${ci}$trmm( 'LEFT', uplo, 'CONJUGATE TRANSPOSE','NON-UNIT', kb, k-1,& cone, b( k, k ), ldb,a( k, 1 ), lda ) - call stdlib_whegs2( itype, uplo, kb, a( k, k ), lda,b( k, k ), ldb, info ) + call stdlib_${ci}$hegs2( itype, uplo, kb, a( k, k ), lda,b( k, k ), ldb, info ) end do end if end if end if return - end subroutine stdlib_whegst + end subroutine stdlib_${ci}$hegst - subroutine stdlib_whegv( itype, jobz, uplo, n, a, lda, b, ldb, w, work,lwork, rwork, info ) + subroutine stdlib_${ci}$hegv( itype, jobz, uplo, n, a, lda, b, ldb, w, work,lwork, rwork, info ) !! ZHEGV: computes all the eigenvalues, and optionally, the eigenvectors !! of a complex generalized Hermitian-definite eigenproblem, of the form !! A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. @@ -25981,9 +25983,9 @@ module stdlib_linalg_lapack_w integer(ilp), intent(out) :: info integer(ilp), intent(in) :: itype, lda, ldb, lwork, n ! Array Arguments - real(qp), intent(out) :: rwork(*), w(*) - complex(qp), intent(inout) :: a(lda,*), b(ldb,*) - complex(qp), intent(out) :: work(*) + real(${ck}$), intent(out) :: rwork(*), w(*) + complex(${ck}$), intent(inout) :: a(lda,*), b(ldb,*) + complex(${ck}$), intent(out) :: work(*) ! ===================================================================== ! Local Scalars @@ -26028,14 +26030,14 @@ module stdlib_linalg_lapack_w ! quick return if possible if( n==0 )return ! form a cholesky factorization of b. - call stdlib_wpotrf( uplo, n, b, ldb, info ) + call stdlib_${ci}$potrf( uplo, n, b, ldb, info ) if( info/=0 ) then info = n + info return end if ! transform problem to standard eigenvalue problem and solve. - call stdlib_whegst( itype, uplo, n, a, lda, b, ldb, info ) - call stdlib_wheev( jobz, uplo, n, a, lda, w, work, lwork, rwork, info ) + call stdlib_${ci}$hegst( itype, uplo, n, a, lda, b, ldb, info ) + call stdlib_${ci}$heev( jobz, uplo, n, a, lda, w, work, lwork, rwork, info ) if( wantz ) then ! backtransform eigenvectors to the original problem. neig = n @@ -26048,7 +26050,7 @@ module stdlib_linalg_lapack_w else trans = 'C' end if - call stdlib_wtrsm( 'LEFT', uplo, trans, 'NON-UNIT', n, neig, cone,b, ldb, a, lda & + call stdlib_${ci}$trsm( 'LEFT', uplo, trans, 'NON-UNIT', n, neig, cone,b, ldb, a, lda & ) else if( itype==3 ) then ! for b*a*x=(lambda)*x; @@ -26058,16 +26060,16 @@ module stdlib_linalg_lapack_w else trans = 'N' end if - call stdlib_wtrmm( 'LEFT', uplo, trans, 'NON-UNIT', n, neig, cone,b, ldb, a, lda & + call stdlib_${ci}$trmm( 'LEFT', uplo, trans, 'NON-UNIT', n, neig, cone,b, ldb, a, lda & ) end if end if work( 1 ) = lwkopt return - end subroutine stdlib_whegv + end subroutine stdlib_${ci}$hegv - subroutine stdlib_whegvd( itype, jobz, uplo, n, a, lda, b, ldb, w, work,lwork, rwork, lrwork,& + subroutine stdlib_${ci}$hegvd( itype, jobz, uplo, n, a, lda, b, ldb, w, work,lwork, rwork, lrwork,& !! ZHEGVD: computes all the eigenvalues, and optionally, the eigenvectors !! of a complex generalized Hermitian-definite eigenproblem, of the form !! A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A and @@ -26089,9 +26091,9 @@ module stdlib_linalg_lapack_w integer(ilp), intent(in) :: itype, lda, ldb, liwork, lrwork, lwork, n ! Array Arguments integer(ilp), intent(out) :: iwork(*) - real(qp), intent(out) :: rwork(*), w(*) - complex(qp), intent(inout) :: a(lda,*), b(ldb,*) - complex(qp), intent(out) :: work(*) + real(${ck}$), intent(out) :: rwork(*), w(*) + complex(${ck}$), intent(inout) :: a(lda,*), b(ldb,*) + complex(${ck}$), intent(out) :: work(*) ! ===================================================================== ! Local Scalars @@ -26156,18 +26158,18 @@ module stdlib_linalg_lapack_w ! quick return if possible if( n==0 )return ! form a cholesky factorization of b. - call stdlib_wpotrf( uplo, n, b, ldb, info ) + call stdlib_${ci}$potrf( uplo, n, b, ldb, info ) if( info/=0 ) then info = n + info return end if ! transform problem to standard eigenvalue problem and solve. - call stdlib_whegst( itype, uplo, n, a, lda, b, ldb, info ) - call stdlib_wheevd( jobz, uplo, n, a, lda, w, work, lwork, rwork, lrwork,iwork, liwork,& + call stdlib_${ci}$hegst( itype, uplo, n, a, lda, b, ldb, info ) + call stdlib_${ci}$heevd( jobz, uplo, n, a, lda, w, work, lwork, rwork, lrwork,iwork, liwork,& info ) - lopt = max( real( lopt,KIND=qp), real( work( 1 ),KIND=qp) ) - lropt = max( real( lropt,KIND=qp), real( rwork( 1 ),KIND=qp) ) - liopt = max( real( liopt,KIND=qp), real( iwork( 1 ),KIND=qp) ) + lopt = max( real( lopt,KIND=${ck}$), real( work( 1 ),KIND=${ck}$) ) + lropt = max( real( lropt,KIND=${ck}$), real( rwork( 1 ),KIND=${ck}$) ) + liopt = max( real( liopt,KIND=${ck}$), real( iwork( 1 ),KIND=${ck}$) ) if( wantz .and. info==0 ) then ! backtransform eigenvectors to the original problem. if( itype==1 .or. itype==2 ) then @@ -26178,7 +26180,7 @@ module stdlib_linalg_lapack_w else trans = 'C' end if - call stdlib_wtrsm( 'LEFT', uplo, trans, 'NON-UNIT', n, n, cone,b, ldb, a, lda ) + call stdlib_${ci}$trsm( 'LEFT', uplo, trans, 'NON-UNIT', n, n, cone,b, ldb, a, lda ) else if( itype==3 ) then ! for b*a*x=(lambda)*x; @@ -26188,7 +26190,7 @@ module stdlib_linalg_lapack_w else trans = 'N' end if - call stdlib_wtrmm( 'LEFT', uplo, trans, 'NON-UNIT', n, n, cone,b, ldb, a, lda ) + call stdlib_${ci}$trmm( 'LEFT', uplo, trans, 'NON-UNIT', n, n, cone,b, ldb, a, lda ) end if end if @@ -26196,10 +26198,10 @@ module stdlib_linalg_lapack_w rwork( 1 ) = lropt iwork( 1 ) = liopt return - end subroutine stdlib_whegvd + end subroutine stdlib_${ci}$hegvd - subroutine stdlib_whegvx( itype, jobz, range, uplo, n, a, lda, b, ldb,vl, vu, il, iu, abstol,& + subroutine stdlib_${ci}$hegvx( itype, jobz, range, uplo, n, a, lda, b, ldb,vl, vu, il, iu, abstol,& !! ZHEGVX: computes selected eigenvalues, and optionally, eigenvectors !! of a complex generalized Hermitian-definite eigenproblem, of the form !! A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A and @@ -26214,12 +26216,12 @@ module stdlib_linalg_lapack_w character, intent(in) :: jobz, range, uplo integer(ilp), intent(in) :: il, itype, iu, lda, ldb, ldz, lwork, n integer(ilp), intent(out) :: info, m - real(qp), intent(in) :: abstol, vl, vu + real(${ck}$), intent(in) :: abstol, vl, vu ! Array Arguments integer(ilp), intent(out) :: ifail(*), iwork(*) - real(qp), intent(out) :: rwork(*), w(*) - complex(qp), intent(inout) :: a(lda,*), b(ldb,*) - complex(qp), intent(out) :: work(*), z(ldz,*) + real(${ck}$), intent(out) :: rwork(*), w(*) + complex(${ck}$), intent(inout) :: a(lda,*), b(ldb,*) + complex(${ck}$), intent(out) :: work(*), z(ldz,*) ! ===================================================================== ! Local Scalars @@ -26287,14 +26289,14 @@ module stdlib_linalg_lapack_w return end if ! form a cholesky factorization of b. - call stdlib_wpotrf( uplo, n, b, ldb, info ) + call stdlib_${ci}$potrf( uplo, n, b, ldb, info ) if( info/=0 ) then info = n + info return end if ! transform problem to standard eigenvalue problem and solve. - call stdlib_whegst( itype, uplo, n, a, lda, b, ldb, info ) - call stdlib_wheevx( jobz, range, uplo, n, a, lda, vl, vu, il, iu, abstol,m, w, z, ldz, & + call stdlib_${ci}$hegst( itype, uplo, n, a, lda, b, ldb, info ) + call stdlib_${ci}$heevx( jobz, range, uplo, n, a, lda, vl, vu, il, iu, abstol,m, w, z, ldz, & work, lwork, rwork, iwork, ifail,info ) if( wantz ) then ! backtransform eigenvectors to the original problem. @@ -26307,7 +26309,7 @@ module stdlib_linalg_lapack_w else trans = 'C' end if - call stdlib_wtrsm( 'LEFT', uplo, trans, 'NON-UNIT', n, m, cone, b,ldb, z, ldz ) + call stdlib_${ci}$trsm( 'LEFT', uplo, trans, 'NON-UNIT', n, m, cone, b,ldb, z, ldz ) else if( itype==3 ) then ! for b*a*x=(lambda)*x; @@ -26317,17 +26319,17 @@ module stdlib_linalg_lapack_w else trans = 'N' end if - call stdlib_wtrmm( 'LEFT', uplo, trans, 'NON-UNIT', n, m, cone, b,ldb, z, ldz ) + call stdlib_${ci}$trmm( 'LEFT', uplo, trans, 'NON-UNIT', n, m, cone, b,ldb, z, ldz ) end if end if ! set work(1) to optimal complex workspace size. work( 1 ) = lwkopt return - end subroutine stdlib_whegvx + end subroutine stdlib_${ci}$hegvx - pure subroutine stdlib_wherfs( uplo, n, nrhs, a, lda, af, ldaf, ipiv, b, ldb,x, ldx, ferr, & + pure subroutine stdlib_${ci}$herfs( uplo, n, nrhs, a, lda, af, ldaf, ipiv, b, ldb,x, ldx, ferr, & !! ZHERFS: improves the computed solution to a system of linear !! equations when the coefficient matrix is Hermitian indefinite, and !! provides error bounds and backward error estimates for the solution. @@ -26341,10 +26343,10 @@ module stdlib_linalg_lapack_w integer(ilp), intent(in) :: lda, ldaf, ldb, ldx, n, nrhs ! Array Arguments integer(ilp), intent(in) :: ipiv(*) - real(qp), intent(out) :: berr(*), ferr(*), rwork(*) - complex(qp), intent(in) :: a(lda,*), af(ldaf,*), b(ldb,*) - complex(qp), intent(out) :: work(*) - complex(qp), intent(inout) :: x(ldx,*) + real(${ck}$), intent(out) :: berr(*), ferr(*), rwork(*) + complex(${ck}$), intent(in) :: a(lda,*), af(ldaf,*), b(ldb,*) + complex(${ck}$), intent(out) :: work(*) + complex(${ck}$), intent(inout) :: x(ldx,*) ! ===================================================================== ! Parameters integer(ilp), parameter :: itmax = 5 @@ -26356,16 +26358,16 @@ module stdlib_linalg_lapack_w ! Local Scalars logical(lk) :: upper integer(ilp) :: count, i, j, k, kase, nz - real(qp) :: eps, lstres, s, safe1, safe2, safmin, xk - complex(qp) :: zdum + real(${ck}$) :: eps, lstres, s, safe1, safe2, safmin, xk + complex(${ck}$) :: zdum ! Local Arrays integer(ilp) :: isave(3) ! Intrinsic Functions intrinsic :: abs,real,aimag,max ! Statement Functions - real(qp) :: cabs1 + real(${ck}$) :: cabs1 ! Statement Function Definitions - cabs1( zdum ) = abs( real( zdum,KIND=qp) ) + abs( aimag( zdum ) ) + cabs1( zdum ) = abs( real( zdum,KIND=${ck}$) ) + abs( aimag( zdum ) ) ! Executable Statements ! test the input parameters. info = 0 @@ -26399,8 +26401,8 @@ module stdlib_linalg_lapack_w end if ! nz = maximum number of nonzero elements in each row of a, plus 1 nz = n + 1 - eps = stdlib_qlamch( 'EPSILON' ) - safmin = stdlib_qlamch( 'SAFE MINIMUM' ) + eps = stdlib_${c2ri(ci)}$lamch( 'EPSILON' ) + safmin = stdlib_${c2ri(ci)}$lamch( 'SAFE MINIMUM' ) safe1 = nz*safmin safe2 = safe1 / eps ! do for each right hand side @@ -26410,8 +26412,8 @@ module stdlib_linalg_lapack_w 20 continue ! loop until stopping criterion is satisfied. ! compute residual r = b - a * x - call stdlib_wcopy( n, b( 1, j ), 1, work, 1 ) - call stdlib_whemv( uplo, n, -cone, a, lda, x( 1, j ), 1, cone, work, 1 ) + call stdlib_${ci}$copy( n, b( 1, j ), 1, work, 1 ) + call stdlib_${ci}$hemv( uplo, n, -cone, a, lda, x( 1, j ), 1, cone, work, 1 ) ! 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 @@ -26430,13 +26432,13 @@ module stdlib_linalg_lapack_w rwork( i ) = rwork( i ) + cabs1( a( i, k ) )*xk s = s + cabs1( a( i, k ) )*cabs1( x( i, j ) ) end do - rwork( k ) = rwork( k ) + abs( real( a( k, k ),KIND=qp) )*xk + s + rwork( k ) = rwork( k ) + abs( real( a( k, k ),KIND=${ck}$) )*xk + s end do else do k = 1, n s = zero xk = cabs1( x( k, j ) ) - rwork( k ) = rwork( k ) + abs( real( a( k, k ),KIND=qp) )*xk + rwork( k ) = rwork( k ) + abs( real( a( k, k ),KIND=${ck}$) )*xk do i = k + 1, n rwork( i ) = rwork( i ) + cabs1( a( i, k ) )*xk s = s + cabs1( a( i, k ) )*cabs1( x( i, j ) ) @@ -26460,8 +26462,8 @@ module stdlib_linalg_lapack_w ! 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_whetrs( uplo, n, 1, af, ldaf, ipiv, work, n, info ) - call stdlib_waxpy( n, cone, work, 1, x( 1, j ), 1 ) + call stdlib_${ci}$hetrs( uplo, n, 1, af, ldaf, ipiv, work, n, info ) + call stdlib_${ci}$axpy( n, cone, work, 1, x( 1, j ), 1 ) lstres = berr( j ) count = count + 1 go to 20 @@ -26480,7 +26482,7 @@ module stdlib_linalg_lapack_w ! 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_wlacn2 to estimate the infinity-norm of the matrix + ! 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 @@ -26492,11 +26494,11 @@ module stdlib_linalg_lapack_w end do kase = 0 100 continue - call stdlib_wlacn2( n, work( n+1 ), work, ferr( j ), kase, isave ) + call stdlib_${ci}$lacn2( n, work( n+1 ), work, ferr( j ), kase, isave ) if( kase/=0 ) then if( kase==1 ) then ! multiply by diag(w)*inv(a**h). - call stdlib_whetrs( uplo, n, 1, af, ldaf, ipiv, work, n, info ) + call stdlib_${ci}$hetrs( uplo, n, 1, af, ldaf, ipiv, work, n, info ) do i = 1, n work( i ) = rwork( i )*work( i ) end do @@ -26505,7 +26507,7 @@ module stdlib_linalg_lapack_w do i = 1, n work( i ) = rwork( i )*work( i ) end do - call stdlib_whetrs( uplo, n, 1, af, ldaf, ipiv, work, n, info ) + call stdlib_${ci}$hetrs( uplo, n, 1, af, ldaf, ipiv, work, n, info ) end if go to 100 end if @@ -26517,10 +26519,10 @@ module stdlib_linalg_lapack_w if( lstres/=zero )ferr( j ) = ferr( j ) / lstres end do loop_140 return - end subroutine stdlib_wherfs + end subroutine stdlib_${ci}$herfs - pure subroutine stdlib_whesv( uplo, n, nrhs, a, lda, ipiv, b, ldb, work,lwork, info ) + pure subroutine stdlib_${ci}$hesv( uplo, n, nrhs, a, lda, ipiv, b, ldb, work,lwork, info ) !! ZHESV: computes the solution to a complex system of linear equations !! A * X = B, !! where A is an N-by-N Hermitian matrix and X and B are N-by-NRHS @@ -26541,8 +26543,8 @@ module stdlib_linalg_lapack_w integer(ilp), intent(in) :: lda, ldb, lwork, n, nrhs ! Array Arguments integer(ilp), intent(out) :: ipiv(*) - complex(qp), intent(inout) :: a(lda,*), b(ldb,*) - complex(qp), intent(out) :: work(*) + complex(${ck}$), intent(inout) :: a(lda,*), b(ldb,*) + complex(${ck}$), intent(out) :: work(*) ! ===================================================================== ! Local Scalars logical(lk) :: lquery @@ -26582,23 +26584,23 @@ module stdlib_linalg_lapack_w return end if ! compute the factorization a = u*d*u**h or a = l*d*l**h. - call stdlib_whetrf( uplo, n, a, lda, ipiv, work, lwork, info ) + call stdlib_${ci}$hetrf( uplo, n, a, lda, ipiv, work, lwork, info ) if( info==0 ) then ! solve the system a*x = b, overwriting b with x. if ( lwork0 )then rcond = zero @@ -26906,24 +26908,24 @@ module stdlib_linalg_lapack_w end if end if ! compute the norm of the matrix a. - anorm = stdlib_wlanhe( 'I', uplo, n, a, lda, rwork ) + anorm = stdlib_${ci}$lanhe( 'I', uplo, n, a, lda, rwork ) ! compute the reciprocal of the condition number of a. - call stdlib_whecon( uplo, n, af, ldaf, ipiv, anorm, rcond, work, info ) + call stdlib_${ci}$hecon( uplo, n, af, ldaf, ipiv, anorm, rcond, work, info ) ! compute the solution vectors x. - call stdlib_wlacpy( 'FULL', n, nrhs, b, ldb, x, ldx ) - call stdlib_whetrs( uplo, n, nrhs, af, ldaf, ipiv, x, ldx, info ) + call stdlib_${ci}$lacpy( 'FULL', n, nrhs, b, ldb, x, ldx ) + call stdlib_${ci}$hetrs( uplo, n, nrhs, af, ldaf, ipiv, x, ldx, info ) ! use iterative refinement to improve the computed solutions and ! compute error bounds and backward error estimates for them. - call stdlib_wherfs( uplo, n, nrhs, a, lda, af, ldaf, ipiv, b, ldb, x,ldx, ferr, berr, & + call stdlib_${ci}$herfs( uplo, n, nrhs, a, lda, af, ldaf, ipiv, b, ldb, x,ldx, ferr, berr, & work, rwork, info ) ! set info = n+1 if the matrix is singular to working precision. - if( rcond1 ) then - imax = stdlib_iwamax( k-1, a( 1, k ), 1 ) + imax = stdlib_i${ci}$amax( k-1, a( 1, k ), 1 ) colmax = cabs1( a( imax, k ) ) else colmax = zero end if - if( (max( absakk, colmax )==zero) .or. stdlib_qisnan(absakk) ) then + if( (max( absakk, colmax )==zero) .or. stdlib_${c2ri(ci)}$isnan(absakk) ) then ! column k is zero or underflow, or contains a nan: ! set info and continue if( info==0 )info = k kp = k - a( k, k ) = real( a( k, k ),KIND=qp) + a( k, k ) = real( a( k, k ),KIND=${ck}$) else ! ============================================================ ! test for interchange @@ -27187,16 +27189,16 @@ module stdlib_linalg_lapack_w ! jmax is the column-index of the largest off-diagonal ! element in row imax, and rowmax is its absolute value. ! determine only rowmax. - jmax = imax + stdlib_iwamax( k-imax, a( imax, imax+1 ), lda ) + jmax = imax + stdlib_i${ci}$amax( k-imax, a( imax, imax+1 ), lda ) rowmax = cabs1( a( imax, jmax ) ) if( imax>1 ) then - jmax = stdlib_iwamax( imax-1, a( 1, imax ), 1 ) + jmax = stdlib_i${ci}$amax( imax-1, a( 1, imax ), 1 ) rowmax = max( rowmax, cabs1( a( jmax, imax ) ) ) end if if( absakk>=alpha*colmax*( colmax / rowmax ) ) then ! no interchange, use 1-by-1 pivot block kp = k - else if( abs( real( a( imax, imax ),KIND=qp) )>=alpha*rowmax )then + else if( abs( real( a( imax, imax ),KIND=${ck}$) )>=alpha*rowmax )then ! interchange rows and columns k and imax, use 1-by-1 ! pivot block kp = imax @@ -27212,25 +27214,25 @@ module stdlib_linalg_lapack_w if( kp/=kk ) then ! interchange rows and columns kk and kp in the leading ! submatrix a(1:k,1:k) - call stdlib_wswap( kp-1, a( 1, kk ), 1, a( 1, kp ), 1 ) + call stdlib_${ci}$swap( kp-1, a( 1, kk ), 1, a( 1, kp ), 1 ) do j = kp + 1, kk - 1 t = conjg( a( j, kk ) ) a( j, kk ) = conjg( a( kp, j ) ) a( kp, j ) = t end do a( kp, kk ) = conjg( a( kp, kk ) ) - r1 = real( a( kk, kk ),KIND=qp) - a( kk, kk ) = real( a( kp, kp ),KIND=qp) + r1 = real( a( kk, kk ),KIND=${ck}$) + a( kk, kk ) = real( a( kp, kp ),KIND=${ck}$) a( kp, kp ) = r1 if( kstep==2 ) then - a( k, k ) = real( a( k, k ),KIND=qp) + a( k, k ) = real( a( k, k ),KIND=${ck}$) t = a( k-1, k ) a( k-1, k ) = a( kp, k ) a( kp, k ) = t end if else - a( k, k ) = real( a( k, k ),KIND=qp) - if( kstep==2 )a( k-1, k-1 ) = real( a( k-1, k-1 ),KIND=qp) + a( k, k ) = real( a( k, k ),KIND=${ck}$) + if( kstep==2 )a( k-1, k-1 ) = real( a( k-1, k-1 ),KIND=${ck}$) end if ! update the leading submatrix if( kstep==1 ) then @@ -27239,10 +27241,10 @@ module stdlib_linalg_lapack_w ! where u(k) is the k-th column of u ! perform a rank-1 update of a(1:k-1,1:k-1) as ! a := a - u(k)*d(k)*u(k)**h = a - w(k)*1/d(k)*w(k)**h - r1 = one / real( a( k, k ),KIND=qp) - call stdlib_wher( uplo, k-1, -r1, a( 1, k ), 1, a, lda ) + r1 = one / real( a( k, k ),KIND=${ck}$) + call stdlib_${ci}$her( uplo, k-1, -r1, a( 1, k ), 1, a, lda ) ! store u(k) in column k - call stdlib_wdscal( k-1, r1, a( 1, k ), 1 ) + call stdlib_${ci}$dscal( k-1, r1, a( 1, k ), 1 ) 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) @@ -27252,10 +27254,10 @@ module stdlib_linalg_lapack_w ! a := a - ( u(k-1) u(k) )*d(k)*( u(k-1) u(k) )**h ! = a - ( w(k-1) w(k) )*inv(d(k))*( w(k-1) w(k) )**h if( k>2 ) then - d = stdlib_qlapy2( real( a( k-1, k ),KIND=qp),aimag( a( k-1, k ) ) ) + d = stdlib_${c2ri(ci)}$lapy2( real( a( k-1, k ),KIND=${ck}$),aimag( a( k-1, k ) ) ) - d22 = real( a( k-1, k-1 ),KIND=qp) / d - d11 = real( a( k, k ),KIND=qp) / d + d22 = real( a( k-1, k-1 ),KIND=${ck}$) / d + d11 = real( a( k, k ),KIND=${ck}$) / d tt = one / ( d11*d22-one ) d12 = a( k-1, k ) / d d = tt / d @@ -27268,7 +27270,7 @@ module stdlib_linalg_lapack_w end do a( j, k ) = wk a( j, k-1 ) = wkm1 - a( j, j ) = cmplx( real( a( j, j ),KIND=qp), zero,KIND=qp) + a( j, j ) = cmplx( real( a( j, j ),KIND=${ck}$), zero,KIND=${ck}$) end do end if end if @@ -27294,22 +27296,22 @@ module stdlib_linalg_lapack_w kstep = 1 ! determine rows and columns to be interchanged and whether ! a 1-by-1 or 2-by-2 pivot block will be used - absakk = abs( real( a( k, k ),KIND=qp) ) + absakk = abs( real( a( k, k ),KIND=${ck}$) ) ! 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=alpha*colmax*( colmax / rowmax ) ) then ! no interchange, use 1-by-1 pivot block kp = k - else if( abs( real( a( imax, imax ),KIND=qp) )>=alpha*rowmax )then + else if( abs( real( a( imax, imax ),KIND=${ck}$) )>=alpha*rowmax )then ! interchange rows and columns k and imax, use 1-by-1 ! pivot block kp = imax @@ -27345,7 +27347,7 @@ module stdlib_linalg_lapack_w if( kp/=kk ) then ! interchange rows and columns kk and kp in the trailing ! submatrix a(k:n,k:n) - if( kp1 ) then - imax = stdlib_iwamax( k-1, a( 1, k ), 1 ) + imax = stdlib_i${ci}$amax( k-1, a( 1, k ), 1 ) colmax = cabs1( a( imax, k ) ) else colmax = zero @@ -27511,7 +27513,7 @@ module stdlib_linalg_lapack_w ! column k is zero or underflow: set info and continue if( info==0 )info = k kp = k - a( k, k ) = real( a( k, k ),KIND=qp) + a( k, k ) = real( a( k, k ),KIND=${ck}$) ! set e( k ) to zero if( k>1 )e( k ) = czero else @@ -27532,13 +27534,13 @@ module stdlib_linalg_lapack_w ! element in row imax, and rowmax is its absolute value. ! determine both rowmax and jmax. if( imax/=k ) then - jmax = imax + stdlib_iwamax( k-imax, a( imax, imax+1 ),lda ) + jmax = imax + stdlib_i${ci}$amax( k-imax, a( imax, imax+1 ),lda ) rowmax = cabs1( a( imax, jmax ) ) else rowmax = zero end if if( imax>1 ) then - itemp = stdlib_iwamax( imax-1, a( 1, imax ), 1 ) + itemp = stdlib_i${ci}$amax( imax-1, a( 1, imax ), 1 ) dtemp = cabs1( a( itemp, imax ) ) if( dtemp>rowmax ) then rowmax = dtemp @@ -27547,9 +27549,9 @@ module stdlib_linalg_lapack_w end if ! case(2) ! equivalent to testing for - ! abs( real( w( imax,kw-1 ),KIND=qp) )>=alpha*rowmax + ! abs( real( w( imax,kw-1 ),KIND=${ck}$) )>=alpha*rowmax ! (used to handle nan and inf) - if( .not.( abs( real( a( imax, imax ),KIND=qp) )1 )call stdlib_wswap( p-1, a( 1, k ), 1, a( 1, p ), 1 ) + if( p>1 )call stdlib_${ci}$swap( p-1, a( 1, k ), 1, a( 1, p ), 1 ) ! (2) swap and conjugate middle parts do j = p + 1, k - 1 t = conjg( a( j, k ) ) @@ -27592,18 +27594,18 @@ module stdlib_linalg_lapack_w ! (3) swap and conjugate corner elements at row-col interserction a( p, k ) = conjg( a( p, k ) ) ! (4) swap diagonal elements at row-col intersection - r1 = real( a( k, k ),KIND=qp) - a( k, k ) = real( a( p, p ),KIND=qp) + r1 = real( a( k, k ),KIND=${ck}$) + a( k, k ) = real( a( p, p ),KIND=${ck}$) a( p, p ) = r1 ! convert upper triangle of a into u form by applying ! the interchanges in columns k+1:n. - if( k1 )call stdlib_wswap( kp-1, a( 1, kk ), 1, a( 1, kp ), 1 ) + if( kp>1 )call stdlib_${ci}$swap( kp-1, a( 1, kk ), 1, a( 1, kp ), 1 ) ! (2) swap and conjugate middle parts do j = kp + 1, kk - 1 t = conjg( a( j, kk ) ) @@ -27613,12 +27615,12 @@ module stdlib_linalg_lapack_w ! (3) swap and conjugate corner elements at row-col interserction a( kp, kk ) = conjg( a( kp, kk ) ) ! (4) swap diagonal elements at row-col intersection - r1 = real( a( kk, kk ),KIND=qp) - a( kk, kk ) = real( a( kp, kp ),KIND=qp) + r1 = real( a( kk, kk ),KIND=${ck}$) + a( kk, kk ) = real( a( kp, kp ),KIND=${ck}$) a( kp, kp ) = r1 if( kstep==2 ) then ! (*) make sure that diagonal element of pivot is real - a( k, k ) = real( a( k, k ),KIND=qp) + a( k, k ) = real( a( k, k ),KIND=${ck}$) ! (5) swap row elements t = a( k-1, k ) a( k-1, k ) = a( kp, k ) @@ -27626,11 +27628,11 @@ module stdlib_linalg_lapack_w end if ! convert upper triangle of a into u form by applying ! the interchanges in columns k+1:n. - if( k1 ) then ! perform a rank-1 update of a(1:k-1,1:k-1) and ! store u(k) in column k - if( abs( real( a( k, k ),KIND=qp) )>=sfmin ) then + if( abs( real( a( k, k ),KIND=${ck}$) )>=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 / real( a( k, k ),KIND=qp) - call stdlib_wher( uplo, k-1, -d11, a( 1, k ), 1, a, lda ) + d11 = one / real( a( k, k ),KIND=${ck}$) + call stdlib_${ci}$her( uplo, k-1, -d11, a( 1, k ), 1, a, lda ) ! store u(k) in column k - call stdlib_wdscal( k-1, d11, a( 1, k ), 1 ) + call stdlib_${ci}$dscal( k-1, d11, a( 1, k ), 1 ) else ! store l(k) in column k - d11 = real( a( k, k ),KIND=qp) + d11 = real( a( k, k ),KIND=${ck}$) do ii = 1, k - 1 a( ii, k ) = a( ii, k ) / d11 end do @@ -27658,7 +27660,7 @@ module stdlib_linalg_lapack_w ! 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_wher( uplo, k-1, -d11, a( 1, k ), 1, a, lda ) + call stdlib_${ci}$her( uplo, k-1, -d11, a( 1, k ), 1, a, lda ) end if ! store the superdiagonal element of d in array e e( k ) = czero @@ -27674,10 +27676,10 @@ module stdlib_linalg_lapack_w ! and store l(k) and l(k+1) in columns k and k+1 if( k>2 ) then ! d = |a12| - d = stdlib_qlapy2( real( a( k-1, k ),KIND=qp),aimag( a( k-1, k ) ) ) + d = stdlib_${c2ri(ci)}$lapy2( real( a( k-1, k ),KIND=${ck}$),aimag( a( k-1, k ) ) ) - d11 = real( a( k, k ) / d,KIND=qp) - d22 = real( a( k-1, k-1 ) / d,KIND=qp) + d11 = real( a( k, k ) / d,KIND=${ck}$) + d22 = real( a( k-1, k-1 ) / d,KIND=${ck}$) d12 = a( k-1, k ) / d tt = one / ( d11*d22-one ) do j = k - 2, 1, -1 @@ -27693,7 +27695,7 @@ module stdlib_linalg_lapack_w a( j, k ) = wk / d a( j, k-1 ) = wkm1 / d ! (*) make sure that diagonal element of pivot is real - a( j, j ) = cmplx( real( a( j, j ),KIND=qp), zero,KIND=qp) + a( j, j ) = cmplx( real( a( j, j ),KIND=${ck}$), zero,KIND=${ck}$) end do end if ! copy superdiagonal elements of d(k) to e(k) and @@ -27729,12 +27731,12 @@ module stdlib_linalg_lapack_w 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( real( a( k, k ),KIND=qp) ) + absakk = abs( real( a( k, k ),KIND=${ck}$) ) ! 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( krowmax ) then rowmax = dtemp @@ -27779,9 +27781,9 @@ module stdlib_linalg_lapack_w end if ! case(2) ! equivalent to testing for - ! abs( real( w( imax,kw-1 ),KIND=qp) )>=alpha*rowmax + ! abs( real( w( imax,kw-1 ),KIND=${ck}$) )>=alpha*rowmax ! (used to handle nan and inf) - if( .not.( abs( real( a( imax, imax ),KIND=qp) )1 )call stdlib_wswap( k-1, a( k, 1 ), lda, a( p, 1 ), lda ) + if ( k>1 )call stdlib_${ci}$swap( k-1, a( k, 1 ), lda, a( p, 1 ), lda ) end if ! for both 1x1 and 2x2 pivots, interchange rows and ! columns kk and kp in the trailing submatrix a(k:n,k:n) if( kp/=kk ) then ! (1) swap columnar parts - if( kp1 )call stdlib_wswap( k-1, a( kk, 1 ), lda, a( kp, 1 ), lda ) + if ( k>1 )call stdlib_${ci}$swap( k-1, a( kk, 1 ), lda, a( kp, 1 ), lda ) else ! (*) make sure that diagonal element of pivot is real - a( k, k ) = real( a( k, k ),KIND=qp) - if( kstep==2 )a( k+1, k+1 ) = real( a( k+1, k+1 ),KIND=qp) + a( k, k ) = real( a( k, k ),KIND=${ck}$) + if( kstep==2 )a( k+1, k+1 ) = real( a( k+1, k+1 ),KIND=${ck}$) end if ! update the trailing submatrix if( kstep==1 ) then @@ -27874,18 +27876,18 @@ module stdlib_linalg_lapack_w ! perform a rank-1 update of a(k+1:n,k+1:n) and ! store l(k) in column k ! handle division by a small number - if( abs( real( a( k, k ),KIND=qp) )>=sfmin ) then + if( abs( real( a( k, k ),KIND=${ck}$) )>=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 / real( a( k, k ),KIND=qp) - call stdlib_wher( uplo, n-k, -d11, a( k+1, k ), 1,a( k+1, k+1 ), lda ) + d11 = one / real( a( k, k ),KIND=${ck}$) + call stdlib_${ci}$her( uplo, n-k, -d11, a( k+1, k ), 1,a( k+1, k+1 ), lda ) ! store l(k) in column k - call stdlib_wdscal( n-k, d11, a( k+1, k ), 1 ) + call stdlib_${ci}$dscal( n-k, d11, a( k+1, k ), 1 ) else ! store l(k) in column k - d11 = real( a( k, k ),KIND=qp) + d11 = real( a( k, k ),KIND=${ck}$) do ii = k + 1, n a( ii, k ) = a( ii, k ) / d11 end do @@ -27893,7 +27895,7 @@ module stdlib_linalg_lapack_w ! 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_wher( uplo, n-k, -d11, a( k+1, k ), 1,a( k+1, k+1 ), lda ) + call stdlib_${ci}$her( uplo, n-k, -d11, a( k+1, k ), 1,a( k+1, k+1 ), lda ) end if ! store the subdiagonal element of d in array e @@ -27910,10 +27912,10 @@ module stdlib_linalg_lapack_w ! and store l(k) and l(k+1) in columns k and k+1 if( k1 ) then - imax = stdlib_iwamax( k-1, a( 1, k ), 1 ) + imax = stdlib_i${ci}$amax( k-1, a( 1, k ), 1 ) colmax = cabs1( a( imax, k ) ) else colmax = zero @@ -28035,7 +28037,7 @@ module stdlib_linalg_lapack_w ! column k is zero or underflow: set info and continue if( info==0 )info = k kp = k - a( k, k ) = real( a( k, k ),KIND=qp) + a( k, k ) = real( a( k, k ),KIND=${ck}$) else ! ============================================================ ! begin pivot search @@ -28054,13 +28056,13 @@ module stdlib_linalg_lapack_w ! element in row imax, and rowmax is its absolute value. ! determine both rowmax and jmax. if( imax/=k ) then - jmax = imax + stdlib_iwamax( k-imax, a( imax, imax+1 ),lda ) + jmax = imax + stdlib_i${ci}$amax( k-imax, a( imax, imax+1 ),lda ) rowmax = cabs1( a( imax, jmax ) ) else rowmax = zero end if if( imax>1 ) then - itemp = stdlib_iwamax( imax-1, a( 1, imax ), 1 ) + itemp = stdlib_i${ci}$amax( imax-1, a( 1, imax ), 1 ) dtemp = cabs1( a( itemp, imax ) ) if( dtemp>rowmax ) then rowmax = dtemp @@ -28069,9 +28071,9 @@ module stdlib_linalg_lapack_w end if ! case(2) ! equivalent to testing for - ! abs( real( w( imax,kw-1 ),KIND=qp) )>=alpha*rowmax + ! abs( real( w( imax,kw-1 ),KIND=${ck}$) )>=alpha*rowmax ! (used to handle nan and inf) - if( .not.( abs( real( a( imax, imax ),KIND=qp) )1 )call stdlib_wswap( p-1, a( 1, k ), 1, a( 1, p ), 1 ) + if( p>1 )call stdlib_${ci}$swap( p-1, a( 1, k ), 1, a( 1, p ), 1 ) ! (2) swap and conjugate middle parts do j = p + 1, k - 1 t = conjg( a( j, k ) ) @@ -28114,15 +28116,15 @@ module stdlib_linalg_lapack_w ! (3) swap and conjugate corner elements at row-col interserction a( p, k ) = conjg( a( p, k ) ) ! (4) swap diagonal elements at row-col intersection - r1 = real( a( k, k ),KIND=qp) - a( k, k ) = real( a( p, p ),KIND=qp) + r1 = real( a( k, k ),KIND=${ck}$) + a( k, k ) = real( a( p, p ),KIND=${ck}$) a( p, p ) = r1 end if ! for both 1x1 and 2x2 pivots, interchange rows and ! columns kk and kp in the leading submatrix a(1:k,1:k) if( kp/=kk ) then ! (1) swap columnar parts - if( kp>1 )call stdlib_wswap( kp-1, a( 1, kk ), 1, a( 1, kp ), 1 ) + if( kp>1 )call stdlib_${ci}$swap( kp-1, a( 1, kk ), 1, a( 1, kp ), 1 ) ! (2) swap and conjugate middle parts do j = kp + 1, kk - 1 t = conjg( a( j, kk ) ) @@ -28132,12 +28134,12 @@ module stdlib_linalg_lapack_w ! (3) swap and conjugate corner elements at row-col interserction a( kp, kk ) = conjg( a( kp, kk ) ) ! (4) swap diagonal elements at row-col intersection - r1 = real( a( kk, kk ),KIND=qp) - a( kk, kk ) = real( a( kp, kp ),KIND=qp) + r1 = real( a( kk, kk ),KIND=${ck}$) + a( kk, kk ) = real( a( kp, kp ),KIND=${ck}$) a( kp, kp ) = r1 if( kstep==2 ) then ! (*) make sure that diagonal element of pivot is real - a( k, k ) = real( a( k, k ),KIND=qp) + a( k, k ) = real( a( k, k ),KIND=${ck}$) ! (5) swap row elements t = a( k-1, k ) a( k-1, k ) = a( kp, k ) @@ -28145,8 +28147,8 @@ module stdlib_linalg_lapack_w end if else ! (*) make sure that diagonal element of pivot is real - a( k, k ) = real( a( k, k ),KIND=qp) - if( kstep==2 )a( k-1, k-1 ) = real( a( k-1, k-1 ),KIND=qp) + a( k, k ) = real( a( k, k ),KIND=${ck}$) + if( kstep==2 )a( k-1, k-1 ) = real( a( k-1, k-1 ),KIND=${ck}$) end if ! update the leading submatrix if( kstep==1 ) then @@ -28156,17 +28158,17 @@ module stdlib_linalg_lapack_w if( k>1 ) then ! perform a rank-1 update of a(1:k-1,1:k-1) and ! store u(k) in column k - if( abs( real( a( k, k ),KIND=qp) )>=sfmin ) then + if( abs( real( a( k, k ),KIND=${ck}$) )>=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 / real( a( k, k ),KIND=qp) - call stdlib_wher( uplo, k-1, -d11, a( 1, k ), 1, a, lda ) + d11 = one / real( a( k, k ),KIND=${ck}$) + call stdlib_${ci}$her( uplo, k-1, -d11, a( 1, k ), 1, a, lda ) ! store u(k) in column k - call stdlib_wdscal( k-1, d11, a( 1, k ), 1 ) + call stdlib_${ci}$dscal( k-1, d11, a( 1, k ), 1 ) else ! store l(k) in column k - d11 = real( a( k, k ),KIND=qp) + d11 = real( a( k, k ),KIND=${ck}$) do ii = 1, k - 1 a( ii, k ) = a( ii, k ) / d11 end do @@ -28174,7 +28176,7 @@ module stdlib_linalg_lapack_w ! 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_wher( uplo, k-1, -d11, a( 1, k ), 1, a, lda ) + call stdlib_${ci}$her( uplo, k-1, -d11, a( 1, k ), 1, a, lda ) end if end if else @@ -28188,10 +28190,10 @@ module stdlib_linalg_lapack_w ! and store l(k) and l(k+1) in columns k and k+1 if( k>2 ) then ! d = |a12| - d = stdlib_qlapy2( real( a( k-1, k ),KIND=qp),aimag( a( k-1, k ) ) ) + d = stdlib_${c2ri(ci)}$lapy2( real( a( k-1, k ),KIND=${ck}$),aimag( a( k-1, k ) ) ) - d11 = real( a( k, k ) / d,KIND=qp) - d22 = real( a( k-1, k-1 ) / d,KIND=qp) + d11 = real( a( k, k ) / d,KIND=${ck}$) + d22 = real( a( k-1, k-1 ) / d,KIND=${ck}$) d12 = a( k-1, k ) / d tt = one / ( d11*d22-one ) do j = k - 2, 1, -1 @@ -28207,7 +28209,7 @@ module stdlib_linalg_lapack_w a( j, k ) = wk / d a( j, k-1 ) = wkm1 / d ! (*) make sure that diagonal element of pivot is real - a( j, j ) = cmplx( real( a( j, j ),KIND=qp), zero,KIND=qp) + a( j, j ) = cmplx( real( a( j, j ),KIND=${ck}$), zero,KIND=${ck}$) end do end if end if @@ -28234,12 +28236,12 @@ module stdlib_linalg_lapack_w 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( real( a( k, k ),KIND=qp) ) + absakk = abs( real( a( k, k ),KIND=${ck}$) ) ! 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( krowmax ) then rowmax = dtemp @@ -28282,9 +28284,9 @@ module stdlib_linalg_lapack_w end if ! case(2) ! equivalent to testing for - ! abs( real( w( imax,kw-1 ),KIND=qp) )>=alpha*rowmax + ! abs( real( w( imax,kw-1 ),KIND=${ck}$) )>=alpha*rowmax ! (used to handle nan and inf) - if( .not.( abs( real( a( imax, imax ),KIND=qp) )=sfmin ) then + if( abs( real( a( k, k ),KIND=${ck}$) )>=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 / real( a( k, k ),KIND=qp) - call stdlib_wher( uplo, n-k, -d11, a( k+1, k ), 1,a( k+1, k+1 ), lda ) + d11 = one / real( a( k, k ),KIND=${ck}$) + call stdlib_${ci}$her( uplo, n-k, -d11, a( k+1, k ), 1,a( k+1, k+1 ), lda ) ! store l(k) in column k - call stdlib_wdscal( n-k, d11, a( k+1, k ), 1 ) + call stdlib_${ci}$dscal( n-k, d11, a( k+1, k ), 1 ) else ! store l(k) in column k - d11 = real( a( k, k ),KIND=qp) + d11 = real( a( k, k ),KIND=${ck}$) do ii = k + 1, n a( ii, k ) = a( ii, k ) / d11 end do @@ -28390,7 +28392,7 @@ module stdlib_linalg_lapack_w ! 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_wher( uplo, n-k, -d11, a( k+1, k ), 1,a( k+1, k+1 ), lda ) + call stdlib_${ci}$her( uplo, n-k, -d11, a( k+1, k ), 1,a( k+1, k+1 ), lda ) end if end if @@ -28405,10 +28407,10 @@ module stdlib_linalg_lapack_w ! and store l(k) and l(k+1) in columns k and k+1 if( knb ) then ! factorize columns k-kb+1:k of a and use blocked code to ! update columns 1:k-kb - call stdlib_wlahef( uplo, k, nb, kb, a, lda, ipiv, work, n, iinfo ) + call stdlib_${ci}$lahef( uplo, k, nb, kb, a, lda, ipiv, work, n, iinfo ) else ! use unblocked code to factorize columns 1:k of a - call stdlib_whetf2( uplo, k, a, lda, ipiv, iinfo ) + call stdlib_${ci}$hetf2( uplo, k, a, lda, ipiv, iinfo ) kb = k end if ! set info on the first occurrence of a zero pivot @@ -29112,7 +29114,7 @@ module stdlib_linalg_lapack_w else ! factorize a as l*d*l**h 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_wlahef; + ! kb, where kb is the number of columns factorized by stdlib_${ci}$lahef; ! kb is either nb or nb-1, or n-k+1 for the last block k = 1 20 continue @@ -29121,11 +29123,11 @@ module stdlib_linalg_lapack_w 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_wlahef( uplo, n-k+1, nb, kb, a( k, k ), lda, ipiv( k ),work, n, & + call stdlib_${ci}$lahef( uplo, n-k+1, nb, kb, a( k, k ), lda, ipiv( k ),work, n, & iinfo ) else ! use unblocked code to factorize columns k:n of a - call stdlib_whetf2( uplo, n-k+1, a( k, k ), lda, ipiv( k ), iinfo ) + call stdlib_${ci}$hetf2( uplo, n-k+1, a( k, k ), lda, ipiv( k ), iinfo ) kb = n - k + 1 end if ! set info on the first occurrence of a zero pivot @@ -29145,10 +29147,10 @@ module stdlib_linalg_lapack_w 40 continue work( 1 ) = lwkopt return - end subroutine stdlib_whetrf + end subroutine stdlib_${ci}$hetrf - pure subroutine stdlib_whetrf_aa( uplo, n, a, lda, ipiv, work, lwork, info) + pure subroutine stdlib_${ci}$hetrf_aa( uplo, n, a, lda, ipiv, work, lwork, info) !! ZHETRF_AA: computes the factorization of a complex hermitian matrix A !! using the Aasen's algorithm. The form of the factorization is !! A = U**H*T*U or A = L*T*L**H @@ -29164,15 +29166,15 @@ module stdlib_linalg_lapack_w integer(ilp), intent(out) :: info ! Array Arguments integer(ilp), intent(out) :: ipiv(*) - complex(qp), intent(inout) :: a(lda,*) - complex(qp), intent(out) :: work(*) + complex(${ck}$), intent(inout) :: a(lda,*) + complex(${ck}$), intent(out) :: work(*) ! ===================================================================== ! Local Scalars logical(lk) :: lquery, upper integer(ilp) :: j, lwkopt integer(ilp) :: nb, mj, nj, k1, k2, j1, j2, j3, jb - complex(qp) :: alpha + complex(${ck}$) :: alpha ! Intrinsic Functions intrinsic :: real,conjg,max ! Executable Statements @@ -29207,7 +29209,7 @@ module stdlib_linalg_lapack_w endif ipiv( 1 ) = 1 if ( n==1 ) then - a( 1, 1 ) = real( a( 1, 1 ),KIND=qp) + a( 1, 1 ) = real( a( 1, 1 ),KIND=${ck}$) return end if ! adjust block size based on the workspace size @@ -29219,9 +29221,9 @@ module stdlib_linalg_lapack_w ! factorize a as u**h*d*u using the upper triangle of a ! ..................................................... ! copy first row a(1, 1:n) into h(1:n) (stored in work(1:n)) - call stdlib_wcopy( n, a( 1, 1 ), lda, work( 1 ), 1 ) + call stdlib_${ci}$copy( n, a( 1, 1 ), lda, work( 1 ), 1 ) ! j is the main loop index, increasing from 1 to n in steps of - ! jb, where jb is the number of columns factorized by stdlib_wlahef; + ! jb, where jb is the number of columns factorized by stdlib_${ci}$lahef; ! jb is either nb, or n-j+1 for the last block j = 0 10 continue @@ -29236,13 +29238,13 @@ module stdlib_linalg_lapack_w jb = min( n-j1+1, nb ) k1 = max(1, j)-j ! panel factorization - call stdlib_wlahef_aa( uplo, 2-k1, n-j, jb,a( max(1, j), j+1 ), lda,ipiv( j+1 ), & + call stdlib_${ci}$lahef_aa( uplo, 2-k1, n-j, jb,a( max(1, j), j+1 ), lda,ipiv( j+1 ), & work, n, work( n*nb+1 ) ) ! adjust ipiv and apply it back (j-th step picks (j+1)-th pivot) do j2 = j+2, min(n, j+jb+1) ipiv( j2 ) = ipiv( j2 ) + j if( (j2/=ipiv(j2)) .and. ((j1-k1)>2) ) then - call stdlib_wswap( j1-k1-2, a( 1, j2 ), 1,a( 1, ipiv(j2) ), 1 ) + call stdlib_${ci}$swap( j1-k1-2, a( 1, j2 ), 1,a( 1, ipiv(j2) ), 1 ) end if end do j = j + jb @@ -29255,9 +29257,9 @@ module stdlib_linalg_lapack_w ! merge rank-1 update with blas-3 update alpha = conjg( a( j, j+1 ) ) a( j, j+1 ) = cone - call stdlib_wcopy( n-j, a( j-1, j+1 ), lda,work( (j+1-j1+1)+jb*n ), 1 ) + call stdlib_${ci}$copy( n-j, a( j-1, j+1 ), lda,work( (j+1-j1+1)+jb*n ), 1 ) - call stdlib_wscal( n-j, alpha, work( (j+1-j1+1)+jb*n ), 1 ) + call stdlib_${ci}$scal( n-j, alpha, work( (j+1-j1+1)+jb*n ), 1 ) ! k1 identifies if the previous column of the panel has been ! explicitly stored, e.g., k1=0 and k2=1 for the first panel, ! and k1=1 and k2=0 for the rest @@ -29272,16 +29274,16 @@ module stdlib_linalg_lapack_w end if do j2 = j+1, n, nb nj = min( nb, n-j2+1 ) - ! update (j2, j2) diagonal block with stdlib_wgemv + ! update (j2, j2) diagonal block with stdlib_${ci}$gemv j3 = j2 do mj = nj-1, 1, -1 - call stdlib_wgemm( 'CONJUGATE TRANSPOSE', 'TRANSPOSE',1, mj, jb+1,-cone,& + call stdlib_${ci}$gemm( 'CONJUGATE TRANSPOSE', 'TRANSPOSE',1, mj, jb+1,-cone,& a( j1-k2, j3 ), lda,work( (j3-j1+1)+k1*n ), n,cone, a( j3, j3 ), lda ) j3 = j3 + 1 end do - ! update off-diagonal block of j2-th block row with stdlib_wgemm - call stdlib_wgemm( 'CONJUGATE TRANSPOSE', 'TRANSPOSE',nj, n-j3+1, jb+1,-& + ! update off-diagonal block of j2-th block row with stdlib_${ci}$gemm + call stdlib_${ci}$gemm( 'CONJUGATE TRANSPOSE', 'TRANSPOSE',nj, n-j3+1, jb+1,-& cone, a( j1-k2, j2 ), lda,work( (j3-j1+1)+k1*n ), n,cone, a( j2, j3 ), lda & ) end do @@ -29289,7 +29291,7 @@ module stdlib_linalg_lapack_w a( j, j+1 ) = conjg( alpha ) end if ! work(j+1, 1) stores h(j+1, 1) - call stdlib_wcopy( n-j, a( j+1, j+1 ), lda, work( 1 ), 1 ) + call stdlib_${ci}$copy( n-j, a( j+1, j+1 ), lda, work( 1 ), 1 ) end if go to 10 else @@ -29298,9 +29300,9 @@ module stdlib_linalg_lapack_w ! ..................................................... ! copy first column a(1:n, 1) into h(1:n, 1) ! (stored in work(1:n)) - call stdlib_wcopy( n, a( 1, 1 ), 1, work( 1 ), 1 ) + call stdlib_${ci}$copy( n, a( 1, 1 ), 1, work( 1 ), 1 ) ! j is the main loop index, increasing from 1 to n in steps of - ! jb, where jb is the number of columns factorized by stdlib_wlahef; + ! jb, where jb is the number of columns factorized by stdlib_${ci}$lahef; ! jb is either nb, or n-j+1 for the last block j = 0 11 continue @@ -29315,13 +29317,13 @@ module stdlib_linalg_lapack_w jb = min( n-j1+1, nb ) k1 = max(1, j)-j ! panel factorization - call stdlib_wlahef_aa( uplo, 2-k1, n-j, jb,a( j+1, max(1, j) ), lda,ipiv( j+1 ), & + call stdlib_${ci}$lahef_aa( uplo, 2-k1, n-j, jb,a( j+1, max(1, j) ), lda,ipiv( j+1 ), & work, n, work( n*nb+1 ) ) ! adjust ipiv and apply it back (j-th step picks (j+1)-th pivot) do j2 = j+2, min(n, j+jb+1) ipiv( j2 ) = ipiv( j2 ) + j if( (j2/=ipiv(j2)) .and. ((j1-k1)>2) ) then - call stdlib_wswap( j1-k1-2, a( j2, 1 ), lda,a( ipiv(j2), 1 ), lda ) + call stdlib_${ci}$swap( j1-k1-2, a( j2, 1 ), lda,a( ipiv(j2), 1 ), lda ) end if end do j = j + jb @@ -29334,8 +29336,8 @@ module stdlib_linalg_lapack_w ! merge rank-1 update with blas-3 update alpha = conjg( a( j+1, j ) ) a( j+1, j ) = cone - call stdlib_wcopy( n-j, a( j+1, j-1 ), 1,work( (j+1-j1+1)+jb*n ), 1 ) - call stdlib_wscal( n-j, alpha, work( (j+1-j1+1)+jb*n ), 1 ) + call stdlib_${ci}$copy( n-j, a( j+1, j-1 ), 1,work( (j+1-j1+1)+jb*n ), 1 ) + call stdlib_${ci}$scal( n-j, alpha, work( (j+1-j1+1)+jb*n ), 1 ) ! k1 identifies if the previous column of the panel has been ! explicitly stored, e.g., k1=0 and k2=1 for the first panel, ! and k1=1 and k2=0 for the rest @@ -29350,16 +29352,16 @@ module stdlib_linalg_lapack_w end if do j2 = j+1, n, nb nj = min( nb, n-j2+1 ) - ! update (j2, j2) diagonal block with stdlib_wgemv + ! update (j2, j2) diagonal block with stdlib_${ci}$gemv j3 = j2 do mj = nj-1, 1, -1 - call stdlib_wgemm( 'NO TRANSPOSE', 'CONJUGATE TRANSPOSE',mj, 1, jb+1,-& + call stdlib_${ci}$gemm( 'NO TRANSPOSE', 'CONJUGATE TRANSPOSE',mj, 1, jb+1,-& cone, work( (j3-j1+1)+k1*n ), n,a( j3, j1-k2 ), lda,cone, a( j3, j3 ), & lda ) j3 = j3 + 1 end do - ! update off-diagonal block of j2-th block column with stdlib_wgemm - call stdlib_wgemm( 'NO TRANSPOSE', 'CONJUGATE TRANSPOSE',n-j3+1, nj, jb+1,-& + ! update off-diagonal block of j2-th block column with stdlib_${ci}$gemm + call stdlib_${ci}$gemm( 'NO TRANSPOSE', 'CONJUGATE TRANSPOSE',n-j3+1, nj, jb+1,-& cone, work( (j3-j1+1)+k1*n ), n,a( j2, j1-k2 ), lda,cone, a( j3, j2 ), lda & ) end do @@ -29367,17 +29369,17 @@ module stdlib_linalg_lapack_w a( j+1, j ) = conjg( alpha ) end if ! work(j+1, 1) stores h(j+1, 1) - call stdlib_wcopy( n-j, a( j+1, j+1 ), 1, work( 1 ), 1 ) + call stdlib_${ci}$copy( n-j, a( j+1, j+1 ), 1, work( 1 ), 1 ) end if go to 11 end if 20 continue work( 1 ) = lwkopt return - end subroutine stdlib_whetrf_aa + end subroutine stdlib_${ci}$hetrf_aa - pure subroutine stdlib_whetrf_rk( uplo, n, a, lda, e, ipiv, work, lwork,info ) + pure subroutine stdlib_${ci}$hetrf_rk( uplo, n, a, lda, e, ipiv, work, lwork,info ) !! ZHETRF_RK: computes the factorization of a complex Hermitian matrix A !! using the bounded Bunch-Kaufman (rook) diagonal pivoting method: !! A = P*U*D*(U**H)*(P**T) or A = P*L*D*(L**H)*(P**T), @@ -29396,8 +29398,8 @@ module stdlib_linalg_lapack_w integer(ilp), intent(in) :: lda, lwork, n ! Array Arguments integer(ilp), intent(out) :: ipiv(*) - complex(qp), intent(inout) :: a(lda,*) - complex(qp), intent(out) :: e(*), work(*) + complex(${ck}$), intent(inout) :: a(lda,*) + complex(${ck}$), intent(out) :: e(*), work(*) ! ===================================================================== ! Local Scalars logical(lk) :: lquery, upper @@ -29445,7 +29447,7 @@ module stdlib_linalg_lapack_w 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_wlahef_rk; + ! kb, where kb is the number of columns factorized by stdlib_${ci}$lahef_rk; ! kb is either nb or nb-1, or k for the last block k = n 10 continue @@ -29454,11 +29456,11 @@ module stdlib_linalg_lapack_w if( k>nb ) then ! factorize columns k-kb+1:k of a and use blocked code to ! update columns 1:k-kb - call stdlib_wlahef_rk( uplo, k, nb, kb, a, lda, e,ipiv, work, ldwork, iinfo ) + call stdlib_${ci}$lahef_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_whetf2_rk( uplo, k, a, lda, e, ipiv, iinfo ) + call stdlib_${ci}$hetf2_rk( uplo, k, a, lda, e, ipiv, iinfo ) kb = k end if ! set info on the first occurrence of a zero pivot @@ -29475,7 +29477,7 @@ module stdlib_linalg_lapack_w do i = k, ( k - kb + 1 ), -1 ip = abs( ipiv( i ) ) if( ip/=i ) then - call stdlib_wswap( n-k, a( i, k+1 ), lda,a( ip, k+1 ), lda ) + call stdlib_${ci}$swap( n-k, a( i, k+1 ), lda,a( ip, k+1 ), lda ) end if end do end if @@ -29488,7 +29490,7 @@ module stdlib_linalg_lapack_w 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_wlahef_rk; + ! kb, where kb is the number of columns factorized by stdlib_${ci}$lahef_rk; ! kb is either nb or nb-1, or n-k+1 for the last block k = 1 20 continue @@ -29497,11 +29499,11 @@ module stdlib_linalg_lapack_w 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_wlahef_rk( uplo, n-k+1, nb, kb, a( k, k ), lda, e( k ),ipiv( k ), & + call stdlib_${ci}$lahef_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_whetf2_rk( uplo, n-k+1, a( k, k ), lda, e( k ),ipiv( k ), iinfo ) + call stdlib_${ci}$hetf2_rk( uplo, n-k+1, a( k, k ), lda, e( k ),ipiv( k ), iinfo ) kb = n - k + 1 end if @@ -29526,7 +29528,7 @@ module stdlib_linalg_lapack_w do i = k, ( k + kb - 1 ), 1 ip = abs( ipiv( i ) ) if( ip/=i ) then - call stdlib_wswap( k-1, a( i, 1 ), lda,a( ip, 1 ), lda ) + call stdlib_${ci}$swap( k-1, a( i, 1 ), lda,a( ip, 1 ), lda ) end if end do end if @@ -29540,10 +29542,10 @@ module stdlib_linalg_lapack_w end if work( 1 ) = lwkopt return - end subroutine stdlib_whetrf_rk + end subroutine stdlib_${ci}$hetrf_rk - pure subroutine stdlib_whetrf_rook( uplo, n, a, lda, ipiv, work, lwork, info ) + pure subroutine stdlib_${ci}$hetrf_rook( uplo, n, a, lda, ipiv, work, lwork, info ) !! ZHETRF_ROOK: computes the factorization of a complex Hermitian matrix A !! using the bounded Bunch-Kaufman ("rook") diagonal pivoting method. !! The form of the factorization is @@ -29561,8 +29563,8 @@ module stdlib_linalg_lapack_w integer(ilp), intent(in) :: lda, lwork, n ! Array Arguments integer(ilp), intent(out) :: ipiv(*) - complex(qp), intent(inout) :: a(lda,*) - complex(qp), intent(out) :: work(*) + complex(${ck}$), intent(inout) :: a(lda,*) + complex(${ck}$), intent(out) :: work(*) ! ===================================================================== ! Local Scalars logical(lk) :: lquery, upper @@ -29610,7 +29612,7 @@ module stdlib_linalg_lapack_w 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_wlahef_rook; + ! kb, where kb is the number of columns factorized by stdlib_${ci}$lahef_rook; ! kb is either nb or nb-1, or k for the last block k = n 10 continue @@ -29619,11 +29621,11 @@ module stdlib_linalg_lapack_w if( k>nb ) then ! factorize columns k-kb+1:k of a and use blocked code to ! update columns 1:k-kb - call stdlib_wlahef_rook( uplo, k, nb, kb, a, lda,ipiv, work, ldwork, iinfo ) + call stdlib_${ci}$lahef_rook( uplo, k, nb, kb, a, lda,ipiv, work, ldwork, iinfo ) else ! use unblocked code to factorize columns 1:k of a - call stdlib_whetf2_rook( uplo, k, a, lda, ipiv, iinfo ) + call stdlib_${ci}$hetf2_rook( uplo, k, a, lda, ipiv, iinfo ) kb = k end if ! set info on the first occurrence of a zero pivot @@ -29635,7 +29637,7 @@ module stdlib_linalg_lapack_w 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_wlahef_rook; + ! kb, where kb is the number of columns factorized by stdlib_${ci}$lahef_rook; ! kb is either nb or nb-1, or n-k+1 for the last block k = 1 20 continue @@ -29644,11 +29646,11 @@ module stdlib_linalg_lapack_w 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_wlahef_rook( uplo, n-k+1, nb, kb, a( k, k ), lda,ipiv( k ), work, & + call stdlib_${ci}$lahef_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_whetf2_rook( uplo, n-k+1, a( k, k ), lda, ipiv( k ),iinfo ) + call stdlib_${ci}$hetf2_rook( uplo, n-k+1, a( k, k ), lda, ipiv( k ),iinfo ) kb = n - k + 1 end if ! set info on the first occurrence of a zero pivot @@ -29668,10 +29670,10 @@ module stdlib_linalg_lapack_w 40 continue work( 1 ) = lwkopt return - end subroutine stdlib_whetrf_rook + end subroutine stdlib_${ci}$hetrf_rook - pure subroutine stdlib_whetri( uplo, n, a, lda, ipiv, work, info ) + pure subroutine stdlib_${ci}$hetri( uplo, n, a, lda, ipiv, work, info ) !! ZHETRI: computes the inverse of a complex Hermitian indefinite matrix !! A using the factorization A = U*D*U**H or A = L*D*L**H computed by !! ZHETRF. @@ -29684,16 +29686,16 @@ module stdlib_linalg_lapack_w integer(ilp), intent(in) :: lda, n ! Array Arguments integer(ilp), intent(in) :: ipiv(*) - complex(qp), intent(inout) :: a(lda,*) - complex(qp), intent(out) :: work(*) + complex(${ck}$), intent(inout) :: a(lda,*) + complex(${ck}$), intent(out) :: work(*) ! ===================================================================== ! Local Scalars logical(lk) :: upper integer(ilp) :: j, k, kp, kstep - real(qp) :: ak, akp1, d, t - complex(qp) :: akkp1, temp + real(${ck}$) :: ak, akp1, d, t + complex(${ck}$) :: akkp1, temp ! Intrinsic Functions intrinsic :: abs,real,conjg,max ! Executable Statements @@ -29737,22 +29739,22 @@ module stdlib_linalg_lapack_w if( ipiv( k )>0 ) then ! 1 x 1 diagonal block ! invert the diagonal block. - a( k, k ) = one / real( a( k, k ),KIND=qp) + a( k, k ) = one / real( a( k, k ),KIND=${ck}$) ! compute column k of the inverse. if( k>1 ) then - call stdlib_wcopy( k-1, a( 1, k ), 1, work, 1 ) - call stdlib_whemv( uplo, k-1, -cone, a, lda, work, 1, czero,a( 1, k ), 1 ) + call stdlib_${ci}$copy( k-1, a( 1, k ), 1, work, 1 ) + call stdlib_${ci}$hemv( uplo, k-1, -cone, a, lda, work, 1, czero,a( 1, k ), 1 ) - a( k, k ) = a( k, k ) - real( stdlib_wdotc( k-1, work, 1, a( 1,k ), 1 ),& - KIND=qp) + a( k, k ) = a( k, k ) - real( stdlib_${ci}$dotc( k-1, work, 1, a( 1,k ), 1 ),& + KIND=${ck}$) end if kstep = 1 else ! 2 x 2 diagonal block ! invert the diagonal block. t = abs( a( k, k+1 ) ) - ak = real( a( k, k ),KIND=qp) / t - akp1 = real( a( k+1, k+1 ),KIND=qp) / t + ak = real( a( k, k ),KIND=${ck}$) / t + akp1 = real( a( k+1, k+1 ),KIND=${ck}$) / t akkp1 = a( k, k+1 ) / t d = t*( ak*akp1-one ) a( k, k ) = akp1 / d @@ -29760,18 +29762,18 @@ module stdlib_linalg_lapack_w a( k, k+1 ) = -akkp1 / d ! compute columns k and k+1 of the inverse. if( k>1 ) then - call stdlib_wcopy( k-1, a( 1, k ), 1, work, 1 ) - call stdlib_whemv( uplo, k-1, -cone, a, lda, work, 1, czero,a( 1, k ), 1 ) + call stdlib_${ci}$copy( k-1, a( 1, k ), 1, work, 1 ) + call stdlib_${ci}$hemv( uplo, k-1, -cone, a, lda, work, 1, czero,a( 1, k ), 1 ) - a( k, k ) = a( k, k ) - real( stdlib_wdotc( k-1, work, 1, a( 1,k ), 1 ),& - KIND=qp) - a( k, k+1 ) = a( k, k+1 ) -stdlib_wdotc( k-1, a( 1, k ), 1, a( 1, k+1 ), 1 ) + a( k, k ) = a( k, k ) - real( stdlib_${ci}$dotc( k-1, work, 1, a( 1,k ), 1 ),& + KIND=${ck}$) + a( k, k+1 ) = a( k, k+1 ) -stdlib_${ci}$dotc( k-1, a( 1, k ), 1, a( 1, k+1 ), 1 ) - call stdlib_wcopy( k-1, a( 1, k+1 ), 1, work, 1 ) - call stdlib_whemv( uplo, k-1, -cone, a, lda, work, 1, czero,a( 1, k+1 ), 1 ) + call stdlib_${ci}$copy( k-1, a( 1, k+1 ), 1, work, 1 ) + call stdlib_${ci}$hemv( uplo, k-1, -cone, a, lda, work, 1, czero,a( 1, k+1 ), 1 ) - a( k+1, k+1 ) = a( k+1, k+1 ) -real( stdlib_wdotc( k-1, work, 1, a( 1, k+1 ),& - 1 ),KIND=qp) + a( k+1, k+1 ) = a( k+1, k+1 ) -real( stdlib_${ci}$dotc( k-1, work, 1, a( 1, k+1 ),& + 1 ),KIND=${ck}$) end if kstep = 2 end if @@ -29779,7 +29781,7 @@ module stdlib_linalg_lapack_w if( kp/=k ) then ! interchange rows and columns k and kp in the leading ! submatrix a(1:k+1,1:k+1) - call stdlib_wswap( kp-1, a( 1, k ), 1, a( 1, kp ), 1 ) + call stdlib_${ci}$swap( kp-1, a( 1, k ), 1, a( 1, kp ), 1 ) do j = kp + 1, k - 1 temp = conjg( a( j, k ) ) a( j, k ) = conjg( a( kp, j ) ) @@ -29809,22 +29811,22 @@ module stdlib_linalg_lapack_w if( ipiv( k )>0 ) then ! 1 x 1 diagonal block ! invert the diagonal block. - a( k, k ) = one / real( a( k, k ),KIND=qp) + a( k, k ) = one / real( a( k, k ),KIND=${ck}$) ! compute column k of the inverse. if( k0 ) then ! 1 x 1 diagonal block ! invert the diagonal block. - a( k, k ) = one / real( a( k, k ),KIND=qp) + a( k, k ) = one / real( a( k, k ),KIND=${ck}$) ! compute column k of the inverse. if( k>1 ) then - call stdlib_wcopy( k-1, a( 1, k ), 1, work, 1 ) - call stdlib_whemv( uplo, k-1, -cone, a, lda, work, 1, czero,a( 1, k ), 1 ) + call stdlib_${ci}$copy( k-1, a( 1, k ), 1, work, 1 ) + call stdlib_${ci}$hemv( uplo, k-1, -cone, a, lda, work, 1, czero,a( 1, k ), 1 ) - a( k, k ) = a( k, k ) - real( stdlib_wdotc( k-1, work, 1, a( 1,k ), 1 ),& - KIND=qp) + a( k, k ) = a( k, k ) - real( stdlib_${ci}$dotc( k-1, work, 1, a( 1,k ), 1 ),& + KIND=${ck}$) end if kstep = 1 else ! 2 x 2 diagonal block ! invert the diagonal block. t = abs( a( k, k+1 ) ) - ak = real( a( k, k ),KIND=qp) / t - akp1 = real( a( k+1, k+1 ),KIND=qp) / t + ak = real( a( k, k ),KIND=${ck}$) / t + akp1 = real( a( k+1, k+1 ),KIND=${ck}$) / t akkp1 = a( k, k+1 ) / t d = t*( ak*akp1-one ) a( k, k ) = akp1 / d @@ -29964,18 +29966,18 @@ module stdlib_linalg_lapack_w a( k, k+1 ) = -akkp1 / d ! compute columns k and k+1 of the inverse. if( k>1 ) then - call stdlib_wcopy( k-1, a( 1, k ), 1, work, 1 ) - call stdlib_whemv( uplo, k-1, -cone, a, lda, work, 1, czero,a( 1, k ), 1 ) + call stdlib_${ci}$copy( k-1, a( 1, k ), 1, work, 1 ) + call stdlib_${ci}$hemv( uplo, k-1, -cone, a, lda, work, 1, czero,a( 1, k ), 1 ) - a( k, k ) = a( k, k ) - real( stdlib_wdotc( k-1, work, 1, a( 1,k ), 1 ),& - KIND=qp) - a( k, k+1 ) = a( k, k+1 ) -stdlib_wdotc( k-1, a( 1, k ), 1, a( 1, k+1 ), 1 ) + a( k, k ) = a( k, k ) - real( stdlib_${ci}$dotc( k-1, work, 1, a( 1,k ), 1 ),& + KIND=${ck}$) + a( k, k+1 ) = a( k, k+1 ) -stdlib_${ci}$dotc( k-1, a( 1, k ), 1, a( 1, k+1 ), 1 ) - call stdlib_wcopy( k-1, a( 1, k+1 ), 1, work, 1 ) - call stdlib_whemv( uplo, k-1, -cone, a, lda, work, 1, czero,a( 1, k+1 ), 1 ) + call stdlib_${ci}$copy( k-1, a( 1, k+1 ), 1, work, 1 ) + call stdlib_${ci}$hemv( uplo, k-1, -cone, a, lda, work, 1, czero,a( 1, k+1 ), 1 ) - a( k+1, k+1 ) = a( k+1, k+1 ) -real( stdlib_wdotc( k-1, work, 1, a( 1, k+1 ),& - 1 ),KIND=qp) + a( k+1, k+1 ) = a( k+1, k+1 ) -real( stdlib_${ci}$dotc( k-1, work, 1, a( 1, k+1 ),& + 1 ),KIND=${ck}$) end if kstep = 2 end if @@ -29984,7 +29986,7 @@ module stdlib_linalg_lapack_w ! submatrix a(1:k,1:k) kp = ipiv( k ) if( kp/=k ) then - if( kp>1 )call stdlib_wswap( kp-1, a( 1, k ), 1, a( 1, kp ), 1 ) + if( kp>1 )call stdlib_${ci}$swap( kp-1, a( 1, k ), 1, a( 1, kp ), 1 ) do j = kp + 1, k - 1 temp = conjg( a( j, k ) ) a( j, k ) = conjg( a( kp, j ) ) @@ -30001,7 +30003,7 @@ module stdlib_linalg_lapack_w ! (1) interchange rows and columns k and -ipiv(k) kp = -ipiv( k ) if( kp/=k ) then - if( kp>1 )call stdlib_wswap( kp-1, a( 1, k ), 1, a( 1, kp ), 1 ) + if( kp>1 )call stdlib_${ci}$swap( kp-1, a( 1, k ), 1, a( 1, kp ), 1 ) do j = kp + 1, k - 1 temp = conjg( a( j, k ) ) a( j, k ) = conjg( a( kp, j ) ) @@ -30019,7 +30021,7 @@ module stdlib_linalg_lapack_w k = k + 1 kp = -ipiv( k ) if( kp/=k ) then - if( kp>1 )call stdlib_wswap( kp-1, a( 1, k ), 1, a( 1, kp ), 1 ) + if( kp>1 )call stdlib_${ci}$swap( kp-1, a( 1, k ), 1, a( 1, kp ), 1 ) do j = kp + 1, k - 1 temp = conjg( a( j, k ) ) a( j, k ) = conjg( a( kp, j ) ) @@ -30045,22 +30047,22 @@ module stdlib_linalg_lapack_w if( ipiv( k )>0 ) then ! 1 x 1 diagonal block ! invert the diagonal block. - a( k, k ) = one / real( a( k, k ),KIND=qp) + a( k, k ) = one / real( a( k, k ),KIND=${ck}$) ! compute column k of the inverse. if( k1 ) then - call stdlib_wlacgv( nrhs, b( k, 1 ), ldb ) - call stdlib_wgemv( 'CONJUGATE TRANSPOSE', k-1, nrhs, -cone, b,ldb, a( 1, k ), & + call stdlib_${ci}$lacgv( nrhs, b( k, 1 ), ldb ) + call stdlib_${ci}$gemv( 'CONJUGATE TRANSPOSE', k-1, nrhs, -cone, b,ldb, a( 1, k ), & 1, cone, b( k, 1 ), ldb ) - call stdlib_wlacgv( nrhs, b( k, 1 ), ldb ) + call stdlib_${ci}$lacgv( nrhs, b( k, 1 ), ldb ) end if ! interchange rows k and ipiv(k). kp = ipiv( k ) - if( kp/=k )call stdlib_wswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib_${ci}$swap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) k = k + 1 else ! 2 x 2 diagonal block ! multiply by inv(u**h(k+1)), where u(k+1) is the transformation ! stored in columns k and k+1 of a. if( k>1 ) then - call stdlib_wlacgv( nrhs, b( k, 1 ), ldb ) - call stdlib_wgemv( 'CONJUGATE TRANSPOSE', k-1, nrhs, -cone, b,ldb, a( 1, k ), & + call stdlib_${ci}$lacgv( nrhs, b( k, 1 ), ldb ) + call stdlib_${ci}$gemv( 'CONJUGATE TRANSPOSE', k-1, nrhs, -cone, b,ldb, a( 1, k ), & 1, cone, b( k, 1 ), ldb ) - call stdlib_wlacgv( nrhs, b( k, 1 ), ldb ) - call stdlib_wlacgv( nrhs, b( k+1, 1 ), ldb ) - call stdlib_wgemv( 'CONJUGATE TRANSPOSE', k-1, nrhs, -cone, b,ldb, a( 1, k+1 )& + call stdlib_${ci}$lacgv( nrhs, b( k, 1 ), ldb ) + call stdlib_${ci}$lacgv( nrhs, b( k+1, 1 ), ldb ) + call stdlib_${ci}$gemv( 'CONJUGATE TRANSPOSE', k-1, nrhs, -cone, b,ldb, a( 1, k+1 )& , 1, cone, b( k+1, 1 ), ldb ) - call stdlib_wlacgv( nrhs, b( k+1, 1 ), ldb ) + call stdlib_${ci}$lacgv( nrhs, b( k+1, 1 ), ldb ) end if ! interchange rows k and -ipiv(k). kp = -ipiv( k ) - if( kp/=k )call stdlib_wswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib_${ci}$swap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) k = k + 2 end if go to 40 @@ -30290,26 +30292,26 @@ module stdlib_linalg_lapack_w ! 1 x 1 diagonal block ! interchange rows k and ipiv(k). kp = ipiv( k ) - if( kp/=k )call stdlib_wswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib_${ci}$swap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) ! multiply by inv(l(k)), where l(k) is the transformation ! stored in column k of a. - if( k b [ (u \p**t * b) ] - call stdlib_wtrsm('L','U','N','U',n,nrhs,cone,a,lda,b,ldb) + call stdlib_${ci}$trsm('L','U','N','U',n,nrhs,cone,a,lda,b,ldb) ! compute d \ b -> b [ d \ (u \p**t * b) ] i=n do while ( i >= 1 ) if( ipiv(i) > 0 ) then - s = real( cone,KIND=qp) / real( a( i, i ),KIND=qp) - call stdlib_wdscal( nrhs, s, b( i, 1 ), ldb ) + s = real( cone,KIND=${ck}$) / real( a( i, i ),KIND=${ck}$) + call stdlib_${ci}$dscal( nrhs, s, b( i, 1 ), ldb ) elseif ( i > 1) then if ( ipiv(i-1) == ipiv(i) ) then akm1k = work(i) @@ -30466,7 +30468,7 @@ module stdlib_linalg_lapack_w i = i - 1 end do ! compute (u**h \ b) -> b [ u**h \ (d \ (u \p**t * b) ) ] - call stdlib_wtrsm('L','U','C','U',n,nrhs,cone,a,lda,b,ldb) + call stdlib_${ci}$trsm('L','U','C','U',n,nrhs,cone,a,lda,b,ldb) ! p * b [ p * (u**h \ (d \ (u \p**t * b) )) ] k=1 do while ( k <= n ) @@ -30474,13 +30476,13 @@ module stdlib_linalg_lapack_w ! 1 x 1 diagonal block ! interchange rows k and ipiv(k). kp = ipiv( k ) - if( kp/=k )call stdlib_wswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib_${ci}$swap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) k=k+1 else ! 2 x 2 diagonal block ! interchange rows k-1 and -ipiv(k). kp = -ipiv( k ) - if( k < n .and. kp==-ipiv( k+1 ) )call stdlib_wswap( nrhs, b( k, 1 ), ldb, b( kp,& + if( k < n .and. kp==-ipiv( k+1 ) )call stdlib_${ci}$swap( nrhs, b( k, 1 ), ldb, b( kp,& 1 ), ldb ) k=k+2 endif @@ -30494,25 +30496,25 @@ module stdlib_linalg_lapack_w ! 1 x 1 diagonal block ! interchange rows k and ipiv(k). kp = ipiv( k ) - if( kp/=k )call stdlib_wswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib_${ci}$swap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) k=k+1 else ! 2 x 2 diagonal block ! interchange rows k and -ipiv(k+1). kp = -ipiv( k+1 ) - if( kp==-ipiv( k ) )call stdlib_wswap( nrhs, b( k+1, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp==-ipiv( k ) )call stdlib_${ci}$swap( nrhs, b( k+1, 1 ), ldb, b( kp, 1 ), ldb ) k=k+2 endif end do ! compute (l \p**t * b) -> b [ (l \p**t * b) ] - call stdlib_wtrsm('L','L','N','U',n,nrhs,cone,a,lda,b,ldb) + call stdlib_${ci}$trsm('L','L','N','U',n,nrhs,cone,a,lda,b,ldb) ! compute d \ b -> b [ d \ (l \p**t * b) ] i=1 do while ( i <= n ) if( ipiv(i) > 0 ) then - s = real( cone,KIND=qp) / real( a( i, i ),KIND=qp) - call stdlib_wdscal( nrhs, s, b( i, 1 ), ldb ) + s = real( cone,KIND=${ck}$) / real( a( i, i ),KIND=${ck}$) + call stdlib_${ci}$dscal( nrhs, s, b( i, 1 ), ldb ) else akm1k = work(i) akm1 = a( i, i ) / conjg( akm1k ) @@ -30529,7 +30531,7 @@ module stdlib_linalg_lapack_w i = i + 1 end do ! compute (l**h \ b) -> b [ l**h \ (d \ (l \p**t * b) ) ] - call stdlib_wtrsm('L','L','C','U',n,nrhs,cone,a,lda,b,ldb) + call stdlib_${ci}$trsm('L','L','C','U',n,nrhs,cone,a,lda,b,ldb) ! p * b [ p * (l**h \ (d \ (l \p**t * b) )) ] k=n do while ( k >= 1 ) @@ -30537,25 +30539,25 @@ module stdlib_linalg_lapack_w ! 1 x 1 diagonal block ! interchange rows k and ipiv(k). kp = ipiv( k ) - if( kp/=k )call stdlib_wswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib_${ci}$swap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) k=k-1 else ! 2 x 2 diagonal block ! interchange rows k-1 and -ipiv(k). kp = -ipiv( k ) - if( k>1 .and. kp==-ipiv( k-1 ) )call stdlib_wswap( nrhs, b( k, 1 ), ldb, b( kp, & + if( k>1 .and. kp==-ipiv( k-1 ) )call stdlib_${ci}$swap( nrhs, b( k, 1 ), ldb, b( kp, & 1 ), ldb ) k=k-2 endif end do end if ! revert a - call stdlib_wsyconv( uplo, 'R', n, a, lda, ipiv, work, iinfo ) + call stdlib_${ci}$syconv( uplo, 'R', n, a, lda, ipiv, work, iinfo ) return - end subroutine stdlib_whetrs2 + end subroutine stdlib_${ci}$hetrs2 - pure subroutine stdlib_whetrs_3( uplo, n, nrhs, a, lda, e, ipiv, b, ldb,info ) + pure subroutine stdlib_${ci}$hetrs_3( uplo, n, nrhs, a, lda, e, ipiv, b, ldb,info ) !! ZHETRS_3: solves a system of linear equations A * X = B with a complex !! Hermitian matrix A using the factorization computed !! by ZHETRF_RK or ZHETRF_BK: @@ -30574,15 +30576,15 @@ module stdlib_linalg_lapack_w integer(ilp), intent(in) :: lda, ldb, n, nrhs ! Array Arguments integer(ilp), intent(in) :: ipiv(*) - complex(qp), intent(in) :: a(lda,*), e(*) - complex(qp), intent(inout) :: b(ldb,*) + complex(${ck}$), intent(in) :: a(lda,*), e(*) + complex(${ck}$), intent(inout) :: b(ldb,*) ! ===================================================================== ! Local Scalars logical(lk) :: upper integer(ilp) :: i, j, k, kp - real(qp) :: s - complex(qp) :: ak, akm1, akm1k, bk, bkm1, denom + real(${ck}$) :: s + complex(${ck}$) :: ak, akm1, akm1k, bk, bkm1, denom ! Intrinsic Functions intrinsic :: abs,real,conjg,max ! Executable Statements @@ -30617,17 +30619,17 @@ module stdlib_linalg_lapack_w do k = n, 1, -1 kp = abs( ipiv( k ) ) if( kp/=k ) then - call stdlib_wswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + call stdlib_${ci}$swap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) end if end do ! compute (u \p**t * b) -> b [ (u \p**t * b) ] - call stdlib_wtrsm( 'L', 'U', 'N', 'U', n, nrhs, cone, a, lda, b, ldb ) + call stdlib_${ci}$trsm( 'L', 'U', 'N', 'U', n, nrhs, cone, a, lda, b, ldb ) ! compute d \ b -> b [ d \ (u \p**t * b) ] i = n do while ( i>=1 ) if( ipiv( i )>0 ) then - s = real( cone,KIND=qp) / real( a( i, i ),KIND=qp) - call stdlib_wdscal( nrhs, s, b( i, 1 ), ldb ) + s = real( cone,KIND=${ck}$) / real( a( i, i ),KIND=${ck}$) + call stdlib_${ci}$dscal( nrhs, s, b( i, 1 ), ldb ) else if ( i>1 ) then akm1k = e( i ) akm1 = a( i-1, i-1 ) / akm1k @@ -30644,7 +30646,7 @@ module stdlib_linalg_lapack_w i = i - 1 end do ! compute (u**h \ b) -> b [ u**h \ (d \ (u \p**t * b) ) ] - call stdlib_wtrsm( 'L', 'U', 'C', 'U', n, nrhs, cone, a, lda, b, ldb ) + call stdlib_${ci}$trsm( 'L', 'U', 'C', 'U', n, nrhs, cone, a, lda, b, ldb ) ! p * b [ p * (u**h \ (d \ (u \p**t * b) )) ] ! interchange rows k and ipiv(k) of matrix b in reverse order ! from the formation order of ipiv(i) vector for upper case. @@ -30654,7 +30656,7 @@ module stdlib_linalg_lapack_w do k = 1, n, 1 kp = abs( ipiv( k ) ) if( kp/=k ) then - call stdlib_wswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + call stdlib_${ci}$swap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) end if end do else @@ -30669,17 +30671,17 @@ module stdlib_linalg_lapack_w do k = 1, n, 1 kp = abs( ipiv( k ) ) if( kp/=k ) then - call stdlib_wswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + call stdlib_${ci}$swap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) end if end do ! compute (l \p**t * b) -> b [ (l \p**t * b) ] - call stdlib_wtrsm( 'L', 'L', 'N', 'U', n, nrhs, cone, a, lda, b, ldb ) + call stdlib_${ci}$trsm( 'L', 'L', 'N', 'U', n, nrhs, cone, a, lda, b, ldb ) ! compute d \ b -> b [ d \ (l \p**t * b) ] i = 1 do while ( i<=n ) if( ipiv( i )>0 ) then - s = real( cone,KIND=qp) / real( a( i, i ),KIND=qp) - call stdlib_wdscal( nrhs, s, b( i, 1 ), ldb ) + s = real( cone,KIND=${ck}$) / real( a( i, i ),KIND=${ck}$) + call stdlib_${ci}$dscal( nrhs, s, b( i, 1 ), ldb ) else if( i b [ l**h \ (d \ (l \p**t * b) ) ] - call stdlib_wtrsm('L', 'L', 'C', 'U', n, nrhs, cone, a, lda, b, ldb ) + call stdlib_${ci}$trsm('L', 'L', 'C', 'U', n, nrhs, cone, a, lda, b, ldb ) ! p * b [ p * (l**h \ (d \ (l \p**t * b) )) ] ! interchange rows k and ipiv(k) of matrix b in reverse order ! from the formation order of ipiv(i) vector for lower case. @@ -30706,16 +30708,16 @@ module stdlib_linalg_lapack_w do k = n, 1, -1 kp = abs( ipiv( k ) ) if( kp/=k ) then - call stdlib_wswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + call stdlib_${ci}$swap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) end if end do ! end lower end if return - end subroutine stdlib_whetrs_3 + end subroutine stdlib_${ci}$hetrs_3 - pure subroutine stdlib_whetrs_aa( uplo, n, nrhs, a, lda, ipiv, b, ldb,work, lwork, info ) + pure subroutine stdlib_${ci}$hetrs_aa( uplo, n, nrhs, a, lda, ipiv, b, ldb,work, lwork, info ) !! ZHETRS_AA: solves a system of linear equations A*X = B with a complex !! hermitian matrix A using the factorization A = U**H*T*U or !! A = L*T*L**H computed by ZHETRF_AA. @@ -30729,9 +30731,9 @@ module stdlib_linalg_lapack_w integer(ilp), intent(out) :: info ! Array Arguments integer(ilp), intent(in) :: ipiv(*) - complex(qp), intent(in) :: a(lda,*) - complex(qp), intent(inout) :: b(ldb,*) - complex(qp), intent(out) :: work(*) + complex(${ck}$), intent(in) :: a(lda,*) + complex(${ck}$), intent(inout) :: b(ldb,*) + complex(${ck}$), intent(out) :: work(*) ! ===================================================================== logical(lk) :: lquery, upper @@ -30772,30 +30774,30 @@ module stdlib_linalg_lapack_w ! pivot, p**t * b -> b do k = 1, n kp = ipiv( k ) - if( kp/=k )call stdlib_wswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib_${ci}$swap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) end do ! compute u**h \ b -> b [ (u**h \p**t * b) ] - call stdlib_wtrsm( 'L', 'U', 'C', 'U', n-1, nrhs, cone, a( 1, 2 ),lda, b( 2, 1 ),& + call stdlib_${ci}$trsm( 'L', 'U', 'C', 'U', n-1, nrhs, cone, a( 1, 2 ),lda, b( 2, 1 ),& ldb ) end if ! 2) solve with triangular matrix t ! compute t \ b -> b [ t \ (u**h \p**t * b) ] - call stdlib_wlacpy( 'F', 1, n, a(1, 1), lda+1, work(n), 1 ) + call stdlib_${ci}$lacpy( 'F', 1, n, a(1, 1), lda+1, work(n), 1 ) if( n>1 ) then - call stdlib_wlacpy( 'F', 1, n-1, a( 1, 2 ), lda+1, work( 2*n ), 1) - call stdlib_wlacpy( 'F', 1, n-1, a( 1, 2 ), lda+1, work( 1 ), 1 ) - call stdlib_wlacgv( n-1, work( 1 ), 1 ) + call stdlib_${ci}$lacpy( 'F', 1, n-1, a( 1, 2 ), lda+1, work( 2*n ), 1) + call stdlib_${ci}$lacpy( 'F', 1, n-1, a( 1, 2 ), lda+1, work( 1 ), 1 ) + call stdlib_${ci}$lacgv( n-1, work( 1 ), 1 ) end if - call stdlib_wgtsv( n, nrhs, work(1), work(n), work(2*n), b, ldb,info ) + call stdlib_${ci}$gtsv( n, nrhs, work(1), work(n), work(2*n), b, ldb,info ) ! 3) backward substitution with u if( n>1 ) then ! compute u \ b -> b [ u \ (t \ (u**h \p**t * b) ) ] - call stdlib_wtrsm( 'L', 'U', 'N', 'U', n-1, nrhs, cone, a( 1, 2 ),lda, b(2, 1), & + call stdlib_${ci}$trsm( 'L', 'U', 'N', 'U', n-1, nrhs, cone, a( 1, 2 ),lda, b(2, 1), & ldb) ! pivot, p * b [ p * (u**h \ (t \ (u \p**t * b) )) ] do k = n, 1, -1 kp = ipiv( k ) - if( kp/=k )call stdlib_wswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib_${ci}$swap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) end do end if else @@ -30805,38 +30807,38 @@ module stdlib_linalg_lapack_w ! pivot, p**t * b -> b do k = 1, n kp = ipiv( k ) - if( kp/=k )call stdlib_wswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib_${ci}$swap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) end do ! compute l \ b -> b [ (l \p**t * b) ] - call stdlib_wtrsm( 'L', 'L', 'N', 'U', n-1, nrhs, cone, a( 2, 1 ),lda, b(2, 1), & + call stdlib_${ci}$trsm( 'L', 'L', 'N', 'U', n-1, nrhs, cone, a( 2, 1 ),lda, b(2, 1), & ldb) end if ! 2) solve with triangular matrix t ! compute t \ b -> b [ t \ (l \p**t * b) ] - call stdlib_wlacpy( 'F', 1, n, a(1, 1), lda+1, work(n), 1) + call stdlib_${ci}$lacpy( 'F', 1, n, a(1, 1), lda+1, work(n), 1) if( n>1 ) then - call stdlib_wlacpy( 'F', 1, n-1, a( 2, 1 ), lda+1, work( 1 ), 1) - call stdlib_wlacpy( 'F', 1, n-1, a( 2, 1 ), lda+1, work( 2*n ), 1) - call stdlib_wlacgv( n-1, work( 2*n ), 1 ) + call stdlib_${ci}$lacpy( 'F', 1, n-1, a( 2, 1 ), lda+1, work( 1 ), 1) + call stdlib_${ci}$lacpy( 'F', 1, n-1, a( 2, 1 ), lda+1, work( 2*n ), 1) + call stdlib_${ci}$lacgv( n-1, work( 2*n ), 1 ) end if - call stdlib_wgtsv(n, nrhs, work(1), work(n), work(2*n), b, ldb,info) + call stdlib_${ci}$gtsv(n, nrhs, work(1), work(n), work(2*n), b, ldb,info) ! 3) backward substitution with l**h if( n>1 ) then ! compute l**h \ b -> b [ l**h \ (t \ (l \p**t * b) ) ] - call stdlib_wtrsm( 'L', 'L', 'C', 'U', n-1, nrhs, cone, a( 2, 1 ),lda, b( 2, 1 ),& + call stdlib_${ci}$trsm( 'L', 'L', 'C', 'U', n-1, nrhs, cone, a( 2, 1 ),lda, b( 2, 1 ),& ldb) ! pivot, p * b [ p * (l**h \ (t \ (l \p**t * b) )) ] do k = n, 1, -1 kp = ipiv( k ) - if( kp/=k )call stdlib_wswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib_${ci}$swap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) end do end if end if return - end subroutine stdlib_whetrs_aa + end subroutine stdlib_${ci}$hetrs_aa - pure subroutine stdlib_whetrs_rook( uplo, n, nrhs, a, lda, ipiv, b, ldb,info ) + pure subroutine stdlib_${ci}$hetrs_rook( uplo, n, nrhs, a, lda, ipiv, b, ldb,info ) !! ZHETRS_ROOK: solves a system of linear equations A*X = B with a complex !! Hermitian matrix A using the factorization A = U*D*U**H or !! A = L*D*L**H computed by ZHETRF_ROOK. @@ -30849,15 +30851,15 @@ module stdlib_linalg_lapack_w integer(ilp), intent(in) :: lda, ldb, n, nrhs ! Array Arguments integer(ilp), intent(in) :: ipiv(*) - complex(qp), intent(in) :: a(lda,*) - complex(qp), intent(inout) :: b(ldb,*) + complex(${ck}$), intent(in) :: a(lda,*) + complex(${ck}$), intent(inout) :: b(ldb,*) ! ===================================================================== ! Local Scalars logical(lk) :: upper integer(ilp) :: j, k, kp - real(qp) :: s - complex(qp) :: ak, akm1, akm1k, bk, bkm1, denom + real(${ck}$) :: s + complex(${ck}$) :: ak, akm1, akm1k, bk, bkm1, denom ! Intrinsic Functions intrinsic :: conjg,max,real ! Executable Statements @@ -30893,27 +30895,27 @@ module stdlib_linalg_lapack_w ! 1 x 1 diagonal block ! interchange rows k and ipiv(k). kp = ipiv( k ) - if( kp/=k )call stdlib_wswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib_${ci}$swap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) ! multiply by inv(u(k)), where u(k) is the transformation ! stored in column k of a. - call stdlib_wgeru( k-1, nrhs, -cone, a( 1, k ), 1, b( k, 1 ), ldb,b( 1, 1 ), ldb & + call stdlib_${ci}$geru( k-1, nrhs, -cone, a( 1, k ), 1, b( k, 1 ), ldb,b( 1, 1 ), ldb & ) ! multiply by the inverse of the diagonal block. - s = real( cone,KIND=qp) / real( a( k, k ),KIND=qp) - call stdlib_wdscal( nrhs, s, b( k, 1 ), ldb ) + s = real( cone,KIND=${ck}$) / real( a( k, k ),KIND=${ck}$) + call stdlib_${ci}$dscal( nrhs, s, b( k, 1 ), ldb ) k = k - 1 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_wswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib_${ci}$swap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) kp = -ipiv( k-1) - if( kp/=k-1 )call stdlib_wswap( nrhs, b( k-1, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k-1 )call stdlib_${ci}$swap( nrhs, b( k-1, 1 ), ldb, b( kp, 1 ), ldb ) ! multiply by inv(u(k)), where u(k) is the transformation ! stored in columns k-1 and k of a. - call stdlib_wgeru( k-2, nrhs, -cone, a( 1, k ), 1, b( k, 1 ), ldb,b( 1, 1 ), ldb & + call stdlib_${ci}$geru( k-2, nrhs, -cone, a( 1, k ), 1, b( k, 1 ), ldb,b( 1, 1 ), ldb & ) - call stdlib_wgeru( k-2, nrhs, -cone, a( 1, k-1 ), 1, b( k-1, 1 ),ldb, b( 1, 1 ), & + call stdlib_${ci}$geru( k-2, nrhs, -cone, a( 1, k-1 ), 1, b( k-1, 1 ),ldb, b( 1, 1 ), & ldb ) ! multiply by the inverse of the diagonal block. akm1k = a( k-1, k ) @@ -30942,34 +30944,34 @@ module stdlib_linalg_lapack_w ! multiply by inv(u**h(k)), where u(k) is the transformation ! stored in column k of a. if( k>1 ) then - call stdlib_wlacgv( nrhs, b( k, 1 ), ldb ) - call stdlib_wgemv( 'CONJUGATE TRANSPOSE', k-1, nrhs, -cone, b,ldb, a( 1, k ), & + call stdlib_${ci}$lacgv( nrhs, b( k, 1 ), ldb ) + call stdlib_${ci}$gemv( 'CONJUGATE TRANSPOSE', k-1, nrhs, -cone, b,ldb, a( 1, k ), & 1, cone, b( k, 1 ), ldb ) - call stdlib_wlacgv( nrhs, b( k, 1 ), ldb ) + call stdlib_${ci}$lacgv( nrhs, b( k, 1 ), ldb ) end if ! interchange rows k and ipiv(k). kp = ipiv( k ) - if( kp/=k )call stdlib_wswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib_${ci}$swap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) k = k + 1 else ! 2 x 2 diagonal block ! multiply by inv(u**h(k+1)), where u(k+1) is the transformation ! stored in columns k and k+1 of a. if( k>1 ) then - call stdlib_wlacgv( nrhs, b( k, 1 ), ldb ) - call stdlib_wgemv( 'CONJUGATE TRANSPOSE', k-1, nrhs, -cone, b,ldb, a( 1, k ), & + call stdlib_${ci}$lacgv( nrhs, b( k, 1 ), ldb ) + call stdlib_${ci}$gemv( 'CONJUGATE TRANSPOSE', k-1, nrhs, -cone, b,ldb, a( 1, k ), & 1, cone, b( k, 1 ), ldb ) - call stdlib_wlacgv( nrhs, b( k, 1 ), ldb ) - call stdlib_wlacgv( nrhs, b( k+1, 1 ), ldb ) - call stdlib_wgemv( 'CONJUGATE TRANSPOSE', k-1, nrhs, -cone, b,ldb, a( 1, k+1 )& + call stdlib_${ci}$lacgv( nrhs, b( k, 1 ), ldb ) + call stdlib_${ci}$lacgv( nrhs, b( k+1, 1 ), ldb ) + call stdlib_${ci}$gemv( 'CONJUGATE TRANSPOSE', k-1, nrhs, -cone, b,ldb, a( 1, k+1 )& , 1, cone, b( k+1, 1 ), ldb ) - call stdlib_wlacgv( nrhs, b( k+1, 1 ), ldb ) + call stdlib_${ci}$lacgv( nrhs, b( k+1, 1 ), ldb ) end if ! interchange rows k and -ipiv(k), then k+1 and -ipiv(k+1) kp = -ipiv( k ) - if( kp/=k )call stdlib_wswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib_${ci}$swap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) kp = -ipiv( k+1 ) - if( kp/=k+1 )call stdlib_wswap( nrhs, b( k+1, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k+1 )call stdlib_${ci}$swap( nrhs, b( k+1, 1 ), ldb, b( kp, 1 ), ldb ) k = k + 2 end if go to 40 @@ -30987,28 +30989,28 @@ module stdlib_linalg_lapack_w ! 1 x 1 diagonal block ! interchange rows k and ipiv(k). kp = ipiv( k ) - if( kp/=k )call stdlib_wswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib_${ci}$swap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) ! multiply by inv(l(k)), where l(k) is the transformation ! stored in column k of a. - if( kzero ) then - if( real( x / temp2,KIND=qp)*real( y,KIND=qp)+aimag( x / temp2 )*aimag( y )& + if( real( x / temp2,KIND=${ck}$)*real( y,KIND=${ck}$)+aimag( x / temp2 )*aimag( y )& istart ) then ctemp = h( j, j-1 ) - call stdlib_wlartg( ctemp, h( j+1, j-1 ), c, s, h( j, j-1 ) ) + call stdlib_${ci}$lartg( ctemp, h( j+1, j-1 ), c, s, h( j, j-1 ) ) h( j+1, j-1 ) = czero end if do jc = j, ilastm @@ -31779,7 +31781,7 @@ module stdlib_linalg_lapack_w end do end if ctemp = t( j+1, j+1 ) - call stdlib_wlartg( ctemp, t( j+1, j ), c, s, t( j+1, j+1 ) ) + call stdlib_${ci}$lartg( ctemp, t( j+1, j ), c, s, t( j+1, j+1 ) ) t( j+1, j ) = czero do jr = ifrstm, min( j+2, ilast ) ctemp = c*h( jr, j+1 ) + s*h( jr, j ) @@ -31814,12 +31816,12 @@ module stdlib_linalg_lapack_w signbc = conjg( t( j, j ) / absb ) t( j, j ) = absb if( ilschr ) then - call stdlib_wscal( j-1, signbc, t( 1, j ), 1 ) - call stdlib_wscal( j, signbc, h( 1, j ), 1 ) + call stdlib_${ci}$scal( j-1, signbc, t( 1, j ), 1 ) + call stdlib_${ci}$scal( j, signbc, h( 1, j ), 1 ) else - call stdlib_wscal( 1, signbc, h( j, j ), 1 ) + call stdlib_${ci}$scal( 1, signbc, h( j, j ), 1 ) end if - if( ilz )call stdlib_wscal( n, signbc, z( 1, j ), 1 ) + if( ilz )call stdlib_${ci}$scal( n, signbc, z( 1, j ), 1 ) else t( j, j ) = czero end if @@ -31830,12 +31832,12 @@ module stdlib_linalg_lapack_w info = 0 ! exit (other than argument error) -- return optimal workspace size 210 continue - work( 1 ) = cmplx( n,KIND=qp) + work( 1 ) = cmplx( n,KIND=${ck}$) return - end subroutine stdlib_whgeqz + end subroutine stdlib_${ci}$hgeqz - pure subroutine stdlib_whpcon( uplo, n, ap, ipiv, anorm, rcond, work, info ) + pure subroutine stdlib_${ci}$hpcon( uplo, n, ap, ipiv, anorm, rcond, work, info ) !! ZHPCON: estimates the reciprocal of the condition number of a complex !! Hermitian packed matrix A using the factorization A = U*D*U**H or !! A = L*D*L**H computed by ZHPTRF. @@ -31848,18 +31850,18 @@ module stdlib_linalg_lapack_w character, intent(in) :: uplo integer(ilp), intent(out) :: info integer(ilp), intent(in) :: n - real(qp), intent(in) :: anorm - real(qp), intent(out) :: rcond + real(${ck}$), intent(in) :: anorm + real(${ck}$), intent(out) :: rcond ! Array Arguments integer(ilp), intent(in) :: ipiv(*) - complex(qp), intent(in) :: ap(*) - complex(qp), intent(out) :: work(*) + complex(${ck}$), intent(in) :: ap(*) + complex(${ck}$), intent(out) :: work(*) ! ===================================================================== ! Local Scalars logical(lk) :: upper integer(ilp) :: i, ip, kase - real(qp) :: ainvnm + real(${ck}$) :: ainvnm ! Local Arrays integer(ilp) :: isave(3) ! Executable Statements @@ -31904,19 +31906,19 @@ module stdlib_linalg_lapack_w ! estimate the 1-norm of the inverse. kase = 0 30 continue - call stdlib_wlacn2( n, work( n+1 ), work, ainvnm, kase, isave ) + call stdlib_${ci}$lacn2( n, work( n+1 ), work, ainvnm, kase, isave ) if( kase/=0 ) then ! multiply by inv(l*d*l**h) or inv(u*d*u**h). - call stdlib_whptrs( uplo, n, 1, ap, ipiv, work, n, info ) + call stdlib_${ci}$hptrs( uplo, n, 1, ap, 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_whpcon + end subroutine stdlib_${ci}$hpcon - subroutine stdlib_whpev( jobz, uplo, n, ap, w, z, ldz, work, rwork,info ) + subroutine stdlib_${ci}$hpev( jobz, uplo, n, ap, w, z, ldz, work, rwork,info ) !! ZHPEV: computes all the eigenvalues and, optionally, eigenvectors of a !! complex Hermitian matrix in packed storage. ! -- lapack driver routine -- @@ -31927,15 +31929,15 @@ module stdlib_linalg_lapack_w integer(ilp), intent(out) :: info integer(ilp), intent(in) :: ldz, n ! Array Arguments - real(qp), intent(out) :: rwork(*), w(*) - complex(qp), intent(inout) :: ap(*) - complex(qp), intent(out) :: work(*), z(ldz,*) + real(${ck}$), intent(out) :: rwork(*), w(*) + complex(${ck}$), intent(inout) :: ap(*) + complex(${ck}$), intent(out) :: work(*), z(ldz,*) ! ===================================================================== ! Local Scalars logical(lk) :: wantz integer(ilp) :: iinfo, imax, inde, indrwk, indtau, indwrk, iscale - real(qp) :: anrm, bignum, eps, rmax, rmin, safmin, sigma, smlnum + real(${ck}$) :: anrm, bignum, eps, rmax, rmin, safmin, sigma, smlnum ! Intrinsic Functions intrinsic :: sqrt ! Executable Statements @@ -31959,20 +31961,20 @@ module stdlib_linalg_lapack_w ! quick return if possible if( n==0 )return if( n==1 ) then - w( 1 ) = real( ap( 1 ),KIND=qp) + w( 1 ) = real( ap( 1 ),KIND=${ck}$) rwork( 1 ) = 1 if( wantz )z( 1, 1 ) = one return end if ! get machine constants. - safmin = stdlib_qlamch( 'SAFE MINIMUM' ) - eps = stdlib_qlamch( 'PRECISION' ) + safmin = stdlib_${c2ri(ci)}$lamch( 'SAFE MINIMUM' ) + eps = stdlib_${c2ri(ci)}$lamch( 'PRECISION' ) smlnum = safmin / eps bignum = one / smlnum rmin = sqrt( smlnum ) rmax = sqrt( bignum ) ! scale matrix to allowable range, if necessary. - anrm = stdlib_wlanhp( 'M', uplo, n, ap, rwork ) + anrm = stdlib_${ci}$lanhp( 'M', uplo, n, ap, rwork ) iscale = 0 if( anrm>zero .and. anrmzero .and. anrm=real( ap( 1 ),KIND=qp) ) then + if( vl=real( ap( 1 ),KIND=${ck}$) ) then m = 1 - w( 1 ) = real( ap( 1 ),KIND=qp) + w( 1 ) = real( ap( 1 ),KIND=${ck}$) end if end if if( wantz )z( 1, 1 ) = cone return end if ! get machine constants. - safmin = stdlib_qlamch( 'SAFE MINIMUM' ) - eps = stdlib_qlamch( 'PRECISION' ) + safmin = stdlib_${c2ri(ci)}$lamch( 'SAFE MINIMUM' ) + eps = stdlib_${c2ri(ci)}$lamch( 'PRECISION' ) smlnum = safmin / eps bignum = one / smlnum rmin = sqrt( smlnum ) @@ -32253,7 +32255,7 @@ module stdlib_linalg_lapack_w vll = zero vuu = zero end if - anrm = stdlib_wlanhp( 'M', uplo, n, ap, rwork ) + anrm = stdlib_${ci}$lanhp( 'M', uplo, n, ap, rwork ) if( anrm>zero .and. anrm0 )abstll = abstol*sigma if( valeig ) then vll = vl*sigma vuu = vu*sigma end if end if - ! call stdlib_whptrd to reduce hermitian packed matrix to tridiagonal form. + ! call stdlib_${ci}$hptrd to reduce hermitian packed matrix to tridiagonal form. indd = 1 inde = indd + n indrwk = inde + n indtau = 1 indwrk = indtau + n - call stdlib_whptrd( uplo, n, ap, rwork( indd ), rwork( inde ),work( indtau ), iinfo ) + call stdlib_${ci}$hptrd( uplo, n, ap, rwork( indd ), rwork( inde ),work( indtau ), iinfo ) ! if all eigenvalues are desired and abstol is less than or equal - ! to zero, then call stdlib_qsterf or stdlib_wupgtr and stdlib_wsteqr. if this fails - ! for some eigenvalue, then try stdlib_qstebz. + ! to zero, then call stdlib_${c2ri(ci)}$sterf or stdlib_${ci}$upgtr and stdlib_${ci}$steqr. if this fails + ! for some eigenvalue, then try stdlib_${c2ri(ci)}$stebz. test = .false. if (indeig) then if (il==1 .and. iu==n) then @@ -32287,16 +32289,16 @@ module stdlib_linalg_lapack_w end if end if if ((alleig .or. test) .and. (abstol<=zero)) then - call stdlib_qcopy( n, rwork( indd ), 1, w, 1 ) + call stdlib_${c2ri(ci)}$copy( n, rwork( indd ), 1, w, 1 ) indee = indrwk + 2*n if( .not.wantz ) then - call stdlib_qcopy( n-1, rwork( inde ), 1, rwork( indee ), 1 ) - call stdlib_qsterf( n, w, rwork( indee ), info ) + call stdlib_${c2ri(ci)}$copy( n-1, rwork( inde ), 1, rwork( indee ), 1 ) + call stdlib_${c2ri(ci)}$sterf( n, w, rwork( indee ), info ) else - call stdlib_wupgtr( uplo, n, ap, work( indtau ), z, ldz,work( indwrk ), iinfo ) + call stdlib_${ci}$upgtr( uplo, n, ap, work( indtau ), z, ldz,work( indwrk ), iinfo ) - call stdlib_qcopy( n-1, rwork( inde ), 1, rwork( indee ), 1 ) - call stdlib_wsteqr( jobz, n, w, rwork( indee ), z, ldz,rwork( indrwk ), info ) + call stdlib_${c2ri(ci)}$copy( n-1, rwork( inde ), 1, rwork( indee ), 1 ) + call stdlib_${ci}$steqr( jobz, n, w, rwork( indee ), z, ldz,rwork( indrwk ), info ) if( info==0 ) then do i = 1, n @@ -32310,7 +32312,7 @@ module stdlib_linalg_lapack_w end if info = 0 end if - ! otherwise, call stdlib_qstebz and, if eigenvectors are desired, stdlib_wstein. + ! otherwise, call stdlib_${c2ri(ci)}$stebz and, if eigenvectors are desired, stdlib_${ci}$stein. if( wantz ) then order = 'B' else @@ -32319,16 +32321,16 @@ module stdlib_linalg_lapack_w indibl = 1 indisp = indibl + n indiwk = indisp + n - call stdlib_qstebz( range, order, n, vll, vuu, il, iu, abstll,rwork( indd ), rwork( & + call stdlib_${c2ri(ci)}$stebz( range, order, n, vll, vuu, il, iu, abstll,rwork( indd ), rwork( & inde ), m, nsplit, w,iwork( indibl ), iwork( indisp ), rwork( indrwk ),iwork( indiwk ),& info ) if( wantz ) then - call stdlib_wstein( n, rwork( indd ), rwork( inde ), m, w,iwork( indibl ), iwork( & + call stdlib_${ci}$stein( n, rwork( indd ), rwork( inde ), m, w,iwork( indibl ), iwork( & indisp ), z, ldz,rwork( indrwk ), iwork( indiwk ), ifail, info ) ! apply unitary matrix used in reduction to tridiagonal - ! form to eigenvectors returned by stdlib_wstein. + ! form to eigenvectors returned by stdlib_${ci}$stein. indwrk = indtau + n - call stdlib_wupmtr( 'L', uplo, 'N', n, m, ap, work( indtau ), z, ldz,work( indwrk ),& + call stdlib_${ci}$upmtr( 'L', uplo, 'N', n, m, ap, work( indtau ), z, ldz,work( indwrk ),& iinfo ) end if ! if matrix was scaled, then rescale eigenvalues appropriately. @@ -32339,7 +32341,7 @@ module stdlib_linalg_lapack_w else imax = info - 1 end if - call stdlib_qscal( imax, one / sigma, w, 1 ) + call stdlib_${c2ri(ci)}$scal( imax, one / sigma, w, 1 ) end if ! if eigenvalues are not in order, then sort them, along with ! eigenvectors. @@ -32359,7 +32361,7 @@ module stdlib_linalg_lapack_w iwork( indibl+i-1 ) = iwork( indibl+j-1 ) w( j ) = tmp1 iwork( indibl+j-1 ) = itmp1 - call stdlib_wswap( n, z( 1, i ), 1, z( 1, j ), 1 ) + call stdlib_${ci}$swap( n, z( 1, i ), 1, z( 1, j ), 1 ) if( info/=0 ) then itmp1 = ifail( i ) ifail( i ) = ifail( j ) @@ -32369,10 +32371,10 @@ module stdlib_linalg_lapack_w end do end if return - end subroutine stdlib_whpevx + end subroutine stdlib_${ci}$hpevx - pure subroutine stdlib_whpgst( itype, uplo, n, ap, bp, info ) + pure subroutine stdlib_${ci}$hpgst( itype, uplo, n, ap, bp, info ) !! ZHPGST: reduces a complex Hermitian-definite generalized !! eigenproblem to standard form, using packed storage. !! If ITYPE = 1, the problem is A*x = lambda*B*x, @@ -32388,16 +32390,16 @@ module stdlib_linalg_lapack_w integer(ilp), intent(out) :: info integer(ilp), intent(in) :: itype, n ! Array Arguments - complex(qp), intent(inout) :: ap(*) - complex(qp), intent(in) :: bp(*) + complex(${ck}$), intent(inout) :: ap(*) + complex(${ck}$), intent(in) :: bp(*) ! ===================================================================== ! Local Scalars logical(lk) :: upper integer(ilp) :: j, j1, j1j1, jj, k, k1, k1k1, kk - real(qp) :: ajj, akk, bjj, bkk - complex(qp) :: ct + real(${ck}$) :: ajj, akk, bjj, bkk + complex(${ck}$) :: ct ! Intrinsic Functions intrinsic :: real ! Executable Statements @@ -32424,14 +32426,14 @@ module stdlib_linalg_lapack_w j1 = jj + 1 jj = jj + j ! compute the j-th column of the upper triangle of a - ap( jj ) = real( ap( jj ),KIND=qp) - bjj = real( bp( jj ),KIND=qp) - call stdlib_wtpsv( uplo, 'CONJUGATE TRANSPOSE', 'NON-UNIT', j,bp, ap( j1 ), 1 & + ap( jj ) = real( ap( jj ),KIND=${ck}$) + bjj = real( bp( jj ),KIND=${ck}$) + call stdlib_${ci}$tpsv( uplo, 'CONJUGATE TRANSPOSE', 'NON-UNIT', j,bp, ap( j1 ), 1 & ) - call stdlib_whpmv( uplo, j-1, -cone, ap, bp( j1 ), 1, cone,ap( j1 ), 1 ) + call stdlib_${ci}$hpmv( uplo, j-1, -cone, ap, bp( j1 ), 1, cone,ap( j1 ), 1 ) - call stdlib_wdscal( j-1, one / bjj, ap( j1 ), 1 ) - ap( jj ) = ( ap( jj )-stdlib_wdotc( j-1, ap( j1 ), 1, bp( j1 ),1 ) ) / & + call stdlib_${ci}$dscal( j-1, one / bjj, ap( j1 ), 1 ) + ap( jj ) = ( ap( jj )-stdlib_${ci}$dotc( j-1, ap( j1 ), 1, bp( j1 ),1 ) ) / & bjj end do else @@ -32441,18 +32443,18 @@ module stdlib_linalg_lapack_w do k = 1, n k1k1 = kk + n - k + 1 ! update the lower triangle of a(k:n,k:n) - akk = real( ap( kk ),KIND=qp) - bkk = real( bp( kk ),KIND=qp) + akk = real( ap( kk ),KIND=${ck}$) + bkk = real( bp( kk ),KIND=${ck}$) akk = akk / bkk**2 ap( kk ) = akk if( keps .and. two*berr( j )<=lstres .and.count<=itmax ) then ! update solution and try again. - call stdlib_whptrs( uplo, n, 1, afp, ipiv, work, n, info ) - call stdlib_waxpy( n, cone, work, 1, x( 1, j ), 1 ) + call stdlib_${ci}$hptrs( uplo, n, 1, afp, ipiv, work, n, info ) + call stdlib_${ci}$axpy( n, cone, work, 1, x( 1, j ), 1 ) lstres = berr( j ) count = count + 1 go to 20 @@ -32988,7 +32990,7 @@ module stdlib_linalg_lapack_w ! 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_wlacn2 to estimate the infinity-norm of the matrix + ! 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 @@ -33000,11 +33002,11 @@ module stdlib_linalg_lapack_w end do kase = 0 100 continue - call stdlib_wlacn2( n, work( n+1 ), work, ferr( j ), kase, isave ) + call stdlib_${ci}$lacn2( n, work( n+1 ), work, ferr( j ), kase, isave ) if( kase/=0 ) then if( kase==1 ) then ! multiply by diag(w)*inv(a**h). - call stdlib_whptrs( uplo, n, 1, afp, ipiv, work, n, info ) + call stdlib_${ci}$hptrs( uplo, n, 1, afp, ipiv, work, n, info ) do i = 1, n work( i ) = rwork( i )*work( i ) end do @@ -33013,7 +33015,7 @@ module stdlib_linalg_lapack_w do i = 1, n work( i ) = rwork( i )*work( i ) end do - call stdlib_whptrs( uplo, n, 1, afp, ipiv, work, n, info ) + call stdlib_${ci}$hptrs( uplo, n, 1, afp, ipiv, work, n, info ) end if go to 100 end if @@ -33025,10 +33027,10 @@ module stdlib_linalg_lapack_w if( lstres/=zero )ferr( j ) = ferr( j ) / lstres end do loop_140 return - end subroutine stdlib_whprfs + end subroutine stdlib_${ci}$hprfs - pure subroutine stdlib_whpsv( uplo, n, nrhs, ap, ipiv, b, ldb, info ) + pure subroutine stdlib_${ci}$hpsv( uplo, n, nrhs, ap, ipiv, b, ldb, info ) !! ZHPSV: computes the solution to a complex system of linear equations !! A * X = B, !! where A is an N-by-N Hermitian matrix stored in packed format and X @@ -33049,7 +33051,7 @@ module stdlib_linalg_lapack_w integer(ilp), intent(in) :: ldb, n, nrhs ! Array Arguments integer(ilp), intent(out) :: ipiv(*) - complex(qp), intent(inout) :: ap(*), b(ldb,*) + complex(${ck}$), intent(inout) :: ap(*), b(ldb,*) ! ===================================================================== ! Intrinsic Functions intrinsic :: max @@ -33070,16 +33072,16 @@ module stdlib_linalg_lapack_w return end if ! compute the factorization a = u*d*u**h or a = l*d*l**h. - call stdlib_whptrf( uplo, n, ap, ipiv, info ) + call stdlib_${ci}$hptrf( uplo, n, ap, ipiv, info ) if( info==0 ) then ! solve the system a*x = b, overwriting b with x. - call stdlib_whptrs( uplo, n, nrhs, ap, ipiv, b, ldb, info ) + call stdlib_${ci}$hptrs( uplo, n, nrhs, ap, ipiv, b, ldb, info ) end if return - end subroutine stdlib_whpsv + end subroutine stdlib_${ci}$hpsv - subroutine stdlib_whpsvx( fact, uplo, n, nrhs, ap, afp, ipiv, b, ldb, x,ldx, rcond, ferr, & + subroutine stdlib_${ci}$hpsvx( fact, uplo, n, nrhs, ap, afp, ipiv, b, ldb, x,ldx, rcond, ferr, & !! ZHPSVX: uses the diagonal pivoting factorization A = U*D*U**H or !! A = L*D*L**H to compute the solution to a complex system of linear !! equations A * X = B, where A is an N-by-N Hermitian matrix stored @@ -33094,18 +33096,18 @@ module stdlib_linalg_lapack_w character, intent(in) :: fact, uplo integer(ilp), intent(out) :: info integer(ilp), intent(in) :: ldb, ldx, n, nrhs - real(qp), intent(out) :: rcond + real(${ck}$), intent(out) :: rcond ! Array Arguments integer(ilp), intent(inout) :: ipiv(*) - real(qp), intent(out) :: berr(*), ferr(*), rwork(*) - complex(qp), intent(inout) :: afp(*) - complex(qp), intent(in) :: ap(*), b(ldb,*) - complex(qp), intent(out) :: work(*), x(ldx,*) + real(${ck}$), intent(out) :: berr(*), ferr(*), rwork(*) + complex(${ck}$), intent(inout) :: afp(*) + complex(${ck}$), intent(in) :: ap(*), b(ldb,*) + complex(${ck}$), intent(out) :: work(*), x(ldx,*) ! ===================================================================== ! Local Scalars logical(lk) :: nofact - real(qp) :: anorm + real(${ck}$) :: anorm ! Intrinsic Functions intrinsic :: max ! Executable Statements @@ -33132,8 +33134,8 @@ module stdlib_linalg_lapack_w end if if( nofact ) then ! compute the factorization a = u*d*u**h or a = l*d*l**h. - call stdlib_wcopy( n*( n+1 ) / 2, ap, 1, afp, 1 ) - call stdlib_whptrf( uplo, n, afp, ipiv, info ) + call stdlib_${ci}$copy( n*( n+1 ) / 2, ap, 1, afp, 1 ) + call stdlib_${ci}$hptrf( uplo, n, afp, ipiv, info ) ! return if info is non-zero. if( info>0 )then rcond = zero @@ -33141,23 +33143,23 @@ module stdlib_linalg_lapack_w end if end if ! compute the norm of the matrix a. - anorm = stdlib_wlanhp( 'I', uplo, n, ap, rwork ) + anorm = stdlib_${ci}$lanhp( 'I', uplo, n, ap, rwork ) ! compute the reciprocal of the condition number of a. - call stdlib_whpcon( uplo, n, afp, ipiv, anorm, rcond, work, info ) + call stdlib_${ci}$hpcon( uplo, n, afp, ipiv, anorm, rcond, work, info ) ! compute the solution vectors x. - call stdlib_wlacpy( 'FULL', n, nrhs, b, ldb, x, ldx ) - call stdlib_whptrs( uplo, n, nrhs, afp, ipiv, x, ldx, info ) + call stdlib_${ci}$lacpy( 'FULL', n, nrhs, b, ldb, x, ldx ) + call stdlib_${ci}$hptrs( uplo, n, nrhs, afp, ipiv, x, ldx, info ) ! use iterative refinement to improve the computed solutions and ! compute error bounds and backward error estimates for them. - call stdlib_whprfs( uplo, n, nrhs, ap, afp, ipiv, b, ldb, x, ldx, ferr,berr, work, & + call stdlib_${ci}$hprfs( uplo, n, nrhs, ap, afp, ipiv, b, ldb, x, ldx, ferr,berr, work, & rwork, info ) ! set info = n+1 if the matrix is singular to working precision. - if( rcond1 ) then - imax = stdlib_iwamax( k-1, ap( kc ), 1 ) + imax = stdlib_i${ci}$amax( k-1, ap( kc ), 1 ) colmax = cabs1( ap( kc+imax-1 ) ) else colmax = zero @@ -33335,7 +33337,7 @@ module stdlib_linalg_lapack_w ! column k is zero: set info and continue if( info==0 )info = k kp = k - ap( kc+k-1 ) = real( ap( kc+k-1 ),KIND=qp) + ap( kc+k-1 ) = real( ap( kc+k-1 ),KIND=${ck}$) else if( absakk>=alpha*colmax ) then ! no interchange, use 1-by-1 pivot block @@ -33355,13 +33357,13 @@ module stdlib_linalg_lapack_w end do kpc = ( imax-1 )*imax / 2 + 1 if( imax>1 ) then - jmax = stdlib_iwamax( imax-1, ap( kpc ), 1 ) + jmax = stdlib_i${ci}$amax( imax-1, ap( kpc ), 1 ) rowmax = max( rowmax, cabs1( ap( kpc+jmax-1 ) ) ) end if if( absakk>=alpha*colmax*( colmax / rowmax ) ) then ! no interchange, use 1-by-1 pivot block kp = k - else if( abs( real( ap( kpc+imax-1 ),KIND=qp) )>=alpha*rowmax ) then + else if( abs( real( ap( kpc+imax-1 ),KIND=${ck}$) )>=alpha*rowmax ) then ! interchange rows and columns k and imax, use 1-by-1 ! pivot block kp = imax @@ -33377,7 +33379,7 @@ module stdlib_linalg_lapack_w if( kp/=kk ) then ! interchange rows and columns kk and kp in the leading ! submatrix a(1:k,1:k) - call stdlib_wswap( kp-1, ap( knc ), 1, ap( kpc ), 1 ) + call stdlib_${ci}$swap( kp-1, ap( knc ), 1, ap( kpc ), 1 ) kx = kpc + kp - 1 do j = kp + 1, kk - 1 kx = kx + j - 1 @@ -33386,18 +33388,18 @@ module stdlib_linalg_lapack_w ap( kx ) = t end do ap( kx+kk-1 ) = conjg( ap( kx+kk-1 ) ) - r1 = real( ap( knc+kk-1 ),KIND=qp) - ap( knc+kk-1 ) = real( ap( kpc+kp-1 ),KIND=qp) + r1 = real( ap( knc+kk-1 ),KIND=${ck}$) + ap( knc+kk-1 ) = real( ap( kpc+kp-1 ),KIND=${ck}$) ap( kpc+kp-1 ) = r1 if( kstep==2 ) then - ap( kc+k-1 ) = real( ap( kc+k-1 ),KIND=qp) + ap( kc+k-1 ) = real( ap( kc+k-1 ),KIND=${ck}$) t = ap( kc+k-2 ) ap( kc+k-2 ) = ap( kc+kp-1 ) ap( kc+kp-1 ) = t end if else - ap( kc+k-1 ) = real( ap( kc+k-1 ),KIND=qp) - if( kstep==2 )ap( kc-1 ) = real( ap( kc-1 ),KIND=qp) + ap( kc+k-1 ) = real( ap( kc+k-1 ),KIND=${ck}$) + if( kstep==2 )ap( kc-1 ) = real( ap( kc-1 ),KIND=${ck}$) end if ! update the leading submatrix if( kstep==1 ) then @@ -33406,10 +33408,10 @@ module stdlib_linalg_lapack_w ! where u(k) is the k-th column of u ! perform a rank-1 update of a(1:k-1,1:k-1) as ! a := a - u(k)*d(k)*u(k)**h = a - w(k)*1/d(k)*w(k)**h - r1 = one / real( ap( kc+k-1 ),KIND=qp) - call stdlib_whpr( uplo, k-1, -r1, ap( kc ), 1, ap ) + r1 = one / real( ap( kc+k-1 ),KIND=${ck}$) + call stdlib_${ci}$hpr( uplo, k-1, -r1, ap( kc ), 1, ap ) ! store u(k) in column k - call stdlib_wdscal( k-1, r1, ap( kc ), 1 ) + call stdlib_${ci}$dscal( k-1, r1, ap( kc ), 1 ) 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) @@ -33419,10 +33421,10 @@ module stdlib_linalg_lapack_w ! a := a - ( u(k-1) u(k) )*d(k)*( u(k-1) u(k) )**h ! = a - ( w(k-1) w(k) )*inv(d(k))*( w(k-1) w(k) )**h if( k>2 ) then - d = stdlib_qlapy2( real( ap( k-1+( k-1 )*k / 2 ),KIND=qp),aimag( ap( k-1+( & + d = stdlib_${c2ri(ci)}$lapy2( real( ap( k-1+( k-1 )*k / 2 ),KIND=${ck}$),aimag( ap( k-1+( & k-1 )*k / 2 ) ) ) - d22 = real( ap( k-1+( k-2 )*( k-1 ) / 2 ),KIND=qp) / d - d11 = real( ap( k+( k-1 )*k / 2 ),KIND=qp) / d + d22 = real( ap( k-1+( k-2 )*( k-1 ) / 2 ),KIND=${ck}$) / d + d11 = real( ap( k+( k-1 )*k / 2 ),KIND=${ck}$) / d tt = one / ( d11*d22-one ) d12 = ap( k-1+( k-1 )*k / 2 ) / d d = tt / d @@ -33437,8 +33439,8 @@ module stdlib_linalg_lapack_w end do ap( j+( k-1 )*k / 2 ) = wk ap( j+( k-2 )*( k-1 ) / 2 ) = wkm1 - ap( j+( j-1 )*j / 2 ) = cmplx( real( ap( j+( j-1 )*j / 2 ),KIND=qp), & - zero,KIND=qp) + ap( j+( j-1 )*j / 2 ) = cmplx( real( ap( j+( j-1 )*j / 2 ),KIND=${ck}$), & + zero,KIND=${ck}$) end do end if end if @@ -33468,11 +33470,11 @@ module stdlib_linalg_lapack_w kstep = 1 ! determine rows and columns to be interchanged and whether ! a 1-by-1 or 2-by-2 pivot block will be used - absakk = abs( real( ap( kc ),KIND=qp) ) + absakk = abs( real( ap( kc ),KIND=${ck}$) ) ! imax is the row-index of the largest off-diagonal element in ! column k, and colmax is its absolute value if( k=alpha*colmax ) then ! no interchange, use 1-by-1 pivot block @@ -33500,13 +33502,13 @@ module stdlib_linalg_lapack_w end do kpc = npp - ( n-imax+1 )*( n-imax+2 ) / 2 + 1 if( imax=alpha*colmax*( colmax / rowmax ) ) then ! no interchange, use 1-by-1 pivot block kp = k - else if( abs( real( ap( kpc ),KIND=qp) )>=alpha*rowmax ) then + else if( abs( real( ap( kpc ),KIND=${ck}$) )>=alpha*rowmax ) then ! interchange rows and columns k and imax, use 1-by-1 ! pivot block kp = imax @@ -33522,7 +33524,7 @@ module stdlib_linalg_lapack_w if( kp/=kk ) then ! interchange rows and columns kk and kp in the trailing ! submatrix a(k:n,k:n) - if( kp0 ) then ! 1 x 1 diagonal block ! invert the diagonal block. - ap( kc+k-1 ) = one / real( ap( kc+k-1 ),KIND=qp) + ap( kc+k-1 ) = one / real( ap( kc+k-1 ),KIND=${ck}$) ! compute column k of the inverse. if( k>1 ) then - call stdlib_wcopy( k-1, ap( kc ), 1, work, 1 ) - call stdlib_whpmv( uplo, k-1, -cone, ap, work, 1, czero,ap( kc ), 1 ) - ap( kc+k-1 ) = ap( kc+k-1 ) -real( stdlib_wdotc( k-1, work, 1, ap( kc ), 1 ),& - KIND=qp) + call stdlib_${ci}$copy( k-1, ap( kc ), 1, work, 1 ) + call stdlib_${ci}$hpmv( uplo, k-1, -cone, ap, work, 1, czero,ap( kc ), 1 ) + ap( kc+k-1 ) = ap( kc+k-1 ) -real( stdlib_${ci}$dotc( k-1, work, 1, ap( kc ), 1 ),& + KIND=${ck}$) end if kstep = 1 else ! 2 x 2 diagonal block ! invert the diagonal block. t = abs( ap( kcnext+k-1 ) ) - ak = real( ap( kc+k-1 ),KIND=qp) / t - akp1 = real( ap( kcnext+k ),KIND=qp) / t + ak = real( ap( kc+k-1 ),KIND=${ck}$) / t + akp1 = real( ap( kcnext+k ),KIND=${ck}$) / t akkp1 = ap( kcnext+k-1 ) / t d = t*( ak*akp1-one ) ap( kc+k-1 ) = akp1 / d @@ -33703,17 +33705,17 @@ module stdlib_linalg_lapack_w ap( kcnext+k-1 ) = -akkp1 / d ! compute columns k and k+1 of the inverse. if( k>1 ) then - call stdlib_wcopy( k-1, ap( kc ), 1, work, 1 ) - call stdlib_whpmv( uplo, k-1, -cone, ap, work, 1, czero,ap( kc ), 1 ) - ap( kc+k-1 ) = ap( kc+k-1 ) -real( stdlib_wdotc( k-1, work, 1, ap( kc ), 1 ),& - KIND=qp) - ap( kcnext+k-1 ) = ap( kcnext+k-1 ) -stdlib_wdotc( k-1, ap( kc ), 1, ap( & + call stdlib_${ci}$copy( k-1, ap( kc ), 1, work, 1 ) + call stdlib_${ci}$hpmv( uplo, k-1, -cone, ap, work, 1, czero,ap( kc ), 1 ) + ap( kc+k-1 ) = ap( kc+k-1 ) -real( stdlib_${ci}$dotc( k-1, work, 1, ap( kc ), 1 ),& + KIND=${ck}$) + ap( kcnext+k-1 ) = ap( kcnext+k-1 ) -stdlib_${ci}$dotc( k-1, ap( kc ), 1, ap( & kcnext ),1 ) - call stdlib_wcopy( k-1, ap( kcnext ), 1, work, 1 ) - call stdlib_whpmv( uplo, k-1, -cone, ap, work, 1, czero,ap( kcnext ), 1 ) + call stdlib_${ci}$copy( k-1, ap( kcnext ), 1, work, 1 ) + call stdlib_${ci}$hpmv( uplo, k-1, -cone, ap, work, 1, czero,ap( kcnext ), 1 ) - ap( kcnext+k ) = ap( kcnext+k ) -real( stdlib_wdotc( k-1, work, 1, ap( kcnext & - ),1 ),KIND=qp) + ap( kcnext+k ) = ap( kcnext+k ) -real( stdlib_${ci}$dotc( k-1, work, 1, ap( kcnext & + ),1 ),KIND=${ck}$) end if kstep = 2 kcnext = kcnext + k + 1 @@ -33723,7 +33725,7 @@ module stdlib_linalg_lapack_w ! interchange rows and columns k and kp in the leading ! submatrix a(1:k+1,1:k+1) kpc = ( kp-1 )*kp / 2 + 1 - call stdlib_wswap( kp-1, ap( kc ), 1, ap( kpc ), 1 ) + call stdlib_${ci}$swap( kp-1, ap( kc ), 1, ap( kpc ), 1 ) kx = kpc + kp - 1 do j = kp + 1, k - 1 kx = kx + j - 1 @@ -33759,22 +33761,22 @@ module stdlib_linalg_lapack_w if( ipiv( k )>0 ) then ! 1 x 1 diagonal block ! invert the diagonal block. - ap( kc ) = one / real( ap( kc ),KIND=qp) + ap( kc ) = one / real( ap( kc ),KIND=${ck}$) ! compute column k of the inverse. if( k1 ) then - call stdlib_wlacgv( nrhs, b( k, 1 ), ldb ) - call stdlib_wgemv( 'CONJUGATE TRANSPOSE', k-1, nrhs, -cone, b,ldb, ap( kc ), & + call stdlib_${ci}$lacgv( nrhs, b( k, 1 ), ldb ) + call stdlib_${ci}$gemv( 'CONJUGATE TRANSPOSE', k-1, nrhs, -cone, b,ldb, ap( kc ), & 1, cone, b( k, 1 ), ldb ) - call stdlib_wlacgv( nrhs, b( k, 1 ), ldb ) + call stdlib_${ci}$lacgv( nrhs, b( k, 1 ), ldb ) end if ! interchange rows k and ipiv(k). kp = ipiv( k ) - if( kp/=k )call stdlib_wswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib_${ci}$swap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) kc = kc + k k = k + 1 else @@ -33951,18 +33953,18 @@ module stdlib_linalg_lapack_w ! multiply by inv(u**h(k+1)), where u(k+1) is the transformation ! stored in columns k and k+1 of a. if( k>1 ) then - call stdlib_wlacgv( nrhs, b( k, 1 ), ldb ) - call stdlib_wgemv( 'CONJUGATE TRANSPOSE', k-1, nrhs, -cone, b,ldb, ap( kc ), & + call stdlib_${ci}$lacgv( nrhs, b( k, 1 ), ldb ) + call stdlib_${ci}$gemv( 'CONJUGATE TRANSPOSE', k-1, nrhs, -cone, b,ldb, ap( kc ), & 1, cone, b( k, 1 ), ldb ) - call stdlib_wlacgv( nrhs, b( k, 1 ), ldb ) - call stdlib_wlacgv( nrhs, b( k+1, 1 ), ldb ) - call stdlib_wgemv( 'CONJUGATE TRANSPOSE', k-1, nrhs, -cone, b,ldb, ap( kc+k ),& + call stdlib_${ci}$lacgv( nrhs, b( k, 1 ), ldb ) + call stdlib_${ci}$lacgv( nrhs, b( k+1, 1 ), ldb ) + call stdlib_${ci}$gemv( 'CONJUGATE TRANSPOSE', k-1, nrhs, -cone, b,ldb, ap( kc+k ),& 1, cone, b( k+1, 1 ), ldb ) - call stdlib_wlacgv( nrhs, b( k+1, 1 ), ldb ) + call stdlib_${ci}$lacgv( nrhs, b( k+1, 1 ), ldb ) end if ! interchange rows k and -ipiv(k). kp = -ipiv( k ) - if( kp/=k )call stdlib_wswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib_${ci}$swap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) kc = kc + 2*k + 1 k = k + 2 end if @@ -33982,27 +33984,27 @@ module stdlib_linalg_lapack_w ! 1 x 1 diagonal block ! interchange rows k and ipiv(k). kp = ipiv( k ) - if( kp/=k )call stdlib_wswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib_${ci}$swap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) ! multiply by inv(l(k)), where l(k) is the transformation ! stored in column k of a. - if( krzero ) then @@ -34212,7 +34214,7 @@ module stdlib_linalg_lapack_w w( k ) = wk if( leftv ) then ! compute left eigenvector. - call stdlib_wlaein( .false., noinit, n-kl+1, h( kl, kl ), ldh,wk, vl( kl, ks )& + call stdlib_${ci}$laein( .false., noinit, n-kl+1, h( kl, kl ), ldh,wk, vl( kl, ks )& , work, ldwork, rwork, eps3,smlnum, iinfo ) if( iinfo>0 ) then info = info + 1 @@ -34226,7 +34228,7 @@ module stdlib_linalg_lapack_w end if if( rightv ) then ! compute right eigenvector. - call stdlib_wlaein( .true., noinit, kr, h, ldh, wk, vr( 1, ks ),work, ldwork, & + call stdlib_${ci}$laein( .true., noinit, kr, h, ldh, wk, vr( 1, ks ),work, ldwork, & rwork, eps3, smlnum, iinfo ) if( iinfo>0 ) then info = info + 1 @@ -34242,10 +34244,10 @@ module stdlib_linalg_lapack_w end if end do loop_100 return - end subroutine stdlib_whsein + end subroutine stdlib_${ci}$hsein - pure subroutine stdlib_whseqr( job, compz, n, ilo, ihi, h, ldh, w, z, ldz,work, lwork, info ) + pure subroutine stdlib_${ci}$hseqr( job, compz, n, ilo, ihi, h, ldh, w, z, ldz,work, lwork, info ) !! ZHSEQR: computes the eigenvalues of a Hessenberg matrix H !! and, optionally, the matrices T and Z from the Schur decomposition !! H = Z T Z**H, where T is an upper triangular matrix (the @@ -34263,19 +34265,19 @@ module stdlib_linalg_lapack_w integer(ilp), intent(out) :: info character, intent(in) :: compz, job ! Array Arguments - complex(qp), intent(inout) :: h(ldh,*), z(ldz,*) - complex(qp), intent(out) :: w(*), work(*) + complex(${ck}$), intent(inout) :: h(ldh,*), z(ldz,*) + complex(${ck}$), intent(out) :: w(*), work(*) ! ===================================================================== ! Parameters integer(ilp), parameter :: ntiny = 15 integer(ilp), parameter :: nl = 49 - real(qp), parameter :: rzero = 0.0_qp + real(${ck}$), parameter :: rzero = 0.0_${ck}$ ! ==== matrices of order ntiny or smaller must be processed by - ! . stdlib_wlahqr because of insufficient subdiagonal scratch space. + ! . stdlib_${ci}$lahqr because of insufficient subdiagonal scratch space. ! . (this is a hard limit.) ==== ! ==== nl allocates some local workspace to help small matrices - ! . through a rare stdlib_wlahqr failure. nl > ntiny = 15 is + ! . through a rare stdlib_${ci}$lahqr failure. nl > ntiny = 15 is ! . required and nl <= nmin = stdlib_ilaenv(ispec=12,...) is recom- ! . mended. (the default value of nmin is 75.) using nl = 49 ! . allows up to six simultaneous shifts and a 16-by-16 @@ -34284,7 +34286,7 @@ module stdlib_linalg_lapack_w ! Local Arrays - complex(qp) :: hl(nl,nl), workl(nl) + complex(${ck}$) :: hl(nl,nl), workl(nl) ! Local Scalars integer(ilp) :: kbot, nmin logical(lk) :: initz, lquery, wantt, wantz @@ -34295,7 +34297,7 @@ module stdlib_linalg_lapack_w wantt = stdlib_lsame( job, 'S' ) initz = stdlib_lsame( compz, 'I' ) wantz = initz .or. stdlib_lsame( compz, 'V' ) - work( 1 ) = cmplx( real( max( 1, n ),KIND=qp), rzero,KIND=qp) + work( 1 ) = cmplx( real( max( 1, n ),KIND=${ck}$), rzero,KIND=${ck}$) lquery = lwork==-1 info = 0 if( .not.stdlib_lsame( job, 'E' ) .and. .not.wantt ) then @@ -34324,73 +34326,73 @@ module stdlib_linalg_lapack_w return else if( lquery ) then ! ==== quick return in case of a workspace query ==== - call stdlib_wlaqr0( wantt, wantz, n, ilo, ihi, h, ldh, w, ilo, ihi, z,ldz, work, & + call stdlib_${ci}$laqr0( wantt, wantz, n, ilo, ihi, h, ldh, w, ilo, ihi, z,ldz, work, & lwork, info ) ! ==== ensure reported workspace size is backward-compatible with ! . previous lapack versions. ==== - work( 1 ) = cmplx( max( real( work( 1 ),KIND=qp), real( max( 1,n ),KIND=qp) ), & - rzero,KIND=qp) + work( 1 ) = cmplx( max( real( work( 1 ),KIND=${ck}$), real( max( 1,n ),KIND=${ck}$) ), & + rzero,KIND=${ck}$) return else - ! ==== copy eigenvalues isolated by stdlib_wgebal ==== - if( ilo>1 )call stdlib_wcopy( ilo-1, h, ldh+1, w, 1 ) - if( ihi1 )call stdlib_${ci}$copy( ilo-1, h, ldh+1, w, 1 ) + if( ihinmin ) then - call stdlib_wlaqr0( wantt, wantz, n, ilo, ihi, h, ldh, w, ilo, ihi,z, ldz, work, & + call stdlib_${ci}$laqr0( wantt, wantz, n, ilo, ihi, h, ldh, w, ilo, ihi,z, ldz, work, & lwork, info ) else ! ==== small matrix ==== - call stdlib_wlahqr( wantt, wantz, n, ilo, ihi, h, ldh, w, ilo, ihi,z, ldz, info ) + call stdlib_${ci}$lahqr( wantt, wantz, n, ilo, ihi, h, ldh, w, ilo, ihi,z, ldz, info ) if( info>0 ) then - ! ==== a rare stdlib_wlahqr failure! stdlib_wlaqr0 sometimes succeeds - ! . when stdlib_wlahqr fails. ==== + ! ==== a rare stdlib_${ci}$lahqr failure! stdlib_${ci}$laqr0 sometimes succeeds + ! . when stdlib_${ci}$lahqr fails. ==== kbot = info if( n>=nl ) then ! ==== larger matrices have enough subdiagonal scratch - ! . space to call stdlib_wlaqr0 directly. ==== - call stdlib_wlaqr0( wantt, wantz, n, ilo, kbot, h, ldh, w,ilo, ihi, z, ldz,& + ! . space to call stdlib_${ci}$laqr0 directly. ==== + call stdlib_${ci}$laqr0( wantt, wantz, n, ilo, kbot, h, ldh, w,ilo, ihi, z, ldz,& work, lwork, info ) else ! ==== tiny matrices don't have enough subdiagonal - ! . scratch space to benefit from stdlib_wlaqr0. hence, + ! . scratch space to benefit from stdlib_${ci}$laqr0. hence, ! . tiny matrices must be copied into a larger - ! . array before calling stdlib_wlaqr0. ==== - call stdlib_wlacpy( 'A', n, n, h, ldh, hl, nl ) + ! . array before calling stdlib_${ci}$laqr0. ==== + call stdlib_${ci}$lacpy( 'A', n, n, h, ldh, hl, nl ) hl( n+1, n ) = czero - call stdlib_wlaset( 'A', nl, nl-n, czero, czero, hl( 1, n+1 ),nl ) - call stdlib_wlaqr0( wantt, wantz, nl, ilo, kbot, hl, nl, w,ilo, ihi, z, & + call stdlib_${ci}$laset( 'A', nl, nl-n, czero, czero, hl( 1, n+1 ),nl ) + call stdlib_${ci}$laqr0( wantt, wantz, nl, ilo, kbot, hl, nl, w,ilo, ihi, z, & ldz, workl, nl, info ) - if( wantt .or. info/=0 )call stdlib_wlacpy( 'A', n, n, hl, nl, h, ldh ) + if( wantt .or. info/=0 )call stdlib_${ci}$lacpy( 'A', n, n, hl, nl, h, ldh ) end if end if end if ! ==== clear out the trash, if necessary. ==== - if( ( wantt .or. info/=0 ) .and. n>2 )call stdlib_wlaset( 'L', n-2, n-2, czero, & + if( ( wantt .or. info/=0 ) .and. n>2 )call stdlib_${ci}$laset( 'L', n-2, n-2, czero, & czero, h( 3, 1 ), ldh ) ! ==== ensure reported workspace size is backward-compatible with ! . previous lapack versions. ==== - work( 1 ) = cmplx( max( real( max( 1, n ),KIND=qp),real( work( 1 ),KIND=qp) ), & - rzero,KIND=qp) + work( 1 ) = cmplx( max( real( max( 1, n ),KIND=${ck}$),real( work( 1 ),KIND=${ck}$) ), & + rzero,KIND=${ck}$) end if - end subroutine stdlib_whseqr + end subroutine stdlib_${ci}$hseqr - subroutine stdlib_wla_gbamv( trans, m, n, kl, ku, alpha, ab, ldab, x,incx, beta, y, incy ) + subroutine stdlib_${ci}$la_gbamv( trans, m, n, kl, ku, alpha, ab, ldab, x,incx, beta, y, incy ) !! ZLA_GBAMV: performs one of the matrix-vector operations !! y := alpha*abs(A)*abs(x) + beta*abs(y), !! or y := alpha*abs(A)**T*abs(x) + beta*abs(y), @@ -34409,24 +34411,24 @@ module stdlib_linalg_lapack_w ! -- lapack is a software package provided by univ. of tennessee, -- ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments - real(qp), intent(in) :: alpha, beta + real(${ck}$), intent(in) :: alpha, beta integer(ilp), intent(in) :: incx, incy, ldab, m, n, kl, ku, trans ! Array Arguments - complex(qp), intent(in) :: ab(ldab,*), x(*) - real(qp), intent(inout) :: y(*) + complex(${ck}$), intent(in) :: ab(ldab,*), x(*) + real(${ck}$), intent(inout) :: y(*) ! ===================================================================== ! Local Scalars logical(lk) :: symb_wero - real(qp) :: temp, safe1 + real(${ck}$) :: temp, safe1 integer(ilp) :: i, info, iy, j, jx, kx, ky, lenx, leny, kd, ke - complex(qp) :: cdum + complex(${ck}$) :: cdum ! Intrinsic Functions intrinsic :: max,abs,real,aimag,sign ! Statement Functions - real(qp) :: cabs1 + real(${ck}$) :: cabs1 ! Statement Function Definitions - cabs1( cdum ) = abs( real( cdum,KIND=qp) ) + abs( aimag( cdum ) ) + cabs1( cdum ) = abs( real( cdum,KIND=${ck}$) ) + abs( aimag( cdum ) ) ! Executable Statements ! test the input parameters. info = 0 @@ -34475,7 +34477,7 @@ module stdlib_linalg_lapack_w end if ! set safe1 essentially to be the underflow threshold times the ! number of additions in each row. - safe1 = stdlib_qlamch( 'SAFE MINIMUM' ) + safe1 = stdlib_${c2ri(ci)}$lamch( 'SAFE MINIMUM' ) safe1 = (n+1)*safe1 ! form y := alpha*abs(a)*abs(x) + beta*abs(y). ! the o(m*n) symb_wero tests could be replaced by o(n) queries to @@ -34582,10 +34584,10 @@ module stdlib_linalg_lapack_w end if end if return - end subroutine stdlib_wla_gbamv + end subroutine stdlib_${ci}$la_gbamv - real(qp) function stdlib_wla_gbrcond_c( trans, n, kl, ku, ab,ldab, afb, ldafb, ipiv,c, & + real(${ck}$) function stdlib_${ci}$la_gbrcond_c( trans, n, kl, ku, ab,ldab, afb, ldafb, ipiv,c, & !! ZLA_GBRCOND_C: Computes the infinity norm condition number of !! op(A) * inv(diag(C)) where C is a DOUBLE PRECISION vector. capply, info, work,rwork ) @@ -34600,26 +34602,26 @@ module stdlib_linalg_lapack_w integer(ilp), intent(out) :: info ! Array Arguments integer(ilp), intent(in) :: ipiv(*) - complex(qp), intent(in) :: ab(ldab,*), afb(ldafb,*) - complex(qp), intent(out) :: work(*) - real(qp), intent(in) :: c(*) - real(qp), intent(out) :: rwork(*) + complex(${ck}$), intent(in) :: ab(ldab,*), afb(ldafb,*) + complex(${ck}$), intent(out) :: work(*) + real(${ck}$), intent(in) :: c(*) + real(${ck}$), intent(out) :: rwork(*) ! ===================================================================== ! Local Scalars logical(lk) :: notrans integer(ilp) :: kase, i, j - real(qp) :: ainvnm, anorm, tmp - complex(qp) :: zdum + real(${ck}$) :: ainvnm, anorm, tmp + complex(${ck}$) :: zdum ! Local Arrays integer(ilp) :: isave(3) ! Intrinsic Functions intrinsic :: abs,max ! Statement Functions - real(qp) :: cabs1 + real(${ck}$) :: cabs1 ! Statement Function Definitions - cabs1( zdum ) = abs( real( zdum,KIND=qp) ) + abs( aimag( zdum ) ) + cabs1( zdum ) = abs( real( zdum,KIND=${ck}$) ) + abs( aimag( zdum ) ) ! Executable Statements - stdlib_wla_gbrcond_c = zero + stdlib_${ci}$la_gbrcond_c = zero info = 0 notrans = stdlib_lsame( trans, 'N' ) if ( .not. notrans .and. .not. stdlib_lsame( trans, 'T' ) .and. .not.stdlib_lsame( & @@ -34677,7 +34679,7 @@ module stdlib_linalg_lapack_w end if ! quick return if possible. if( n==0 ) then - stdlib_wla_gbrcond_c = one + stdlib_${ci}$la_gbrcond_c = one return else if( anorm == zero ) then return @@ -34686,7 +34688,7 @@ module stdlib_linalg_lapack_w ainvnm = zero kase = 0 10 continue - call stdlib_wlacn2( n, work( n+1 ), work, ainvnm, kase, isave ) + call stdlib_${ci}$lacn2( n, work( n+1 ), work, ainvnm, kase, isave ) if( kase/=0 ) then if( kase==2 ) then ! multiply by r. @@ -34694,10 +34696,10 @@ module stdlib_linalg_lapack_w work( i ) = work( i ) * rwork( i ) end do if ( notrans ) then - call stdlib_wgbtrs( 'NO TRANSPOSE', n, kl, ku, 1, afb, ldafb,ipiv, work, n, & + call stdlib_${ci}$gbtrs( 'NO TRANSPOSE', n, kl, ku, 1, afb, ldafb,ipiv, work, n, & info ) else - call stdlib_wgbtrs( 'CONJUGATE TRANSPOSE', n, kl, ku, 1, afb,ldafb, ipiv, & + call stdlib_${ci}$gbtrs( 'CONJUGATE TRANSPOSE', n, kl, ku, 1, afb,ldafb, ipiv, & work, n, info ) endif ! multiply by inv(c). @@ -34714,10 +34716,10 @@ module stdlib_linalg_lapack_w end do end if if ( notrans ) then - call stdlib_wgbtrs( 'CONJUGATE TRANSPOSE', n, kl, ku, 1, afb,ldafb, ipiv, & + call stdlib_${ci}$gbtrs( 'CONJUGATE TRANSPOSE', n, kl, ku, 1, afb,ldafb, ipiv, & work, n, info ) else - call stdlib_wgbtrs( 'NO TRANSPOSE', n, kl, ku, 1, afb, ldafb,ipiv, work, n, & + call stdlib_${ci}$gbtrs( 'NO TRANSPOSE', n, kl, ku, 1, afb, ldafb,ipiv, work, n, & info ) end if ! multiply by r. @@ -34728,12 +34730,12 @@ module stdlib_linalg_lapack_w go to 10 end if ! compute the estimate of the reciprocal condition number. - if( ainvnm /= zero )stdlib_wla_gbrcond_c = one / ainvnm + if( ainvnm /= zero )stdlib_${ci}$la_gbrcond_c = one / ainvnm return - end function stdlib_wla_gbrcond_c + end function stdlib_${ci}$la_gbrcond_c - pure real(qp) function stdlib_wla_gbrpvgrw( n, kl, ku, ncols, ab,ldab, afb, ldafb ) + pure real(${ck}$) function stdlib_${ci}$la_gbrpvgrw( n, kl, ku, ncols, ab,ldab, afb, ldafb ) !! ZLA_GBRPVGRW: computes the reciprocal pivot growth factor !! norm(A)/norm(U). The "max absolute element" norm is used. If this is !! much less than 1, the stability of the LU factorization of the @@ -34746,18 +34748,18 @@ module stdlib_linalg_lapack_w ! Scalar Arguments integer(ilp), intent(in) :: n, kl, ku, ncols, ldab, ldafb ! Array Arguments - complex(qp), intent(in) :: ab(ldab,*), afb(ldafb,*) + complex(${ck}$), intent(in) :: ab(ldab,*), afb(ldafb,*) ! ===================================================================== ! Local Scalars integer(ilp) :: i, j, kd - real(qp) :: amax, umax, rpvgrw - complex(qp) :: zdum + real(${ck}$) :: amax, umax, rpvgrw + complex(${ck}$) :: zdum ! Intrinsic Functions intrinsic :: abs,max,min,real,aimag ! Statement Functions - real(qp) :: cabs1 + real(${ck}$) :: cabs1 ! Statement Function Definitions - cabs1( zdum ) = abs( real( zdum,KIND=qp) ) + abs( aimag( zdum ) ) + cabs1( zdum ) = abs( real( zdum,KIND=${ck}$) ) + abs( aimag( zdum ) ) ! Executable Statements rpvgrw = one kd = ku + 1 @@ -34774,11 +34776,11 @@ module stdlib_linalg_lapack_w rpvgrw = min( amax / umax, rpvgrw ) end if end do - stdlib_wla_gbrpvgrw = rpvgrw - end function stdlib_wla_gbrpvgrw + stdlib_${ci}$la_gbrpvgrw = rpvgrw + end function stdlib_${ci}$la_gbrpvgrw - subroutine stdlib_wla_geamv( trans, m, n, alpha, a, lda, x, incx, beta,y, incy ) + subroutine stdlib_${ci}$la_geamv( trans, m, n, alpha, a, lda, x, incx, beta,y, incy ) !! ZLA_GEAMV: performs one of the matrix-vector operations !! y := alpha*abs(A)*abs(x) + beta*abs(y), !! or y := alpha*abs(A)**T*abs(x) + beta*abs(y), @@ -34796,25 +34798,25 @@ module stdlib_linalg_lapack_w ! -- lapack is a software package provided by univ. of tennessee, -- ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments - real(qp), intent(in) :: alpha, beta + real(${ck}$), intent(in) :: alpha, beta integer(ilp), intent(in) :: incx, incy, lda, m, n integer(ilp), intent(in) :: trans ! Array Arguments - complex(qp), intent(in) :: a(lda,*), x(*) - real(qp), intent(inout) :: y(*) + complex(${ck}$), intent(in) :: a(lda,*), x(*) + real(${ck}$), intent(inout) :: y(*) ! ===================================================================== ! Local Scalars logical(lk) :: symb_wero - real(qp) :: temp, safe1 + real(${ck}$) :: temp, safe1 integer(ilp) :: i, info, iy, j, jx, kx, ky, lenx, leny - complex(qp) :: cdum + complex(${ck}$) :: cdum ! Intrinsic Functions intrinsic :: max,abs,real,aimag,sign ! Statement Functions - real(qp) :: cabs1 + real(${ck}$) :: cabs1 ! Statement Function Definitions - cabs1( cdum ) = abs( real( cdum,KIND=qp) ) + abs( aimag( cdum ) ) + cabs1( cdum ) = abs( real( cdum,KIND=${ck}$) ) + abs( aimag( cdum ) ) ! Executable Statements ! test the input parameters. info = 0 @@ -34859,7 +34861,7 @@ module stdlib_linalg_lapack_w end if ! set safe1 essentially to be the underflow threshold times the ! number of additions in each row. - safe1 = stdlib_qlamch( 'SAFE MINIMUM' ) + safe1 = stdlib_${c2ri(ci)}$lamch( 'SAFE MINIMUM' ) safe1 = (n+1)*safe1 ! form y := alpha*abs(a)*abs(x) + beta*abs(y). ! the o(m*n) symb_wero tests could be replaced by o(n) queries to @@ -34964,10 +34966,10 @@ module stdlib_linalg_lapack_w end if end if return - end subroutine stdlib_wla_geamv + end subroutine stdlib_${ci}$la_geamv - real(qp) function stdlib_wla_gercond_c( trans, n, a, lda, af,ldaf, ipiv, c, capply,info, & + real(${ck}$) function stdlib_${ci}$la_gercond_c( trans, n, a, lda, af,ldaf, ipiv, c, capply,info, & !! ZLA_GERCOND_C: computes the infinity norm condition number of !! op(A) * inv(diag(C)) where C is a DOUBLE PRECISION vector. work, rwork ) @@ -34981,26 +34983,26 @@ module stdlib_linalg_lapack_w integer(ilp), intent(out) :: info ! Array Arguments integer(ilp), intent(in) :: ipiv(*) - complex(qp), intent(in) :: a(lda,*), af(ldaf,*) - complex(qp), intent(out) :: work(*) - real(qp), intent(in) :: c(*) - real(qp), intent(out) :: rwork(*) + complex(${ck}$), intent(in) :: a(lda,*), af(ldaf,*) + complex(${ck}$), intent(out) :: work(*) + real(${ck}$), intent(in) :: c(*) + real(${ck}$), intent(out) :: rwork(*) ! ===================================================================== ! Local Scalars logical(lk) :: notrans integer(ilp) :: kase, i, j - real(qp) :: ainvnm, anorm, tmp - complex(qp) :: zdum + real(${ck}$) :: ainvnm, anorm, tmp + complex(${ck}$) :: zdum ! Local Arrays integer(ilp) :: isave(3) ! Intrinsic Functions intrinsic :: abs,max,real,aimag ! Statement Functions - real(qp) :: cabs1 + real(${ck}$) :: cabs1 ! Statement Function Definitions - cabs1( zdum ) = abs( real( zdum,KIND=qp) ) + abs( aimag( zdum ) ) + cabs1( zdum ) = abs( real( zdum,KIND=${ck}$) ) + abs( aimag( zdum ) ) ! Executable Statements - stdlib_wla_gercond_c = zero + stdlib_${ci}$la_gercond_c = zero info = 0 notrans = stdlib_lsame( trans, 'N' ) if ( .not. notrans .and. .not. stdlib_lsame( trans, 'T' ) .and. .not.stdlib_lsame( & @@ -35052,7 +35054,7 @@ module stdlib_linalg_lapack_w end if ! quick return if possible. if( n==0 ) then - stdlib_wla_gercond_c = one + stdlib_${ci}$la_gercond_c = one return else if( anorm == zero ) then return @@ -35061,7 +35063,7 @@ module stdlib_linalg_lapack_w ainvnm = zero kase = 0 10 continue - call stdlib_wlacn2( n, work( n+1 ), work, ainvnm, kase, isave ) + call stdlib_${ci}$lacn2( n, work( n+1 ), work, ainvnm, kase, isave ) if( kase/=0 ) then if( kase==2 ) then ! multiply by r. @@ -35069,10 +35071,10 @@ module stdlib_linalg_lapack_w work( i ) = work( i ) * rwork( i ) end do if (notrans) then - call stdlib_wgetrs( 'NO TRANSPOSE', n, 1, af, ldaf, ipiv,work, n, info ) + call stdlib_${ci}$getrs( 'NO TRANSPOSE', n, 1, af, ldaf, ipiv,work, n, info ) else - call stdlib_wgetrs( 'CONJUGATE TRANSPOSE', n, 1, af, ldaf, ipiv,work, n, info & + call stdlib_${ci}$getrs( 'CONJUGATE TRANSPOSE', n, 1, af, ldaf, ipiv,work, n, info & ) endif ! multiply by inv(c). @@ -35089,10 +35091,10 @@ module stdlib_linalg_lapack_w end do end if if ( notrans ) then - call stdlib_wgetrs( 'CONJUGATE TRANSPOSE', n, 1, af, ldaf, ipiv,work, n, info & + call stdlib_${ci}$getrs( 'CONJUGATE TRANSPOSE', n, 1, af, ldaf, ipiv,work, n, info & ) else - call stdlib_wgetrs( 'NO TRANSPOSE', n, 1, af, ldaf, ipiv,work, n, info ) + call stdlib_${ci}$getrs( 'NO TRANSPOSE', n, 1, af, ldaf, ipiv,work, n, info ) end if ! multiply by r. @@ -35103,12 +35105,12 @@ module stdlib_linalg_lapack_w go to 10 end if ! compute the estimate of the reciprocal condition number. - if( ainvnm /= zero )stdlib_wla_gercond_c = one / ainvnm + if( ainvnm /= zero )stdlib_${ci}$la_gercond_c = one / ainvnm return - end function stdlib_wla_gercond_c + end function stdlib_${ci}$la_gercond_c - pure real(qp) function stdlib_wla_gerpvgrw( n, ncols, a, lda, af,ldaf ) + pure real(${ck}$) function stdlib_${ci}$la_gerpvgrw( n, ncols, a, lda, af,ldaf ) !! ZLA_GERPVGRW: computes the reciprocal pivot growth factor !! norm(A)/norm(U). The "max absolute element" norm is used. If this is !! much less than 1, the stability of the LU factorization of the @@ -35121,18 +35123,18 @@ module stdlib_linalg_lapack_w ! Scalar Arguments integer(ilp), intent(in) :: n, ncols, lda, ldaf ! Array Arguments - complex(qp), intent(in) :: a(lda,*), af(ldaf,*) + complex(${ck}$), intent(in) :: a(lda,*), af(ldaf,*) ! ===================================================================== ! Local Scalars integer(ilp) :: i, j - real(qp) :: amax, umax, rpvgrw - complex(qp) :: zdum + real(${ck}$) :: amax, umax, rpvgrw + complex(${ck}$) :: zdum ! Intrinsic Functions intrinsic :: max,min,abs,real,aimag ! Statement Functions - real(qp) :: cabs1 + real(${ck}$) :: cabs1 ! Statement Function Definitions - cabs1( zdum ) = abs( real( zdum,KIND=qp) ) + abs( aimag( zdum ) ) + cabs1( zdum ) = abs( real( zdum,KIND=${ck}$) ) + abs( aimag( zdum ) ) ! Executable Statements rpvgrw = one do j = 1, ncols @@ -35148,11 +35150,11 @@ module stdlib_linalg_lapack_w rpvgrw = min( amax / umax, rpvgrw ) end if end do - stdlib_wla_gerpvgrw = rpvgrw - end function stdlib_wla_gerpvgrw + stdlib_${ci}$la_gerpvgrw = rpvgrw + end function stdlib_${ci}$la_gerpvgrw - subroutine stdlib_wla_heamv( uplo, n, alpha, a, lda, x, incx, beta, y,incy ) + subroutine stdlib_${ci}$la_heamv( uplo, n, alpha, a, lda, x, incx, beta, y,incy ) !! ZLA_SYAMV performs the matrix-vector operation !! y := alpha*abs(A)*abs(x) + beta*abs(y), !! where alpha and beta are scalars, x and y are vectors and A is an @@ -35169,24 +35171,24 @@ module stdlib_linalg_lapack_w ! -- lapack is a software package provided by univ. of tennessee, -- ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments - real(qp), intent(in) :: alpha, beta + real(${ck}$), intent(in) :: alpha, beta integer(ilp), intent(in) :: incx, incy, lda, n, uplo ! Array Arguments - complex(qp), intent(in) :: a(lda,*), x(*) - real(qp), intent(inout) :: y(*) + complex(${ck}$), intent(in) :: a(lda,*), x(*) + real(${ck}$), intent(inout) :: y(*) ! ===================================================================== ! Local Scalars logical(lk) :: symb_wero - real(qp) :: temp, safe1 + real(${ck}$) :: temp, safe1 integer(ilp) :: i, info, iy, j, jx, kx, ky - complex(qp) :: zdum + complex(${ck}$) :: zdum ! Intrinsic Functions intrinsic :: max,abs,sign,real,aimag ! Statement Functions - real(qp) :: cabs1 + real(${ck}$) :: cabs1 ! Statement Function Definitions - cabs1( zdum ) = abs( real( zdum,KIND=qp) ) + abs( aimag ( zdum ) ) + cabs1( zdum ) = abs( real( zdum,KIND=${ck}$) ) + abs( aimag ( zdum ) ) ! Executable Statements ! test the input parameters. info = 0 @@ -35220,7 +35222,7 @@ module stdlib_linalg_lapack_w end if ! set safe1 essentially to be the underflow threshold times the ! number of additions in each row. - safe1 = stdlib_qlamch( 'SAFE MINIMUM' ) + safe1 = stdlib_${c2ri(ci)}$lamch( 'SAFE MINIMUM' ) safe1 = (n+1)*safe1 ! form y := alpha*abs(a)*abs(x) + beta*abs(y). ! the o(n^2) symb_wero tests could be replaced by o(n) queries to @@ -35343,10 +35345,10 @@ module stdlib_linalg_lapack_w end if end if return - end subroutine stdlib_wla_heamv + end subroutine stdlib_${ci}$la_heamv - real(qp) function stdlib_wla_hercond_c( uplo, n, a, lda, af,ldaf, ipiv, c, capply,info, work,& + real(${ck}$) function stdlib_${ci}$la_hercond_c( uplo, n, a, lda, af,ldaf, ipiv, c, capply,info, work,& !! ZLA_HERCOND_C: computes the infinity norm condition number of !! op(A) * inv(diag(C)) where C is a DOUBLE PRECISION vector. rwork ) @@ -35360,26 +35362,26 @@ module stdlib_linalg_lapack_w integer(ilp), intent(out) :: info ! Array Arguments integer(ilp), intent(in) :: ipiv(*) - complex(qp), intent(in) :: a(lda,*), af(ldaf,*) - complex(qp), intent(out) :: work(*) - real(qp), intent(in) :: c(*) - real(qp), intent(out) :: rwork(*) + complex(${ck}$), intent(in) :: a(lda,*), af(ldaf,*) + complex(${ck}$), intent(out) :: work(*) + real(${ck}$), intent(in) :: c(*) + real(${ck}$), intent(out) :: rwork(*) ! ===================================================================== ! Local Scalars integer(ilp) :: kase, i, j - real(qp) :: ainvnm, anorm, tmp + real(${ck}$) :: ainvnm, anorm, tmp logical(lk) :: up, upper - complex(qp) :: zdum + complex(${ck}$) :: zdum ! Local Arrays integer(ilp) :: isave(3) ! Intrinsic Functions intrinsic :: abs,max ! Statement Functions - real(qp) :: cabs1 + real(${ck}$) :: cabs1 ! Statement Function Definitions - cabs1( zdum ) = abs( real( zdum,KIND=qp) ) + abs( aimag( zdum ) ) + cabs1( zdum ) = abs( real( zdum,KIND=${ck}$) ) + abs( aimag( zdum ) ) ! Executable Statements - stdlib_wla_hercond_c = zero + stdlib_${ci}$la_hercond_c = zero info = 0 upper = stdlib_lsame( uplo, 'U' ) if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then @@ -35444,7 +35446,7 @@ module stdlib_linalg_lapack_w end if ! quick return if possible. if( n==0 ) then - stdlib_wla_hercond_c = one + stdlib_${ci}$la_hercond_c = one return else if( anorm == zero ) then return @@ -35453,7 +35455,7 @@ module stdlib_linalg_lapack_w ainvnm = zero kase = 0 10 continue - call stdlib_wlacn2( n, work( n+1 ), work, ainvnm, kase, isave ) + call stdlib_${ci}$lacn2( n, work( n+1 ), work, ainvnm, kase, isave ) if( kase/=0 ) then if( kase==2 ) then ! multiply by r. @@ -35461,9 +35463,9 @@ module stdlib_linalg_lapack_w work( i ) = work( i ) * rwork( i ) end do if ( up ) then - call stdlib_whetrs( 'U', n, 1, af, ldaf, ipiv,work, n, info ) + call stdlib_${ci}$hetrs( 'U', n, 1, af, ldaf, ipiv,work, n, info ) else - call stdlib_whetrs( 'L', n, 1, af, ldaf, ipiv,work, n, info ) + call stdlib_${ci}$hetrs( 'L', n, 1, af, ldaf, ipiv,work, n, info ) endif ! multiply by inv(c). if ( capply ) then @@ -35479,9 +35481,9 @@ module stdlib_linalg_lapack_w end do end if if ( up ) then - call stdlib_whetrs( 'U', n, 1, af, ldaf, ipiv,work, n, info ) + call stdlib_${ci}$hetrs( 'U', n, 1, af, ldaf, ipiv,work, n, info ) else - call stdlib_whetrs( 'L', n, 1, af, ldaf, ipiv,work, n, info ) + call stdlib_${ci}$hetrs( 'L', n, 1, af, ldaf, ipiv,work, n, info ) end if ! multiply by r. do i = 1, n @@ -35491,12 +35493,12 @@ module stdlib_linalg_lapack_w go to 10 end if ! compute the estimate of the reciprocal condition number. - if( ainvnm /= zero )stdlib_wla_hercond_c = one / ainvnm + if( ainvnm /= zero )stdlib_${ci}$la_hercond_c = one / ainvnm return - end function stdlib_wla_hercond_c + end function stdlib_${ci}$la_hercond_c - real(qp) function stdlib_wla_herpvgrw( uplo, n, info, a, lda, af,ldaf, ipiv, work ) + real(${ck}$) function stdlib_${ci}$la_herpvgrw( uplo, n, info, a, lda, af,ldaf, ipiv, work ) !! ZLA_HERPVGRW: computes the reciprocal pivot growth factor !! norm(A)/norm(U). The "max absolute element" norm is used. If this is !! much less than 1, the stability of the LU factorization of the @@ -35511,20 +35513,20 @@ module stdlib_linalg_lapack_w integer(ilp), intent(in) :: n, info, lda, ldaf ! Array Arguments integer(ilp), intent(in) :: ipiv(*) - complex(qp), intent(in) :: a(lda,*), af(ldaf,*) - real(qp), intent(out) :: work(*) + complex(${ck}$), intent(in) :: a(lda,*), af(ldaf,*) + real(${ck}$), intent(out) :: work(*) ! ===================================================================== ! Local Scalars integer(ilp) :: ncols, i, j, k, kp - real(qp) :: amax, umax, rpvgrw, tmp + real(${ck}$) :: amax, umax, rpvgrw, tmp logical(lk) :: upper, lsame - complex(qp) :: zdum + complex(${ck}$) :: zdum ! Intrinsic Functions intrinsic :: abs,real,aimag,max,min ! Statement Functions - real(qp) :: cabs1 + real(${ck}$) :: cabs1 ! Statement Function Definitions - cabs1( zdum ) = abs( real( zdum,KIND=qp) ) + abs( aimag ( zdum ) ) + cabs1( zdum ) = abs( real( zdum,KIND=${ck}$) ) + abs( aimag ( zdum ) ) ! Executable Statements upper = stdlib_lsame( 'UPPER', uplo ) if ( info==0 ) then @@ -35561,7 +35563,7 @@ module stdlib_linalg_lapack_w ! now find the max magnitude entry of each column of u or l. also ! permute the magnitudes of a above so they're in the same order as ! the factor. - ! the iteration orders and permutations were copied from stdlib_wsytrs. + ! the iteration orders and permutations were copied from stdlib_${ci}$sytrs. ! calls to stdlib_dswap would be severe overkill. if ( upper ) then k = n @@ -35681,11 +35683,11 @@ module stdlib_linalg_lapack_w end if end do end if - stdlib_wla_herpvgrw = rpvgrw - end function stdlib_wla_herpvgrw + stdlib_${ci}$la_herpvgrw = rpvgrw + end function stdlib_${ci}$la_herpvgrw - pure subroutine stdlib_wla_lin_berr( n, nz, nrhs, res, ayb, berr ) + pure subroutine stdlib_${ci}$la_lin_berr( n, nz, nrhs, res, ayb, berr ) !! ZLA_LIN_BERR: computes componentwise relative backward error from !! the formula !! max(i) ( abs(R(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) ) @@ -35697,25 +35699,25 @@ module stdlib_linalg_lapack_w ! Scalar Arguments integer(ilp), intent(in) :: n, nz, nrhs ! Array Arguments - real(qp), intent(in) :: ayb(n,nrhs) - real(qp), intent(out) :: berr(nrhs) - complex(qp), intent(in) :: res(n,nrhs) + real(${ck}$), intent(in) :: ayb(n,nrhs) + real(${ck}$), intent(out) :: berr(nrhs) + complex(${ck}$), intent(in) :: res(n,nrhs) ! ===================================================================== ! Local Scalars - real(qp) :: tmp,safe1 + real(${ck}$) :: tmp,safe1 integer(ilp) :: i, j - complex(qp) :: cdum + complex(${ck}$) :: cdum ! Intrinsic Functions intrinsic :: abs,real,aimag,max ! Statement Functions - complex(qp) :: cabs1 + complex(${ck}$) :: cabs1 ! Statement Function Definitions - cabs1( cdum ) = abs( real( cdum,KIND=qp) ) + abs( aimag( cdum ) ) + cabs1( cdum ) = abs( real( cdum,KIND=${ck}$) ) + abs( aimag( cdum ) ) ! Executable Statements ! adding safe1 to the numerator guards against spuriously zero ! residuals. a similar safeguard is in the cla_yyamv routine used ! to compute ayb. - safe1 = stdlib_qlamch( 'SAFE MINIMUM' ) + safe1 = stdlib_${c2ri(ci)}$lamch( 'SAFE MINIMUM' ) safe1 = (nz+1)*safe1 do j = 1, nrhs berr(j) = zero @@ -35724,14 +35726,14 @@ module stdlib_linalg_lapack_w tmp = (safe1 + cabs1(res(i,j)))/ayb(i,j) berr(j) = max( berr(j), tmp ) end if - ! if ayb is exactly 0.0_qp (and if computed by cla_yyamv), then we know + ! if ayb is exactly 0.0_${ck}$ (and if computed by cla_yyamv), then we know ! the true residual also must be exactly zero. end do end do - end subroutine stdlib_wla_lin_berr + end subroutine stdlib_${ci}$la_lin_berr - real(qp) function stdlib_wla_porcond_c( uplo, n, a, lda, af,ldaf, c, capply, info,work, & + real(${ck}$) function stdlib_${ci}$la_porcond_c( uplo, n, a, lda, af,ldaf, c, capply, info,work, & !! ZLA_PORCOND_C: Computes the infinity norm condition number of !! op(A) * inv(diag(C)) where C is a DOUBLE PRECISION vector rwork ) @@ -35744,27 +35746,27 @@ module stdlib_linalg_lapack_w integer(ilp), intent(in) :: n, lda, ldaf integer(ilp), intent(out) :: info ! Array Arguments - complex(qp), intent(in) :: a(lda,*), af(ldaf,*) - complex(qp), intent(out) :: work(*) - real(qp), intent(in) :: c(*) - real(qp), intent(out) :: rwork(*) + complex(${ck}$), intent(in) :: a(lda,*), af(ldaf,*) + complex(${ck}$), intent(out) :: work(*) + real(${ck}$), intent(in) :: c(*) + real(${ck}$), intent(out) :: rwork(*) ! ===================================================================== ! Local Scalars integer(ilp) :: kase - real(qp) :: ainvnm, anorm, tmp + real(${ck}$) :: ainvnm, anorm, tmp integer(ilp) :: i, j logical(lk) :: up, upper - complex(qp) :: zdum + complex(${ck}$) :: zdum ! Local Arrays integer(ilp) :: isave(3) ! Intrinsic Functions intrinsic :: abs,max,real,aimag ! Statement Functions - real(qp) :: cabs1 + real(${ck}$) :: cabs1 ! Statement Function Definitions - cabs1( zdum ) = abs( real( zdum,KIND=qp) ) + abs( aimag( zdum ) ) + cabs1( zdum ) = abs( real( zdum,KIND=${ck}$) ) + abs( aimag( zdum ) ) ! Executable Statements - stdlib_wla_porcond_c = zero + stdlib_${ci}$la_porcond_c = zero info = 0 upper = stdlib_lsame( uplo, 'U' ) if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then @@ -35829,7 +35831,7 @@ module stdlib_linalg_lapack_w end if ! quick return if possible. if( n==0 ) then - stdlib_wla_porcond_c = one + stdlib_${ci}$la_porcond_c = one return else if( anorm == zero ) then return @@ -35838,7 +35840,7 @@ module stdlib_linalg_lapack_w ainvnm = zero kase = 0 10 continue - call stdlib_wlacn2( n, work( n+1 ), work, ainvnm, kase, isave ) + call stdlib_${ci}$lacn2( n, work( n+1 ), work, ainvnm, kase, isave ) if( kase/=0 ) then if( kase==2 ) then ! multiply by r. @@ -35846,9 +35848,9 @@ module stdlib_linalg_lapack_w work( i ) = work( i ) * rwork( i ) end do if ( up ) then - call stdlib_wpotrs( 'U', n, 1, af, ldaf,work, n, info ) + call stdlib_${ci}$potrs( 'U', n, 1, af, ldaf,work, n, info ) else - call stdlib_wpotrs( 'L', n, 1, af, ldaf,work, n, info ) + call stdlib_${ci}$potrs( 'L', n, 1, af, ldaf,work, n, info ) endif ! multiply by inv(c). if ( capply ) then @@ -35864,9 +35866,9 @@ module stdlib_linalg_lapack_w end do end if if ( up ) then - call stdlib_wpotrs( 'U', n, 1, af, ldaf,work, n, info ) + call stdlib_${ci}$potrs( 'U', n, 1, af, ldaf,work, n, info ) else - call stdlib_wpotrs( 'L', n, 1, af, ldaf,work, n, info ) + call stdlib_${ci}$potrs( 'L', n, 1, af, ldaf,work, n, info ) end if ! multiply by r. do i = 1, n @@ -35876,12 +35878,12 @@ module stdlib_linalg_lapack_w go to 10 end if ! compute the estimate of the reciprocal condition number. - if( ainvnm /= zero )stdlib_wla_porcond_c = one / ainvnm + if( ainvnm /= zero )stdlib_${ci}$la_porcond_c = one / ainvnm return - end function stdlib_wla_porcond_c + end function stdlib_${ci}$la_porcond_c - real(qp) function stdlib_wla_porpvgrw( uplo, ncols, a, lda, af,ldaf, work ) + real(${ck}$) function stdlib_${ci}$la_porpvgrw( uplo, ncols, a, lda, af,ldaf, work ) !! ZLA_PORPVGRW: computes the reciprocal pivot growth factor !! norm(A)/norm(U). The "max absolute element" norm is used. If this is !! much less than 1, the stability of the LU factorization of the @@ -35895,23 +35897,23 @@ module stdlib_linalg_lapack_w character, intent(in) :: uplo integer(ilp), intent(in) :: ncols, lda, ldaf ! Array Arguments - complex(qp), intent(in) :: a(lda,*), af(ldaf,*) - real(qp), intent(out) :: work(*) + complex(${ck}$), intent(in) :: a(lda,*), af(ldaf,*) + real(${ck}$), intent(out) :: work(*) ! ===================================================================== ! Local Scalars integer(ilp) :: i, j - real(qp) :: amax, umax, rpvgrw + real(${ck}$) :: amax, umax, rpvgrw logical(lk) :: upper - complex(qp) :: zdum + complex(${ck}$) :: zdum ! Intrinsic Functions intrinsic :: abs,max,min,real,aimag ! Statement Functions - real(qp) :: cabs1 + real(${ck}$) :: cabs1 ! Statement Function Definitions - cabs1( zdum ) = abs( real( zdum,KIND=qp) ) + abs( aimag( zdum ) ) + cabs1( zdum ) = abs( real( zdum,KIND=${ck}$) ) + abs( aimag( zdum ) ) ! Executable Statements upper = stdlib_lsame( 'UPPER', uplo ) - ! stdlib_qpotrf will have factored only the ncolsxncols leading minor, so + ! stdlib_${ci}$otrf will have factored only the ncolsxncols leading minor, so ! we restrict the growth search to that minor and use only the first ! 2*ncols workspace entries. rpvgrw = one @@ -35970,11 +35972,11 @@ module stdlib_linalg_lapack_w end if end do end if - stdlib_wla_porpvgrw = rpvgrw - end function stdlib_wla_porpvgrw + stdlib_${ci}$la_porpvgrw = rpvgrw + end function stdlib_${ci}$la_porpvgrw - subroutine stdlib_wla_syamv( uplo, n, alpha, a, lda, x, incx, beta, y,incy ) + subroutine stdlib_${ci}$la_syamv( uplo, n, alpha, a, lda, x, incx, beta, y,incy ) !! ZLA_SYAMV: performs the matrix-vector operation !! y := alpha*abs(A)*abs(x) + beta*abs(y), !! where alpha and beta are scalars, x and y are vectors and A is an @@ -35991,25 +35993,25 @@ module stdlib_linalg_lapack_w ! -- lapack is a software package provided by univ. of tennessee, -- ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments - real(qp), intent(in) :: alpha, beta + real(${ck}$), intent(in) :: alpha, beta integer(ilp), intent(in) :: incx, incy, lda, n integer(ilp), intent(in) :: uplo ! Array Arguments - complex(qp), intent(in) :: a(lda,*), x(*) - real(qp), intent(inout) :: y(*) + complex(${ck}$), intent(in) :: a(lda,*), x(*) + real(${ck}$), intent(inout) :: y(*) ! ===================================================================== ! Local Scalars logical(lk) :: symb_wero - real(qp) :: temp, safe1 + real(${ck}$) :: temp, safe1 integer(ilp) :: i, info, iy, j, jx, kx, ky - complex(qp) :: zdum + complex(${ck}$) :: zdum ! Intrinsic Functions intrinsic :: max,abs,sign,real,aimag ! Statement Functions - real(qp) :: cabs1 + real(${ck}$) :: cabs1 ! Statement Function Definitions - cabs1( zdum ) = abs( real( zdum,KIND=qp) ) + abs( aimag ( zdum ) ) + cabs1( zdum ) = abs( real( zdum,KIND=${ck}$) ) + abs( aimag ( zdum ) ) ! Executable Statements ! test the input parameters. info = 0 @@ -36043,7 +36045,7 @@ module stdlib_linalg_lapack_w end if ! set safe1 essentially to be the underflow threshold times the ! number of additions in each row. - safe1 = stdlib_qlamch( 'SAFE MINIMUM' ) + safe1 = stdlib_${c2ri(ci)}$lamch( 'SAFE MINIMUM' ) safe1 = (n+1)*safe1 ! form y := alpha*abs(a)*abs(x) + beta*abs(y). ! the o(n^2) symb_wero tests could be replaced by o(n) queries to @@ -36166,10 +36168,10 @@ module stdlib_linalg_lapack_w end if end if return - end subroutine stdlib_wla_syamv + end subroutine stdlib_${ci}$la_syamv - real(qp) function stdlib_wla_syrcond_c( uplo, n, a, lda, af,ldaf, ipiv, c, capply,info, work,& + real(${ck}$) function stdlib_${ci}$la_syrcond_c( uplo, n, a, lda, af,ldaf, ipiv, c, capply,info, work,& !! ZLA_SYRCOND_C: Computes the infinity norm condition number of !! op(A) * inv(diag(C)) where C is a DOUBLE PRECISION vector. rwork ) @@ -36183,27 +36185,27 @@ module stdlib_linalg_lapack_w integer(ilp), intent(out) :: info ! Array Arguments integer(ilp), intent(in) :: ipiv(*) - complex(qp), intent(in) :: a(lda,*), af(ldaf,*) - complex(qp), intent(out) :: work(*) - real(qp), intent(in) :: c(*) - real(qp), intent(out) :: rwork(*) + complex(${ck}$), intent(in) :: a(lda,*), af(ldaf,*) + complex(${ck}$), intent(out) :: work(*) + real(${ck}$), intent(in) :: c(*) + real(${ck}$), intent(out) :: rwork(*) ! ===================================================================== ! Local Scalars integer(ilp) :: kase - real(qp) :: ainvnm, anorm, tmp + real(${ck}$) :: ainvnm, anorm, tmp integer(ilp) :: i, j logical(lk) :: up, upper - complex(qp) :: zdum + complex(${ck}$) :: zdum ! Local Arrays integer(ilp) :: isave(3) ! Intrinsic Functions intrinsic :: abs,max ! Statement Functions - real(qp) :: cabs1 + real(${ck}$) :: cabs1 ! Statement Function Definitions - cabs1( zdum ) = abs( real( zdum,KIND=qp) ) + abs( aimag( zdum ) ) + cabs1( zdum ) = abs( real( zdum,KIND=${ck}$) ) + abs( aimag( zdum ) ) ! Executable Statements - stdlib_wla_syrcond_c = zero + stdlib_${ci}$la_syrcond_c = zero info = 0 upper = stdlib_lsame( uplo, 'U' ) if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then @@ -36268,7 +36270,7 @@ module stdlib_linalg_lapack_w end if ! quick return if possible. if( n==0 ) then - stdlib_wla_syrcond_c = one + stdlib_${ci}$la_syrcond_c = one return else if( anorm == zero ) then return @@ -36277,7 +36279,7 @@ module stdlib_linalg_lapack_w ainvnm = zero kase = 0 10 continue - call stdlib_wlacn2( n, work( n+1 ), work, ainvnm, kase, isave ) + call stdlib_${ci}$lacn2( n, work( n+1 ), work, ainvnm, kase, isave ) if( kase/=0 ) then if( kase==2 ) then ! multiply by r. @@ -36285,9 +36287,9 @@ module stdlib_linalg_lapack_w work( i ) = work( i ) * rwork( i ) end do if ( up ) then - call stdlib_wsytrs( 'U', n, 1, af, ldaf, ipiv,work, n, info ) + call stdlib_${ci}$sytrs( 'U', n, 1, af, ldaf, ipiv,work, n, info ) else - call stdlib_wsytrs( 'L', n, 1, af, ldaf, ipiv,work, n, info ) + call stdlib_${ci}$sytrs( 'L', n, 1, af, ldaf, ipiv,work, n, info ) endif ! multiply by inv(c). if ( capply ) then @@ -36303,9 +36305,9 @@ module stdlib_linalg_lapack_w end do end if if ( up ) then - call stdlib_wsytrs( 'U', n, 1, af, ldaf, ipiv,work, n, info ) + call stdlib_${ci}$sytrs( 'U', n, 1, af, ldaf, ipiv,work, n, info ) else - call stdlib_wsytrs( 'L', n, 1, af, ldaf, ipiv,work, n, info ) + call stdlib_${ci}$sytrs( 'L', n, 1, af, ldaf, ipiv,work, n, info ) end if ! multiply by r. do i = 1, n @@ -36315,12 +36317,12 @@ module stdlib_linalg_lapack_w go to 10 end if ! compute the estimate of the reciprocal condition number. - if( ainvnm /= zero )stdlib_wla_syrcond_c = one / ainvnm + if( ainvnm /= zero )stdlib_${ci}$la_syrcond_c = one / ainvnm return - end function stdlib_wla_syrcond_c + end function stdlib_${ci}$la_syrcond_c - real(qp) function stdlib_wla_syrpvgrw( uplo, n, info, a, lda, af,ldaf, ipiv, work ) + real(${ck}$) function stdlib_${ci}$la_syrpvgrw( uplo, n, info, a, lda, af,ldaf, ipiv, work ) !! ZLA_SYRPVGRW: computes the reciprocal pivot growth factor !! norm(A)/norm(U). The "max absolute element" norm is used. If this is !! much less than 1, the stability of the LU factorization of the @@ -36334,21 +36336,21 @@ module stdlib_linalg_lapack_w character, intent(in) :: uplo integer(ilp), intent(in) :: n, info, lda, ldaf ! Array Arguments - complex(qp), intent(in) :: a(lda,*), af(ldaf,*) - real(qp), intent(out) :: work(*) + complex(${ck}$), intent(in) :: a(lda,*), af(ldaf,*) + real(${ck}$), intent(out) :: work(*) integer(ilp), intent(in) :: ipiv(*) ! ===================================================================== ! Local Scalars integer(ilp) :: ncols, i, j, k, kp - real(qp) :: amax, umax, rpvgrw, tmp + real(${ck}$) :: amax, umax, rpvgrw, tmp logical(lk) :: upper - complex(qp) :: zdum + complex(${ck}$) :: zdum ! Intrinsic Functions intrinsic :: abs,real,aimag,max,min ! Statement Functions - real(qp) :: cabs1 + real(${ck}$) :: cabs1 ! Statement Function Definitions - cabs1( zdum ) = abs( real( zdum,KIND=qp) ) + abs( aimag ( zdum ) ) + cabs1( zdum ) = abs( real( zdum,KIND=${ck}$) ) + abs( aimag ( zdum ) ) ! Executable Statements upper = stdlib_lsame( 'UPPER', uplo ) if ( info==0 ) then @@ -36385,7 +36387,7 @@ module stdlib_linalg_lapack_w ! now find the max magnitude entry of each column of u or l. also ! permute the magnitudes of a above so they're in the same order as ! the factor. - ! the iteration orders and permutations were copied from stdlib_wsytrs. + ! the iteration orders and permutations were copied from stdlib_${ci}$sytrs. ! calls to stdlib_dswap would be severe overkill. if ( upper ) then k = n @@ -36505,11 +36507,11 @@ module stdlib_linalg_lapack_w end if end do end if - stdlib_wla_syrpvgrw = rpvgrw - end function stdlib_wla_syrpvgrw + stdlib_${ci}$la_syrpvgrw = rpvgrw + end function stdlib_${ci}$la_syrpvgrw - pure subroutine stdlib_wla_wwaddw( n, x, y, w ) + pure subroutine stdlib_${ci}$la_wwaddw( n, x, y, w ) !! ZLA_WWADDW: adds a vector W into a doubled-single vector (X, Y). !! This works for all extant IBM's hex and binary floating point !! arithmetic, but not for decimal. @@ -36519,11 +36521,11 @@ module stdlib_linalg_lapack_w ! Scalar Arguments integer(ilp), intent(in) :: n ! Array Arguments - complex(qp), intent(inout) :: x(*), y(*) - complex(qp), intent(in) :: w(*) + complex(${ck}$), intent(inout) :: x(*), y(*) + complex(${ck}$), intent(in) :: w(*) ! ===================================================================== ! Local Scalars - complex(qp) :: s + complex(${ck}$) :: s integer(ilp) :: i ! Executable Statements do 10 i = 1, n @@ -36533,10 +36535,10 @@ module stdlib_linalg_lapack_w x(i) = s 10 continue return - end subroutine stdlib_wla_wwaddw + end subroutine stdlib_${ci}$la_wwaddw - pure subroutine stdlib_wlabrd( m, n, nb, a, lda, d, e, tauq, taup, x, ldx, y,ldy ) + pure subroutine stdlib_${ci}$labrd( m, n, nb, a, lda, d, e, tauq, taup, x, ldx, y,ldy ) !! ZLABRD: reduces the first NB rows and columns of a complex general !! m by n matrix A to upper or lower real bidiagonal form by a unitary !! transformation Q**H * A * P, and returns the matrices X and Y which @@ -36550,14 +36552,14 @@ module stdlib_linalg_lapack_w ! Scalar Arguments integer(ilp), intent(in) :: lda, ldx, ldy, m, n, nb ! Array Arguments - real(qp), intent(out) :: d(*), e(*) - complex(qp), intent(inout) :: a(lda,*) - complex(qp), intent(out) :: taup(*), tauq(*), x(ldx,*), y(ldy,*) + real(${ck}$), intent(out) :: d(*), e(*) + complex(${ck}$), intent(inout) :: a(lda,*) + complex(${ck}$), intent(out) :: taup(*), tauq(*), x(ldx,*), y(ldy,*) ! ===================================================================== ! Local Scalars integer(ilp) :: i - complex(qp) :: alpha + complex(${ck}$) :: alpha ! Intrinsic Functions intrinsic :: min ! Executable Statements @@ -36567,126 +36569,126 @@ module stdlib_linalg_lapack_w ! reduce to upper bidiagonal form loop_10: do i = 1, nb ! update a(i:m,i) - call stdlib_wlacgv( i-1, y( i, 1 ), ldy ) - call stdlib_wgemv( 'NO TRANSPOSE', m-i+1, i-1, -cone, a( i, 1 ),lda, y( i, 1 ), & + call stdlib_${ci}$lacgv( i-1, y( i, 1 ), ldy ) + call stdlib_${ci}$gemv( 'NO TRANSPOSE', m-i+1, i-1, -cone, a( i, 1 ),lda, y( i, 1 ), & ldy, cone, a( i, i ), 1 ) - call stdlib_wlacgv( i-1, y( i, 1 ), ldy ) - call stdlib_wgemv( 'NO TRANSPOSE', m-i+1, i-1, -cone, x( i, 1 ),ldx, a( 1, i ), & + call stdlib_${ci}$lacgv( i-1, y( i, 1 ), ldy ) + call stdlib_${ci}$gemv( 'NO TRANSPOSE', m-i+1, i-1, -cone, x( i, 1 ),ldx, a( 1, i ), & 1, cone, a( i, i ), 1 ) ! generate reflection q(i) to annihilate a(i+1:m,i) alpha = a( i, i ) - call stdlib_wlarfg( m-i+1, alpha, a( min( i+1, m ), i ), 1,tauq( i ) ) - d( i ) = real( alpha,KIND=qp) + call stdlib_${ci}$larfg( m-i+1, alpha, a( min( i+1, m ), i ), 1,tauq( i ) ) + d( i ) = real( alpha,KIND=${ck}$) if( isafmin ) then - x( i ) = cmplx( real( x( i ),KIND=qp) / absxi,aimag( x( i ) ) / absxi,KIND=qp) + x( i ) = cmplx( real( x( i ),KIND=${ck}$) / absxi,aimag( x( i ) ) / absxi,KIND=${ck}$) else x( i ) = cone @@ -36778,7 +36780,7 @@ module stdlib_linalg_lapack_w ! ................ entry (isave( 1 ) = 2) ! first iteration. x has been overwritten by ctrans(a)*x. 40 continue - isave( 2 ) = stdlib_iwmax1( n, x, 1 ) + isave( 2 ) = stdlib_i${ci}$max1( n, x, 1 ) isave( 3 ) = 2 ! main loop - iterations 2,3,...,itmax. 50 continue @@ -36792,15 +36794,15 @@ module stdlib_linalg_lapack_w ! ................ entry (isave( 1 ) = 3) ! x has been overwritten by a*x. 70 continue - call stdlib_wcopy( n, x, 1, v, 1 ) + call stdlib_${ci}$copy( n, x, 1, v, 1 ) estold = est - est = stdlib_qzsum1( n, v, 1 ) + est = stdlib_${c2ri(ci)}$zsum1( n, v, 1 ) ! test for cycling. if( est<=estold )go to 100 do i = 1, n absxi = abs( x( i ) ) if( absxi>safmin ) then - x( i ) = cmplx( real( x( i ),KIND=qp) / absxi,aimag( x( i ) ) / absxi,KIND=qp) + x( i ) = cmplx( real( x( i ),KIND=${ck}$) / absxi,aimag( x( i ) ) / absxi,KIND=${ck}$) else x( i ) = cone @@ -36813,7 +36815,7 @@ module stdlib_linalg_lapack_w ! x has been overwritten by ctrans(a)*x. 90 continue jlast = isave( 2 ) - isave( 2 ) = stdlib_iwmax1( n, x, 1 ) + isave( 2 ) = stdlib_i${ci}$max1( n, x, 1 ) if( ( abs( x( jlast ) )/=abs( x( isave( 2 ) ) ) ) .and.( isave( 3 )est ) then - call stdlib_wcopy( n, x, 1, v, 1 ) + call stdlib_${ci}$copy( n, x, 1, v, 1 ) est = temp end if 130 continue kase = 0 return - end subroutine stdlib_wlacn2 + end subroutine stdlib_${ci}$lacn2 - subroutine stdlib_wlacon( n, v, x, est, kase ) + subroutine stdlib_${ci}$lacon( n, v, x, est, kase ) !! ZLACON: estimates the 1-norm of a square, complex matrix A. !! Reverse communication is used for evaluating matrix-vector products. ! -- lapack auxiliary routine -- @@ -36853,10 +36855,10 @@ module stdlib_linalg_lapack_w ! Scalar Arguments integer(ilp), intent(inout) :: kase integer(ilp), intent(in) :: n - real(qp), intent(inout) :: est + real(${ck}$), intent(inout) :: est ! Array Arguments - complex(qp), intent(out) :: v(n) - complex(qp), intent(inout) :: x(n) + complex(${ck}$), intent(out) :: v(n) + complex(${ck}$), intent(inout) :: x(n) ! ===================================================================== ! Parameters integer(ilp), parameter :: itmax = 5 @@ -36865,16 +36867,16 @@ module stdlib_linalg_lapack_w ! Local Scalars integer(ilp) :: i, iter, j, jlast, jump - real(qp) :: absxi, altsgn, estold, safmin, temp + real(${ck}$) :: absxi, altsgn, estold, safmin, temp ! Intrinsic Functions intrinsic :: abs,real,cmplx,aimag ! Save Statement save ! Executable Statements - safmin = stdlib_qlamch( 'SAFE MINIMUM' ) + safmin = stdlib_${c2ri(ci)}$lamch( 'SAFE MINIMUM' ) if( kase==0 ) then do i = 1, n - x( i ) = cmplx( one / real( n,KIND=qp),KIND=qp) + x( i ) = cmplx( one / real( n,KIND=${ck}$),KIND=${ck}$) end do kase = 1 jump = 1 @@ -36890,11 +36892,11 @@ module stdlib_linalg_lapack_w ! ... quit go to 130 end if - est = stdlib_qzsum1( n, x, 1 ) + est = stdlib_${c2ri(ci)}$zsum1( n, x, 1 ) do i = 1, n absxi = abs( x( i ) ) if( absxi>safmin ) then - x( i ) = cmplx( real( x( i ),KIND=qp) / absxi,aimag( x( i ) ) / absxi,KIND=qp) + x( i ) = cmplx( real( x( i ),KIND=${ck}$) / absxi,aimag( x( i ) ) / absxi,KIND=${ck}$) else x( i ) = cone @@ -36906,7 +36908,7 @@ module stdlib_linalg_lapack_w ! ................ entry (jump = 2) ! first iteration. x has been overwritten by ctrans(a)*x. 40 continue - j = stdlib_iwmax1( n, x, 1 ) + j = stdlib_i${ci}$max1( n, x, 1 ) iter = 2 ! main loop - iterations 2,3,...,itmax. 50 continue @@ -36920,15 +36922,15 @@ module stdlib_linalg_lapack_w ! ................ entry (jump = 3) ! x has been overwritten by a*x. 70 continue - call stdlib_wcopy( n, x, 1, v, 1 ) + call stdlib_${ci}$copy( n, x, 1, v, 1 ) estold = est - est = stdlib_qzsum1( n, v, 1 ) + est = stdlib_${c2ri(ci)}$zsum1( n, v, 1 ) ! test for cycling. if( est<=estold )go to 100 do i = 1, n absxi = abs( x( i ) ) if( absxi>safmin ) then - x( i ) = cmplx( real( x( i ),KIND=qp) / absxi,aimag( x( i ) ) / absxi,KIND=qp) + x( i ) = cmplx( real( x( i ),KIND=${ck}$) / absxi,aimag( x( i ) ) / absxi,KIND=${ck}$) else x( i ) = cone @@ -36941,7 +36943,7 @@ module stdlib_linalg_lapack_w ! x has been overwritten by ctrans(a)*x. 90 continue jlast = j - j = stdlib_iwmax1( n, x, 1 ) + j = stdlib_i${ci}$max1( n, x, 1 ) if( ( abs( x( jlast ) )/=abs( x( j ) ) ) .and.( iterest ) then - call stdlib_wcopy( n, x, 1, v, 1 ) + call stdlib_${ci}$copy( n, x, 1, v, 1 ) est = temp end if 130 continue kase = 0 return - end subroutine stdlib_wlacon + end subroutine stdlib_${ci}$lacon - pure subroutine stdlib_wlacp2( uplo, m, n, a, lda, b, ldb ) + pure subroutine stdlib_${ci}$lacp2( uplo, m, n, a, lda, b, ldb ) !! ZLACP2: copies all or part of a real two-dimensional matrix A to a !! complex matrix B. ! -- lapack auxiliary routine -- @@ -36981,8 +36983,8 @@ module stdlib_linalg_lapack_w character, intent(in) :: uplo integer(ilp), intent(in) :: lda, ldb, m, n ! Array Arguments - real(qp), intent(in) :: a(lda,*) - complex(qp), intent(out) :: b(ldb,*) + real(${ck}$), intent(in) :: a(lda,*) + complex(${ck}$), intent(out) :: b(ldb,*) ! ===================================================================== ! Local Scalars integer(ilp) :: i, j @@ -37009,10 +37011,10 @@ module stdlib_linalg_lapack_w end do end if return - end subroutine stdlib_wlacp2 + end subroutine stdlib_${ci}$lacp2 - pure subroutine stdlib_wlacpy( uplo, m, n, a, lda, b, ldb ) + pure subroutine stdlib_${ci}$lacpy( uplo, m, n, a, lda, b, ldb ) !! ZLACPY: copies all or part of a two-dimensional matrix A to another !! matrix B. ! -- lapack auxiliary routine -- @@ -37022,8 +37024,8 @@ module stdlib_linalg_lapack_w character, intent(in) :: uplo integer(ilp), intent(in) :: lda, ldb, m, n ! Array Arguments - complex(qp), intent(in) :: a(lda,*) - complex(qp), intent(out) :: b(ldb,*) + complex(${ck}$), intent(in) :: a(lda,*) + complex(${ck}$), intent(out) :: b(ldb,*) ! ===================================================================== ! Local Scalars integer(ilp) :: i, j @@ -37050,10 +37052,10 @@ module stdlib_linalg_lapack_w end do end if return - end subroutine stdlib_wlacpy + end subroutine stdlib_${ci}$lacpy - pure subroutine stdlib_wlacrm( m, n, a, lda, b, ldb, c, ldc, rwork ) + pure subroutine stdlib_${ci}$lacrm( m, n, a, lda, b, ldb, c, ldc, rwork ) !! ZLACRM: performs a very simple matrix-matrix multiplication: !! C := A * B, !! where A is M by N and complex; B is N by N and real; @@ -37064,10 +37066,10 @@ module stdlib_linalg_lapack_w ! Scalar Arguments integer(ilp), intent(in) :: lda, ldb, ldc, m, n ! Array Arguments - real(qp), intent(in) :: b(ldb,*) - real(qp), intent(out) :: rwork(*) - complex(qp), intent(in) :: a(lda,*) - complex(qp), intent(out) :: c(ldc,*) + real(${ck}$), intent(in) :: b(ldb,*) + real(${ck}$), intent(out) :: rwork(*) + complex(${ck}$), intent(in) :: a(lda,*) + complex(${ck}$), intent(out) :: c(ldc,*) ! ===================================================================== ! Local Scalars @@ -37079,11 +37081,11 @@ module stdlib_linalg_lapack_w if( ( m==0 ) .or. ( n==0 ) )return do j = 1, n do i = 1, m - rwork( ( j-1 )*m+i ) = real( a( i, j ),KIND=qp) + rwork( ( j-1 )*m+i ) = real( a( i, j ),KIND=${ck}$) end do end do l = m*n + 1 - call stdlib_qgemm( 'N', 'N', m, n, n, one, rwork, m, b, ldb, zero,rwork( l ), m ) + call stdlib_${c2ri(ci)}$gemm( 'N', 'N', m, n, n, one, rwork, m, b, ldb, zero,rwork( l ), m ) do j = 1, n do i = 1, m @@ -37095,19 +37097,19 @@ module stdlib_linalg_lapack_w rwork( ( j-1 )*m+i ) = aimag( a( i, j ) ) end do end do - call stdlib_qgemm( 'N', 'N', m, n, n, one, rwork, m, b, ldb, zero,rwork( l ), m ) + call stdlib_${c2ri(ci)}$gemm( 'N', 'N', m, n, n, one, rwork, m, b, ldb, zero,rwork( l ), m ) do j = 1, n do i = 1, m - c( i, j ) = cmplx( real( c( i, j ),KIND=qp),rwork( l+( j-1 )*m+i-1 ),KIND=qp) + c( i, j ) = cmplx( real( c( i, j ),KIND=${ck}$),rwork( l+( j-1 )*m+i-1 ),KIND=${ck}$) end do end do return - end subroutine stdlib_wlacrm + end subroutine stdlib_${ci}$lacrm - pure subroutine stdlib_wlacrt( n, cx, incx, cy, incy, c, s ) + pure subroutine stdlib_${ci}$lacrt( n, cx, incx, cy, incy, c, s ) !! ZLACRT: performs the operation !! ( c s )( x ) ==> ( x ) !! ( -s c )( y ) ( y ) @@ -37117,13 +37119,13 @@ module stdlib_linalg_lapack_w ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments integer(ilp), intent(in) :: incx, incy, n - complex(qp), intent(in) :: c, s + complex(${ck}$), intent(in) :: c, s ! Array Arguments - complex(qp), intent(inout) :: cx(*), cy(*) + complex(${ck}$), intent(inout) :: cx(*), cy(*) ! ===================================================================== ! Local Scalars integer(ilp) :: i, ix, iy - complex(qp) :: ctemp + complex(${ck}$) :: ctemp ! Executable Statements if( n<=0 )return if( incx==1 .and. incy==1 )go to 20 @@ -37148,10 +37150,10 @@ module stdlib_linalg_lapack_w cx( i ) = ctemp end do return - end subroutine stdlib_wlacrt + end subroutine stdlib_${ci}$lacrt - pure complex(qp) function stdlib_wladiv( x, y ) + pure complex(${ck}$) function stdlib_${ci}$ladiv( x, y ) !! ZLADIV: := X / Y, where X and Y are complex. The computation of X / Y !! will not overflow on an intermediary step unless the results !! overflows. @@ -37159,21 +37161,21 @@ module stdlib_linalg_lapack_w ! -- lapack is a software package provided by univ. of tennessee, -- ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments - complex(qp), intent(in) :: x, y + complex(${ck}$), intent(in) :: x, y ! ===================================================================== ! Local Scalars - real(qp) :: zi, zr + real(${ck}$) :: zi, zr ! Intrinsic Functions intrinsic :: real,cmplx,aimag ! Executable Statements - call stdlib_qladiv( real( x,KIND=qp), aimag( x ), real( y,KIND=qp), aimag( y ), zr,zi ) + call stdlib_${c2ri(ci)}$ladiv( real( x,KIND=${ck}$), aimag( x ), real( y,KIND=${ck}$), aimag( y ), zr,zi ) - stdlib_wladiv = cmplx( zr, zi,KIND=qp) + stdlib_${ci}$ladiv = cmplx( zr, zi,KIND=${ck}$) return - end function stdlib_wladiv + end function stdlib_${ci}$ladiv - pure subroutine stdlib_wlaed0( qsiz, n, d, e, q, ldq, qstore, ldqs, rwork,iwork, info ) + pure subroutine stdlib_${ci}$laed0( qsiz, n, d, e, q, ldq, qstore, ldqs, rwork,iwork, info ) !! Using the divide and conquer method, ZLAED0: computes all eigenvalues !! of a symmetric tridiagonal matrix which is one diagonal block of !! those from reducing a dense or band Hermitian matrix and @@ -37187,10 +37189,10 @@ module stdlib_linalg_lapack_w integer(ilp), intent(in) :: ldq, ldqs, n, qsiz ! Array Arguments integer(ilp), intent(out) :: iwork(*) - real(qp), intent(inout) :: d(*), e(*) - real(qp), intent(out) :: rwork(*) - complex(qp), intent(inout) :: q(ldq,*) - complex(qp), intent(out) :: qstore(ldqs,*) + real(${ck}$), intent(inout) :: d(*), e(*) + real(${ck}$), intent(out) :: rwork(*) + complex(${ck}$), intent(inout) :: q(ldq,*) + complex(${ck}$), intent(out) :: qstore(ldqs,*) ! ===================================================================== ! warning: n could be as big as qsiz! @@ -37198,7 +37200,7 @@ module stdlib_linalg_lapack_w integer(ilp) :: curlvl, curprb, curr, i, igivcl, igivnm, igivpt, indxq, iperm, iprmpt, & iq, iqptr, iwrem, j, k, lgn, ll, matsiz, msd2, smlsiz, smm1, spm1, spm2, submat, & subpbs, tlvls - real(qp) :: temp + real(${ck}$) :: temp ! Intrinsic Functions intrinsic :: abs,real,int,log,max ! Executable Statements @@ -37254,7 +37256,7 @@ module stdlib_linalg_lapack_w indxq = 4*n + 3 ! set up workspaces for eigenvalues only/accumulate new vectors ! routine - temp = log( real( n,KIND=qp) ) / log( two ) + temp = log( real( n,KIND=${ck}$) ) / log( two ) lgn = int( temp,KIND=ilp) if( 2**lgn=growto*scale )go to 120 ! choose new orthogonal starting vector and try again. rtemp = eps3 / ( rootn+one ) @@ -37819,13 +37821,13 @@ module stdlib_linalg_lapack_w info = 1 120 continue ! normalize eigenvector. - i = stdlib_iwamax( n, v, 1 ) - call stdlib_wdscal( n, one / cabs1( v( i ) ), v, 1 ) + i = stdlib_i${ci}$amax( n, v, 1 ) + call stdlib_${ci}$dscal( n, one / cabs1( v( i ) ), v, 1 ) return - end subroutine stdlib_wlaein + end subroutine stdlib_${ci}$laein - pure subroutine stdlib_wlaesy( a, b, c, rt1, rt2, evscal, cs1, sn1 ) + pure subroutine stdlib_${ci}$laesy( a, b, c, rt1, rt2, evscal, cs1, sn1 ) !! ZLAESY: computes the eigendecomposition of a 2-by-2 symmetric matrix !! ( ( A, B );( B, C ) ) !! provided the norm of the matrix of eigenvectors is larger than @@ -37839,19 +37841,19 @@ module stdlib_linalg_lapack_w ! -- lapack is a software package provided by univ. of tennessee, -- ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments - complex(qp), intent(in) :: a, b, c - complex(qp), intent(out) :: cs1, evscal, rt1, rt2, sn1 + complex(${ck}$), intent(in) :: a, b, c + complex(${ck}$), intent(out) :: cs1, evscal, rt1, rt2, sn1 ! ===================================================================== ! Parameters - real(qp), parameter :: thresh = 0.1_qp + real(${ck}$), parameter :: thresh = 0.1_${ck}$ ! Local Scalars - real(qp) :: babs, evnorm, tabs, z - complex(qp) :: s, t, tmp + real(${ck}$) :: babs, evnorm, tabs, z + complex(${ck}$) :: s, t, tmp ! Intrinsic Functions intrinsic :: abs,max,sqrt ! Executable Statements @@ -37912,10 +37914,10 @@ module stdlib_linalg_lapack_w end if end if return - end subroutine stdlib_wlaesy + end subroutine stdlib_${ci}$laesy - pure subroutine stdlib_wlaev2( a, b, c, rt1, rt2, cs1, sn1 ) + pure subroutine stdlib_${ci}$laev2( a, b, c, rt1, rt2, cs1, sn1 ) !! ZLAEV2: computes the eigendecomposition of a 2-by-2 Hermitian matrix !! [ A B ] !! [ CONJG(B) C ]. @@ -37928,15 +37930,15 @@ module stdlib_linalg_lapack_w ! -- lapack is a software package provided by univ. of tennessee, -- ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments - real(qp), intent(out) :: cs1, rt1, rt2 - complex(qp), intent(in) :: a, b, c - complex(qp), intent(out) :: sn1 + real(${ck}$), intent(out) :: cs1, rt1, rt2 + complex(${ck}$), intent(in) :: a, b, c + complex(${ck}$), intent(out) :: sn1 ! ===================================================================== ! Local Scalars - real(qp) :: t - complex(qp) :: w + real(${ck}$) :: t + complex(${ck}$) :: w ! Intrinsic Functions intrinsic :: abs,real,conjg ! Executable Statements @@ -37945,14 +37947,14 @@ module stdlib_linalg_lapack_w else w = conjg( b ) / abs( b ) end if - call stdlib_qlaev2( real( a,KIND=qp), abs( b ), real( c,KIND=qp), rt1, rt2, cs1, t ) + call stdlib_${c2ri(ci)}$laev2( real( a,KIND=${ck}$), abs( b ), real( c,KIND=${ck}$), rt1, rt2, cs1, t ) sn1 = w*t return - end subroutine stdlib_wlaev2 + end subroutine stdlib_${ci}$laev2 - pure subroutine stdlib_wlag2c( m, n, a, lda, sa, ldsa, info ) + pure subroutine stdlib_${ci}$lag2c( m, n, a, lda, sa, ldsa, info ) !! ZLAG2C: converts a COMPLEX*16 matrix, SA, to a COMPLEX matrix, A. !! RMAX is the overflow for the SINGLE PRECISION arithmetic !! ZLAG2C checks that all the entries of A are between -RMAX and @@ -37966,18 +37968,18 @@ module stdlib_linalg_lapack_w integer(ilp), intent(in) :: lda, ldsa, m, n ! Array Arguments complex(dp), intent(out) :: sa(ldsa,*) - complex(qp), intent(in) :: a(lda,*) + complex(${ck}$), intent(in) :: a(lda,*) ! ===================================================================== ! Local Scalars integer(ilp) :: i, j - real(qp) :: rmax + real(${ck}$) :: rmax ! Intrinsic Functions intrinsic :: real,aimag ! Executable Statements rmax = stdlib_dlamch( 'O' ) do j = 1, n do i = 1, m - if( ( real( a( i, j ),KIND=qp)<-rmax ) .or.( real( a( i, j ),KIND=qp)>rmax ) & + if( ( real( a( i, j ),KIND=${ck}$)<-rmax ) .or.( real( a( i, j ),KIND=${ck}$)>rmax ) & .or.( aimag( a( i, j ) )<-rmax ) .or.( aimag( a( i, j ) )>rmax ) ) then info = 1 go to 30 @@ -37988,10 +37990,10 @@ module stdlib_linalg_lapack_w info = 0 30 continue return - end subroutine stdlib_wlag2c + end subroutine stdlib_${ci}$lag2c - pure subroutine stdlib_wlags2( upper, a1, a2, a3, b1, b2, b3, csu, snu, csv,snv, csq, snq ) + pure subroutine stdlib_${ci}$lags2( upper, a1, a2, a3, b1, b2, b3, csu, snu, csv,snv, csq, snq ) !! ZLAGS2: computes 2-by-2 unitary matrices U, V and Q, such !! that if ( UPPER ) then !! U**H *A*Q = U**H *( A1 A2 )*Q = ( x 0 ) @@ -38022,22 +38024,22 @@ module stdlib_linalg_lapack_w ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments logical(lk), intent(in) :: upper - real(qp), intent(in) :: a1, a3, b1, b3 - real(qp), intent(out) :: csq, csu, csv - complex(qp), intent(in) :: a2, b2 - complex(qp), intent(out) :: snq, snu, snv + real(${ck}$), intent(in) :: a1, a3, b1, b3 + real(${ck}$), intent(out) :: csq, csu, csv + complex(${ck}$), intent(in) :: a2, b2 + complex(${ck}$), intent(out) :: snq, snu, snv ! ===================================================================== ! Local Scalars - real(qp) :: a, aua11, aua12, aua21, aua22, avb12, avb11, avb21, avb22, csl, csr, d, fb,& + real(${ck}$) :: a, aua11, aua12, aua21, aua22, avb12, avb11, avb21, avb22, csl, csr, d, fb,& fc, s1, s2, snl, snr, ua11r, ua22r, vb11r, vb22r - complex(qp) :: b, c, d1, r, t, ua11, ua12, ua21, ua22, vb11, vb12, vb21, vb22 + complex(${ck}$) :: b, c, d1, r, t, ua11, ua12, ua21, ua22, vb11, vb12, vb21, vb22 ! Intrinsic Functions intrinsic :: abs,real,cmplx,conjg,aimag ! Statement Functions - real(qp) :: abs1 + real(${ck}$) :: abs1 ! Statement Function Definitions - abs1( t ) = abs( real( t,KIND=qp) ) + abs( aimag( t ) ) + abs1( t ) = abs( real( t,KIND=${ck}$) ) + abs( aimag( t ) ) ! Executable Statements if( upper ) then ! input matrices a and b are upper triangular matrices @@ -38054,7 +38056,7 @@ module stdlib_linalg_lapack_w ! the svd of real 2 by 2 triangular c ! ( csl -snl )*( a b )*( csr snr ) = ( r 0 ) ! ( snl csl ) ( 0 d ) ( -snr csr ) ( 0 t ) - call stdlib_qlasv2( a, fb, d, s1, s2, snr, csr, snl, csl ) + call stdlib_${c2ri(ci)}$lasv2( a, fb, d, s1, s2, snr, csr, snl, csl ) if( abs( csl )>=abs( snl ) .or. abs( csr )>=abs( snr ) )then ! compute the (1,1) and (1,2) elements of u**h *a and v**h *b, ! and (1,2) element of |u|**h *|a| and |v|**h *|b|. @@ -38066,17 +38068,17 @@ module stdlib_linalg_lapack_w avb12 = abs( csr )*abs1( b2 ) + abs( snr )*abs( b3 ) ! zero (1,2) elements of u**h *a and v**h *b if( ( abs( ua11r )+abs1( ua12 ) )==zero ) then - call stdlib_wlartg( -cmplx( vb11r,KIND=qp), conjg( vb12 ), csq, snq,r ) + call stdlib_${ci}$lartg( -cmplx( vb11r,KIND=${ck}$), conjg( vb12 ), csq, snq,r ) else if( ( abs( vb11r )+abs1( vb12 ) )==zero ) then - call stdlib_wlartg( -cmplx( ua11r,KIND=qp), conjg( ua12 ), csq, snq,r ) + call stdlib_${ci}$lartg( -cmplx( ua11r,KIND=${ck}$), conjg( ua12 ), csq, snq,r ) else if( aua12 / ( abs( ua11r )+abs1( ua12 ) )<=avb12 /( abs( vb11r )+abs1( vb12 & ) ) ) then - call stdlib_wlartg( -cmplx( ua11r,KIND=qp), conjg( ua12 ), csq, snq,r ) + call stdlib_${ci}$lartg( -cmplx( ua11r,KIND=${ck}$), conjg( ua12 ), csq, snq,r ) else - call stdlib_wlartg( -cmplx( vb11r,KIND=qp), conjg( vb12 ), csq, snq,r ) + call stdlib_${ci}$lartg( -cmplx( vb11r,KIND=${ck}$), conjg( vb12 ), csq, snq,r ) end if csu = csl @@ -38094,14 +38096,14 @@ module stdlib_linalg_lapack_w avb22 = abs( snr )*abs1( b2 ) + abs( csr )*abs( b3 ) ! zero (2,2) elements of u**h *a and v**h *b, and then swap. if( ( abs1( ua21 )+abs1( ua22 ) )==zero ) then - call stdlib_wlartg( -conjg( vb21 ), conjg( vb22 ), csq, snq,r ) + call stdlib_${ci}$lartg( -conjg( vb21 ), conjg( vb22 ), csq, snq,r ) else if( ( abs1( vb21 )+abs( vb22 ) )==zero ) then - call stdlib_wlartg( -conjg( ua21 ), conjg( ua22 ), csq, snq,r ) + call stdlib_${ci}$lartg( -conjg( ua21 ), conjg( ua22 ), csq, snq,r ) else if( aua22 / ( abs1( ua21 )+abs1( ua22 ) )<=avb22 /( abs1( vb21 )+abs1( vb22 & ) ) ) then - call stdlib_wlartg( -conjg( ua21 ), conjg( ua22 ), csq, snq,r ) + call stdlib_${ci}$lartg( -conjg( ua21 ), conjg( ua22 ), csq, snq,r ) else - call stdlib_wlartg( -conjg( vb21 ), conjg( vb22 ), csq, snq,r ) + call stdlib_${ci}$lartg( -conjg( vb21 ), conjg( vb22 ), csq, snq,r ) end if csu = snl snu = d1*csl @@ -38123,7 +38125,7 @@ module stdlib_linalg_lapack_w ! the svd of real 2 by 2 triangular c ! ( csl -snl )*( a 0 )*( csr snr ) = ( r 0 ) ! ( snl csl ) ( c d ) ( -snr csr ) ( 0 t ) - call stdlib_qlasv2( a, fc, d, s1, s2, snr, csr, snl, csl ) + call stdlib_${c2ri(ci)}$lasv2( a, fc, d, s1, s2, snr, csr, snl, csl ) if( abs( csr )>=abs( snr ) .or. abs( csl )>=abs( snl ) )then ! compute the (2,1) and (2,2) elements of u**h *a and v**h *b, ! and (2,1) element of |u|**h *|a| and |v|**h *|b|. @@ -38135,14 +38137,14 @@ module stdlib_linalg_lapack_w avb21 = abs( snl )*abs( b1 ) + abs( csl )*abs1( b2 ) ! zero (2,1) elements of u**h *a and v**h *b. if( ( abs1( ua21 )+abs( ua22r ) )==zero ) then - call stdlib_wlartg( cmplx( vb22r,KIND=qp), vb21, csq, snq, r ) + call stdlib_${ci}$lartg( cmplx( vb22r,KIND=${ck}$), vb21, csq, snq, r ) else if( ( abs1( vb21 )+abs( vb22r ) )==zero ) then - call stdlib_wlartg( cmplx( ua22r,KIND=qp), ua21, csq, snq, r ) + call stdlib_${ci}$lartg( cmplx( ua22r,KIND=${ck}$), ua21, csq, snq, r ) else if( aua21 / ( abs1( ua21 )+abs( ua22r ) )<=avb21 /( abs1( vb21 )+abs( vb22r & ) ) ) then - call stdlib_wlartg( cmplx( ua22r,KIND=qp), ua21, csq, snq, r ) + call stdlib_${ci}$lartg( cmplx( ua22r,KIND=${ck}$), ua21, csq, snq, r ) else - call stdlib_wlartg( cmplx( vb22r,KIND=qp), vb21, csq, snq, r ) + call stdlib_${ci}$lartg( cmplx( vb22r,KIND=${ck}$), vb21, csq, snq, r ) end if csu = csr snu = -conjg( d1 )*snr @@ -38159,14 +38161,14 @@ module stdlib_linalg_lapack_w avb11 = abs( csl )*abs( b1 ) + abs( snl )*abs1( b2 ) ! zero (1,1) elements of u**h *a and v**h *b, and then swap. if( ( abs1( ua11 )+abs1( ua12 ) )==zero ) then - call stdlib_wlartg( vb12, vb11, csq, snq, r ) + call stdlib_${ci}$lartg( vb12, vb11, csq, snq, r ) else if( ( abs1( vb11 )+abs1( vb12 ) )==zero ) then - call stdlib_wlartg( ua12, ua11, csq, snq, r ) + call stdlib_${ci}$lartg( ua12, ua11, csq, snq, r ) else if( aua11 / ( abs1( ua11 )+abs1( ua12 ) )<=avb11 /( abs1( vb11 )+abs1( vb12 & ) ) ) then - call stdlib_wlartg( ua12, ua11, csq, snq, r ) + call stdlib_${ci}$lartg( ua12, ua11, csq, snq, r ) else - call stdlib_wlartg( vb12, vb11, csq, snq, r ) + call stdlib_${ci}$lartg( vb12, vb11, csq, snq, r ) end if csu = snr snu = conjg( d1 )*csr @@ -38175,10 +38177,10 @@ module stdlib_linalg_lapack_w end if end if return - end subroutine stdlib_wlags2 + end subroutine stdlib_${ci}$lags2 - pure subroutine stdlib_wlagtm( trans, n, nrhs, alpha, dl, d, du, x, ldx, beta,b, ldb ) + pure subroutine stdlib_${ci}$lagtm( trans, n, nrhs, alpha, dl, d, du, x, ldx, beta,b, ldb ) !! ZLAGTM: performs a matrix-vector product of the form !! B := alpha * A * X + beta * B !! where A is a tridiagonal matrix of order N, B and X are N by NRHS @@ -38191,10 +38193,10 @@ module stdlib_linalg_lapack_w ! Scalar Arguments character, intent(in) :: trans integer(ilp), intent(in) :: ldb, ldx, n, nrhs - real(qp), intent(in) :: alpha, beta + real(${ck}$), intent(in) :: alpha, beta ! Array Arguments - complex(qp), intent(inout) :: b(ldb,*) - complex(qp), intent(in) :: d(*), dl(*), du(*), x(ldx,*) + complex(${ck}$), intent(inout) :: b(ldb,*) + complex(${ck}$), intent(in) :: d(*), dl(*), du(*), x(ldx,*) ! ===================================================================== ! Local Scalars @@ -38311,10 +38313,10 @@ module stdlib_linalg_lapack_w end if end if return - end subroutine stdlib_wlagtm + end subroutine stdlib_${ci}$lagtm - pure subroutine stdlib_wlahef( uplo, n, nb, kb, a, lda, ipiv, w, ldw, info ) + pure subroutine stdlib_${ci}$lahef( uplo, n, nb, kb, a, lda, ipiv, w, ldw, info ) !! ZLAHEF: computes a partial factorization of a complex Hermitian !! matrix A using the Bunch-Kaufman diagonal pivoting method. The !! partial factorization has the form: @@ -38337,24 +38339,24 @@ module stdlib_linalg_lapack_w integer(ilp), intent(in) :: lda, ldw, n, nb ! Array Arguments integer(ilp), intent(out) :: ipiv(*) - complex(qp), intent(inout) :: a(lda,*) - complex(qp), intent(out) :: w(ldw,*) + complex(${ck}$), intent(inout) :: a(lda,*) + complex(${ck}$), intent(out) :: w(ldw,*) ! ===================================================================== ! Parameters - real(qp), parameter :: sevten = 17.0e+0_qp + real(${ck}$), parameter :: sevten = 17.0e+0_${ck}$ ! Local Scalars integer(ilp) :: imax, j, jb, jj, jmax, jp, k, kk, kkw, kp, kstep, kw - real(qp) :: absakk, alpha, colmax, r1, rowmax, t - complex(qp) :: d11, d21, d22, z + real(${ck}$) :: absakk, alpha, colmax, r1, rowmax, t + complex(${ck}$) :: d11, d21, d22, z ! Intrinsic Functions intrinsic :: abs,real,conjg,aimag,max,min,sqrt ! Statement Functions - real(qp) :: cabs1 + real(${ck}$) :: cabs1 ! Statement Function Definitions - cabs1( z ) = abs( real( z,KIND=qp) ) + abs( aimag( z ) ) + cabs1( z ) = abs( real( z,KIND=${ck}$) ) + abs( aimag( z ) ) ! Executable Statements info = 0 ! initialize alpha for use in choosing pivot block size. @@ -38372,21 +38374,21 @@ module stdlib_linalg_lapack_w if( ( k<=n-nb+1 .and. nb1 ) then - imax = stdlib_iwamax( k-1, w( 1, kw ), 1 ) + imax = stdlib_i${ci}$amax( k-1, w( 1, kw ), 1 ) colmax = cabs1( w( imax, kw ) ) else colmax = zero @@ -38395,7 +38397,7 @@ module stdlib_linalg_lapack_w ! column k is zero or underflow: set info and continue if( info==0 )info = k kp = k - a( k, k ) = real( a( k, k ),KIND=qp) + a( k, k ) = real( a( k, k ),KIND=${ck}$) else ! ============================================================ ! begin pivot search @@ -38406,23 +38408,23 @@ module stdlib_linalg_lapack_w else ! begin pivot search along imax row ! copy column imax to column kw-1 of w and update it - call stdlib_wcopy( imax-1, a( 1, imax ), 1, w( 1, kw-1 ), 1 ) - w( imax, kw-1 ) = real( a( imax, imax ),KIND=qp) - call stdlib_wcopy( k-imax, a( imax, imax+1 ), lda,w( imax+1, kw-1 ), 1 ) + call stdlib_${ci}$copy( imax-1, a( 1, imax ), 1, w( 1, kw-1 ), 1 ) + w( imax, kw-1 ) = real( a( imax, imax ),KIND=${ck}$) + call stdlib_${ci}$copy( k-imax, a( imax, imax+1 ), lda,w( imax+1, kw-1 ), 1 ) - call stdlib_wlacgv( k-imax, w( imax+1, kw-1 ), 1 ) + call stdlib_${ci}$lacgv( k-imax, w( imax+1, kw-1 ), 1 ) if( k1 ) then - jmax = stdlib_iwamax( imax-1, w( 1, kw-1 ), 1 ) + jmax = stdlib_i${ci}$amax( imax-1, w( 1, kw-1 ), 1 ) rowmax = max( rowmax, cabs1( w( jmax, kw-1 ) ) ) end if ! case(2) @@ -38430,12 +38432,12 @@ module stdlib_linalg_lapack_w ! no interchange, use 1-by-1 pivot block kp = k ! case(3) - else if( abs( real( w( imax, kw-1 ),KIND=qp) )>=alpha*rowmax )then + else if( abs( real( w( imax, kw-1 ),KIND=${ck}$) )>=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_wcopy( k, w( 1, kw-1 ), 1, w( 1, kw ), 1 ) + call stdlib_${ci}$copy( k, w( 1, kw-1 ), 1, w( 1, kw ), 1 ) ! case(4) else ! interchange rows and columns k-1 and imax, use 2-by-2 @@ -38458,16 +38460,16 @@ module stdlib_linalg_lapack_w ! at step k. no need to copy element into column k ! (or k and k-1 for 2-by-2 pivot) of a, since these columns ! will be later overwritten. - a( kp, kp ) = real( a( kk, kk ),KIND=qp) - call stdlib_wcopy( kk-1-kp, a( kp+1, kk ), 1, a( kp, kp+1 ),lda ) - call stdlib_wlacgv( kk-1-kp, a( kp, kp+1 ), lda ) - if( kp>1 )call stdlib_wcopy( kp-1, a( 1, kk ), 1, a( 1, kp ), 1 ) + a( kp, kp ) = real( a( kk, kk ),KIND=${ck}$) + call stdlib_${ci}$copy( kk-1-kp, a( kp+1, kk ), 1, a( kp, kp+1 ),lda ) + call stdlib_${ci}$lacgv( kk-1-kp, a( kp, kp+1 ), lda ) + if( kp>1 )call stdlib_${ci}$copy( kp-1, a( 1, kk ), 1, a( 1, kp ), 1 ) ! interchange rows kk and kp in last k+1 to n columns of a ! (columns k (or k and k-1 for 2-by-2 pivot) of a will be ! later overwritten). interchange rows kk and kp ! in last kkw to nb columns of w. - if( k1 ) then ! (note: no need to check if a(k,k) is not zero, ! since that was ensured earlier in pivot search: ! case a(k,k) = 0 falls into 2x2 pivot case(4)) - r1 = one / real( a( k, k ),KIND=qp) - call stdlib_wdscal( k-1, r1, a( 1, k ), 1 ) + r1 = one / real( a( k, k ),KIND=${ck}$) + call stdlib_${ci}$dscal( k-1, r1, a( 1, k ), 1 ) ! (2) conjugate column w(kw) - call stdlib_wlacgv( k-1, w( 1, kw ), 1 ) + call stdlib_${ci}$lacgv( k-1, w( 1, kw ), 1 ) end if else ! 2-by-2 pivot block d(k): columns kw and kw-1 of w now hold @@ -38538,7 +38540,7 @@ module stdlib_linalg_lapack_w d21 = w( k-1, kw ) d11 = w( k, kw ) / conjg( d21 ) d22 = w( k-1, kw-1 ) / d21 - t = one / ( real( d11*d22,KIND=qp)-one ) + t = one / ( real( d11*d22,KIND=${ck}$)-one ) d21 = t / d21 ! update elements in columns a(k-1) and a(k) as ! dot products of rows of ( w(kw-1) w(kw) ) and columns @@ -38553,8 +38555,8 @@ module stdlib_linalg_lapack_w a( k-1, k ) = w( k-1, kw ) a( k, k ) = w( k, kw ) ! (2) conjugate columns w(kw) and w(kw-1) - call stdlib_wlacgv( k-1, w( 1, kw ), 1 ) - call stdlib_wlacgv( k-2, w( 1, kw-1 ), 1 ) + call stdlib_${ci}$lacgv( k-1, w( 1, kw ), 1 ) + call stdlib_${ci}$lacgv( k-2, w( 1, kw-1 ), 1 ) end if end if ! store details of the interchanges in ipiv @@ -38576,13 +38578,13 @@ module stdlib_linalg_lapack_w jb = min( nb, k-j+1 ) ! update the upper triangle of the diagonal block do jj = j, j + jb - 1 - a( jj, jj ) = real( a( jj, jj ),KIND=qp) - call stdlib_wgemv( 'NO TRANSPOSE', jj-j+1, n-k, -cone,a( j, k+1 ), lda, w( jj,& + a( jj, jj ) = real( a( jj, jj ),KIND=${ck}$) + call stdlib_${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 ) - a( jj, jj ) = real( a( jj, jj ),KIND=qp) + a( jj, jj ) = real( a( jj, jj ),KIND=${ck}$) end do ! update the rectangular superdiagonal block - call stdlib_wgemm( 'NO TRANSPOSE', 'TRANSPOSE', j-1, jb, n-k,-cone, a( 1, k+1 ), & + call stdlib_${ci}$gemm( 'NO TRANSPOSE', 'TRANSPOSE', j-1, jb, n-k,-cone, a( 1, k+1 ), & lda, w( j, kw+1 ), ldw,cone, a( 1, j ), lda ) end do ! put u12 in standard form by partially undoing the interchanges @@ -38602,7 +38604,7 @@ module stdlib_linalg_lapack_w ! (note: here, j is used to determine row length. length n-j+1 ! of the rows to swap back doesn't include diagonal element) j = j + 1 - if( jp/=jj .and. j<=n )call stdlib_wswap( n-j+1, a( jp, j ), lda, a( jj, j ), & + if( jp/=jj .and. j<=n )call stdlib_${ci}$swap( n-j+1, a( jp, j ), lda, a( jj, j ), & lda ) if( j=nb .and. nbn )go to 90 kstep = 1 ! copy column k of a to column k of w and update it - w( k, k ) = real( a( k, k ),KIND=qp) - if( k=alpha*rowmax )then + else if( abs( real( w( imax, k+1 ),KIND=${ck}$) )>=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_wcopy( n-k+1, w( k, k+1 ), 1, w( k, k ), 1 ) + call stdlib_${ci}$copy( n-k+1, w( k, k+1 ), 1, w( k, k ), 1 ) ! case(4) else ! interchange rows and columns k+1 and imax, use 2-by-2 @@ -38698,17 +38700,17 @@ module stdlib_linalg_lapack_w ! at step k. no need to copy element into column k ! (or k and k+1 for 2-by-2 pivot) of a, since these columns ! will be later overwritten. - a( kp, kp ) = real( a( kk, kk ),KIND=qp) - call stdlib_wcopy( kp-kk-1, a( kk+1, kk ), 1, a( kp, kk+1 ),lda ) - call stdlib_wlacgv( kp-kk-1, a( kp, kk+1 ), lda ) - if( kp1 )call stdlib_wswap( k-1, a( kk, 1 ), lda, a( kp, 1 ), lda ) - call stdlib_wswap( kk, w( kk, 1 ), ldw, w( kp, 1 ), ldw ) + if( k>1 )call stdlib_${ci}$swap( k-1, a( kk, 1 ), lda, a( kp, 1 ), lda ) + call stdlib_${ci}$swap( kk, w( kk, 1 ), ldw, w( kp, 1 ), ldw ) end if if( kstep==1 ) then ! 1-by-1 pivot block d(k): column k of w now holds @@ -38721,17 +38723,17 @@ module stdlib_linalg_lapack_w ! a(k,k) := d(k,k) = w(k,k) ! a(k+1:n,k) := l(k+1:n,k) = w(k+1:n,k)/d(k,k) ! (note: no need to use for hermitian matrix - ! a( k, k ) = real( w( k, k),KIND=qp) to separately copy diagonal + ! a( k, k ) = real( w( k, k),KIND=${ck}$) to separately copy diagonal ! element d(k,k) from w (potentially saves only one load)) - call stdlib_wcopy( n-k+1, w( k, k ), 1, a( k, k ), 1 ) + call stdlib_${ci}$copy( n-k+1, w( k, k ), 1, a( k, k ), 1 ) if( k=1 )call stdlib_wswap( j, a( jp, 1 ), lda, a( jj, 1 ), lda ) + if( jp/=jj .and. j>=1 )call stdlib_${ci}$swap( j, a( jp, 1 ), lda, a( jj, 1 ), lda ) if( j>1 )go to 120 ! set kb to the number of columns factorized kb = k - 1 end if return - end subroutine stdlib_wlahef + end subroutine stdlib_${ci}$lahef - pure subroutine stdlib_wlahef_aa( uplo, j1, m, nb, a, lda, ipiv,h, ldh, work ) + pure subroutine stdlib_${ci}$lahef_aa( uplo, j1, m, nb, a, lda, ipiv,h, ldh, work ) !! DLAHEF_AA factorizes a panel of a complex hermitian matrix A using !! the Aasen's algorithm. The panel consists of a set of NB rows of A !! when UPLO is U, or a set of NB columns when UPLO is L. @@ -38872,13 +38874,13 @@ module stdlib_linalg_lapack_w integer(ilp), intent(in) :: m, nb, j1, lda, ldh ! Array Arguments integer(ilp), intent(out) :: ipiv(*) - complex(qp), intent(inout) :: a(lda,*), h(ldh,*) - complex(qp), intent(out) :: work(*) + complex(${ck}$), intent(inout) :: a(lda,*), h(ldh,*) + complex(${ck}$), intent(out) :: work(*) ! ===================================================================== ! Local Scalars integer(ilp) :: j, k, k1, i1, i2, mj - complex(qp) :: piv, alpha + complex(${ck}$) :: piv, alpha ! Intrinsic Functions intrinsic :: real,conjg,max ! Executable Statements @@ -38893,7 +38895,7 @@ module stdlib_linalg_lapack_w 10 continue if ( j>min(m, nb) )go to 20 ! k is the column to be factorized - ! when being called from stdlib_whetrf_aa, + ! when being called from stdlib_${ci}$hetrf_aa, ! > for the first block column, j1 is 1, hence j1+j-1 is j, ! > for the rest of the columns, j1 is 2, and j1+j-1 is j+1, k = j1+j-1 @@ -38911,30 +38913,30 @@ module stdlib_linalg_lapack_w ! columns ! > for the rest of the columns, k is j+1, skipping only the ! first column - call stdlib_wlacgv( j-k1, a( 1, j ), 1 ) - call stdlib_wgemv( 'NO TRANSPOSE', mj, j-k1,-cone, h( j, k1 ), ldh,a( 1, j ), 1,& + call stdlib_${ci}$lacgv( j-k1, a( 1, j ), 1 ) + call stdlib_${ci}$gemv( 'NO TRANSPOSE', mj, j-k1,-cone, h( j, k1 ), ldh,a( 1, j ), 1,& cone, h( j, j ), 1 ) - call stdlib_wlacgv( j-k1, a( 1, j ), 1 ) + call stdlib_${ci}$lacgv( j-k1, a( 1, j ), 1 ) end if ! copy h(i:n, i) into work - call stdlib_wcopy( mj, h( j, j ), 1, work( 1 ), 1 ) + call stdlib_${ci}$copy( mj, h( j, j ), 1, work( 1 ), 1 ) if( j>k1 ) then ! compute work := work - l(j-1, j:n) * t(j-1,j), ! where a(j-1, j) stores t(j-1, j) and a(j-2, j:n) stores u(j-1, j:n) alpha = -conjg( a( k-1, j ) ) - call stdlib_waxpy( mj, alpha, a( k-2, j ), lda, work( 1 ), 1 ) + call stdlib_${ci}$axpy( mj, alpha, a( k-2, j ), lda, work( 1 ), 1 ) end if ! set a(j, j) = t(j, j) - a( k, j ) = real( work( 1 ),KIND=qp) + a( k, j ) = real( work( 1 ),KIND=${ck}$) if( j1 ) then alpha = -a( k, j ) - call stdlib_waxpy( m-j, alpha, a( k-1, j+1 ), lda,work( 2 ), 1 ) + call stdlib_${ci}$axpy( m-j, alpha, a( k-1, j+1 ), lda,work( 2 ), 1 ) endif ! find max(|work(2:n)|) - i2 = stdlib_iwamax( m-j, work( 2 ), 1 ) + 1 + i2 = stdlib_i${ci}$amax( m-j, work( 2 ), 1 ) + 1 piv = work( i2 ) ! apply hermitian pivot if( (i2/=2) .and. (piv/=0) ) then @@ -38945,24 +38947,24 @@ module stdlib_linalg_lapack_w ! swap a(i1, i1+1:n) with a(i1+1:n, i2) i1 = i1+j-1 i2 = i2+j-1 - call stdlib_wswap( i2-i1-1, a( j1+i1-1, i1+1 ), lda,a( j1+i1, i2 ), 1 ) + call stdlib_${ci}$swap( i2-i1-1, a( j1+i1-1, i1+1 ), lda,a( j1+i1, i2 ), 1 ) - call stdlib_wlacgv( i2-i1, a( j1+i1-1, i1+1 ), lda ) - call stdlib_wlacgv( i2-i1-1, a( j1+i1, i2 ), 1 ) + call stdlib_${ci}$lacgv( i2-i1, a( j1+i1-1, i1+1 ), lda ) + call stdlib_${ci}$lacgv( i2-i1-1, a( j1+i1, i2 ), 1 ) ! swap a(i1, i2+1:n) with a(i2, i2+1:n) - if( i2(k1-1) ) then ! swap l(1:i1-1, i1) with l(1:i1-1, i2), ! skipping the first column - call stdlib_wswap( i1-k1+1, a( 1, i1 ), 1,a( 1, i2 ), 1 ) + call stdlib_${ci}$swap( i1-k1+1, a( 1, i1 ), 1,a( 1, i2 ), 1 ) end if else ipiv( j+1 ) = j+1 @@ -38971,17 +38973,17 @@ module stdlib_linalg_lapack_w a( k, j+1 ) = work( 2 ) if( jmin( m, nb ) )go to 40 ! k is the column to be factorized - ! when being called from stdlib_whetrf_aa, + ! when being called from stdlib_${ci}$hetrf_aa, ! > for the first block column, j1 is 1, hence j1+j-1 is j, ! > for the rest of the columns, j1 is 2, and j1+j-1 is j+1, k = j1+j-1 @@ -39014,30 +39016,30 @@ module stdlib_linalg_lapack_w ! columns ! > for the rest of the columns, k is j+1, skipping only the ! first column - call stdlib_wlacgv( j-k1, a( j, 1 ), lda ) - call stdlib_wgemv( 'NO TRANSPOSE', mj, j-k1,-cone, h( j, k1 ), ldh,a( j, 1 ), & + call stdlib_${ci}$lacgv( j-k1, a( j, 1 ), lda ) + call stdlib_${ci}$gemv( 'NO TRANSPOSE', mj, j-k1,-cone, h( j, k1 ), ldh,a( j, 1 ), & lda,cone, h( j, j ), 1 ) - call stdlib_wlacgv( j-k1, a( j, 1 ), lda ) + call stdlib_${ci}$lacgv( j-k1, a( j, 1 ), lda ) end if ! copy h(j:n, j) into work - call stdlib_wcopy( mj, h( j, j ), 1, work( 1 ), 1 ) + call stdlib_${ci}$copy( mj, h( j, j ), 1, work( 1 ), 1 ) if( j>k1 ) then ! compute work := work - l(j:n, j-1) * t(j-1,j), ! where a(j-1, j) = t(j-1, j) and a(j, j-2) = l(j, j-1) alpha = -conjg( a( j, k-1 ) ) - call stdlib_waxpy( mj, alpha, a( j, k-2 ), 1, work( 1 ), 1 ) + call stdlib_${ci}$axpy( mj, alpha, a( j, k-2 ), 1, work( 1 ), 1 ) end if ! set a(j, j) = t(j, j) - a( j, k ) = real( work( 1 ),KIND=qp) + a( j, k ) = real( work( 1 ),KIND=${ck}$) if( j1 ) then alpha = -a( j, k ) - call stdlib_waxpy( m-j, alpha, a( j+1, k-1 ), 1,work( 2 ), 1 ) + call stdlib_${ci}$axpy( m-j, alpha, a( j+1, k-1 ), 1,work( 2 ), 1 ) endif ! find max(|work(2:n)|) - i2 = stdlib_iwamax( m-j, work( 2 ), 1 ) + 1 + i2 = stdlib_i${ci}$amax( m-j, work( 2 ), 1 ) + 1 piv = work( i2 ) ! apply hermitian pivot if( (i2/=2) .and. (piv/=0) ) then @@ -39048,24 +39050,24 @@ module stdlib_linalg_lapack_w ! swap a(i1+1:n, i1) with a(i2, i1+1:n) i1 = i1+j-1 i2 = i2+j-1 - call stdlib_wswap( i2-i1-1, a( i1+1, j1+i1-1 ), 1,a( i2, j1+i1 ), lda ) + call stdlib_${ci}$swap( i2-i1-1, a( i1+1, j1+i1-1 ), 1,a( i2, j1+i1 ), lda ) - call stdlib_wlacgv( i2-i1, a( i1+1, j1+i1-1 ), 1 ) - call stdlib_wlacgv( i2-i1-1, a( i2, j1+i1 ), lda ) + call stdlib_${ci}$lacgv( i2-i1, a( i1+1, j1+i1-1 ), 1 ) + call stdlib_${ci}$lacgv( i2-i1-1, a( i2, j1+i1 ), lda ) ! swap a(i2+1:n, i1) with a(i2+1:n, i2) - if( i2(k1-1) ) then ! swap l(1:i1-1, i1) with l(1:i1-1, i2), ! skipping the first column - call stdlib_wswap( i1-k1+1, a( i1, 1 ), lda,a( i2, 1 ), lda ) + call stdlib_${ci}$swap( i1-k1+1, a( i1, 1 ), lda,a( i2, 1 ), lda ) end if else ipiv( j+1 ) = j+1 @@ -39074,17 +39076,17 @@ module stdlib_linalg_lapack_w a( j+1, k ) = work( 2 ) if( j1 )call stdlib_wcopy( k-1, a( 1, k ), 1, w( 1, kw ), 1 ) - w( k, kw ) = real( a( k, k ),KIND=qp) + if( k>1 )call stdlib_${ci}$copy( k-1, a( 1, k ), 1, w( 1, kw ), 1 ) + w( k, kw ) = real( a( k, k ),KIND=${ck}$) if( k1 ) then - imax = stdlib_iwamax( k-1, w( 1, kw ), 1 ) + imax = stdlib_i${ci}$amax( k-1, w( 1, kw ), 1 ) colmax = cabs1( w( imax, kw ) ) else colmax = zero @@ -39185,8 +39187,8 @@ module stdlib_linalg_lapack_w ! column k is zero or underflow: set info and continue if( info==0 )info = k kp = k - a( k, k ) = real( w( k, kw ),KIND=qp) - if( k>1 )call stdlib_wcopy( k-1, w( 1, kw ), 1, a( 1, k ), 1 ) + a( k, k ) = real( w( k, kw ),KIND=${ck}$) + if( k>1 )call stdlib_${ci}$copy( k-1, w( 1, kw ), 1, a( 1, k ), 1 ) ! set e( k ) to zero if( k>1 )e( k ) = czero else @@ -39204,28 +39206,28 @@ module stdlib_linalg_lapack_w 12 continue ! begin pivot search loop body ! copy column imax to column kw-1 of w and update it - if( imax>1 )call stdlib_wcopy( imax-1, a( 1, imax ), 1, w( 1, kw-1 ),1 ) + if( imax>1 )call stdlib_${ci}$copy( imax-1, a( 1, imax ), 1, w( 1, kw-1 ),1 ) - w( imax, kw-1 ) = real( a( imax, imax ),KIND=qp) - call stdlib_wcopy( k-imax, a( imax, imax+1 ), lda,w( imax+1, kw-1 ), 1 ) + w( imax, kw-1 ) = real( a( imax, imax ),KIND=${ck}$) + call stdlib_${ci}$copy( k-imax, a( imax, imax+1 ), lda,w( imax+1, kw-1 ), 1 ) - call stdlib_wlacgv( k-imax, w( imax+1, kw-1 ), 1 ) + call stdlib_${ci}$lacgv( k-imax, w( imax+1, kw-1 ), 1 ) if( k1 ) then - itemp = stdlib_iwamax( imax-1, w( 1, kw-1 ), 1 ) + itemp = stdlib_i${ci}$amax( imax-1, w( 1, kw-1 ), 1 ) dtemp = cabs1( w( itemp, kw-1 ) ) if( dtemp>rowmax ) then rowmax = dtemp @@ -39234,15 +39236,15 @@ module stdlib_linalg_lapack_w end if ! case(2) ! equivalent to testing for - ! abs( real( w( imax,kw-1 ),KIND=qp) )>=alpha*rowmax + ! abs( real( w( imax,kw-1 ),KIND=${ck}$) )>=alpha*rowmax ! (used to handle nan and inf) - if( .not.( abs( real( w( imax,kw-1 ),KIND=qp) )1 )call stdlib_wcopy( p-1, a( 1, k ), 1, a( 1, p ), 1 ) + a( p, p ) = real( a( k, k ),KIND=${ck}$) + call stdlib_${ci}$copy( k-1-p, a( p+1, k ), 1, a( p, p+1 ),lda ) + call stdlib_${ci}$lacgv( k-1-p, a( p, p+1 ), lda ) + if( p>1 )call stdlib_${ci}$copy( p-1, a( 1, k ), 1, a( 1, p ), 1 ) ! interchange rows k and p in the last k+1 to n columns of a ! (columns k and k-1 of a for 2-by-2 pivot will be ! later overwritten). interchange rows k and p ! in last kkw to nb columns of w. - if( k1 )call stdlib_wcopy( kp-1, a( 1, kk ), 1, a( 1, kp ), 1 ) + a( kp, kp ) = real( a( kk, kk ),KIND=${ck}$) + call stdlib_${ci}$copy( kk-1-kp, a( kp+1, kk ), 1, a( kp, kp+1 ),lda ) + call stdlib_${ci}$lacgv( kk-1-kp, a( kp, kp+1 ), lda ) + if( kp>1 )call stdlib_${ci}$copy( kp-1, a( 1, kk ), 1, a( 1, kp ), 1 ) ! interchange rows kk and kp in last k+1 to n columns of a ! (columns k (or k and k-1 for 2-by-2 pivot) of a will be ! later overwritten). interchange rows kk and kp ! in last kkw to nb columns of w. - if( k1 ) then ! (note: no need to check if a(k,k) is not zero, ! since that was ensured earlier in pivot search: ! case a(k,k) = 0 falls into 2x2 pivot case(3)) ! handle division by a small number - t = real( a( k, k ),KIND=qp) + t = real( a( k, k ),KIND=${ck}$) if( abs( t )>=sfmin ) then r1 = one / t - call stdlib_wdscal( k-1, r1, a( 1, k ), 1 ) + call stdlib_${ci}$dscal( k-1, r1, a( 1, k ), 1 ) else do ii = 1, k-1 a( ii, k ) = a( ii, k ) / t end do end if ! (2) conjugate column w(kw) - call stdlib_wlacgv( k-1, w( 1, kw ), 1 ) + call stdlib_${ci}$lacgv( k-1, w( 1, kw ), 1 ) ! store the superdiagonal element of d in array e e( k ) = czero end if @@ -39388,7 +39390,7 @@ module stdlib_linalg_lapack_w d21 = w( k-1, kw ) d11 = w( k, kw ) / conjg( d21 ) d22 = w( k-1, kw-1 ) / d21 - t = one / ( real( d11*d22,KIND=qp)-one ) + t = one / ( real( d11*d22,KIND=${ck}$)-one ) ! update elements in columns a(k-1) and a(k) as ! dot products of rows of ( w(kw-1) w(kw) ) and columns ! of d**(-1) @@ -39406,8 +39408,8 @@ module stdlib_linalg_lapack_w e( k ) = w( k-1, kw ) e( k-1 ) = czero ! (2) conjugate columns w(kw) and w(kw-1) - call stdlib_wlacgv( k-1, w( 1, kw ), 1 ) - call stdlib_wlacgv( k-2, w( 1, kw-1 ), 1 ) + call stdlib_${ci}$lacgv( k-1, w( 1, kw ), 1 ) + call stdlib_${ci}$lacgv( k-2, w( 1, kw-1 ), 1 ) end if ! end column k is nonsingular end if @@ -39430,13 +39432,13 @@ module stdlib_linalg_lapack_w jb = min( nb, k-j+1 ) ! update the upper triangle of the diagonal block do jj = j, j + jb - 1 - a( jj, jj ) = real( a( jj, jj ),KIND=qp) - call stdlib_wgemv( 'NO TRANSPOSE', jj-j+1, n-k, -cone,a( j, k+1 ), lda, w( jj,& + a( jj, jj ) = real( a( jj, jj ),KIND=${ck}$) + call stdlib_${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 ) - a( jj, jj ) = real( a( jj, jj ),KIND=qp) + a( jj, jj ) = real( a( jj, jj ),KIND=${ck}$) end do ! update the rectangular superdiagonal block - if( j>=2 )call stdlib_wgemm( 'NO TRANSPOSE', 'TRANSPOSE', j-1, jb, n-k,-cone, a( & + if( j>=2 )call stdlib_${ci}$gemm( 'NO TRANSPOSE', 'TRANSPOSE', j-1, jb, n-k,-cone, a( & 1, k+1 ), lda, w( j, kw+1 ), ldw,cone, a( 1, j ), lda ) end do ! set kb to the number of columns factorized @@ -39455,21 +39457,21 @@ module stdlib_linalg_lapack_w kstep = 1 p = k ! copy column k of a to column k of w and update column k of w - w( k, k ) = real( a( k, k ),KIND=qp) - if( k1 ) then - call stdlib_wgemv( 'NO TRANSPOSE', n-k+1, k-1, -cone, a( k, 1 ),lda, w( k, 1 ), & + call stdlib_${ci}$gemv( 'NO TRANSPOSE', n-k+1, k-1, -cone, a( k, 1 ),lda, w( k, 1 ), & ldw, cone, w( k, k ), 1 ) - w( k, k ) = real( w( k, k ),KIND=qp) + w( k, k ) = real( w( k, k ),KIND=${ck}$) end if ! determine rows and columns to be interchanged and whether ! a 1-by-1 or 2-by-2 pivot block will be used - absakk = abs( real( w( k, k ),KIND=qp) ) + absakk = abs( real( w( k, k ),KIND=${ck}$) ) ! 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( k1 ) then - call stdlib_wgemv( 'NO TRANSPOSE', n-k+1, k-1, -cone,a( k, 1 ), lda, w( & + call stdlib_${ci}$gemv( 'NO TRANSPOSE', n-k+1, k-1, -cone,a( k, 1 ), lda, w( & imax, 1 ), ldw,cone, w( k, k+1 ), 1 ) - w( imax, k+1 ) = real( w( imax, k+1 ),KIND=qp) + w( imax, k+1 ) = real( w( imax, k+1 ),KIND=${ck}$) end if ! 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 + stdlib_iwamax( imax-k, w( k, k+1 ), 1 ) + jmax = k - 1 + stdlib_i${ci}$amax( imax-k, w( k, k+1 ), 1 ) rowmax = cabs1( w( jmax, k+1 ) ) else rowmax = zero end if if( imaxrowmax ) then rowmax = dtemp @@ -39526,15 +39528,15 @@ module stdlib_linalg_lapack_w end if ! case(2) ! equivalent to testing for - ! abs( real( w( imax,k+1 ),KIND=qp) )>=alpha*rowmax + ! abs( real( w( imax,k+1 ),KIND=${ck}$) )>=alpha*rowmax ! (used to handle nan and inf) - if( .not.( abs( real( w( imax,k+1 ),KIND=qp) )1 )call stdlib_wswap( k-1, a( k, 1 ), lda, a( p, 1 ), lda ) - call stdlib_wswap( kk, w( k, 1 ), ldw, w( p, 1 ), ldw ) + if( k>1 )call stdlib_${ci}$swap( k-1, a( k, 1 ), lda, a( p, 1 ), lda ) + call stdlib_${ci}$swap( kk, w( k, 1 ), ldw, w( p, 1 ), ldw ) end if ! interchange rows and columns kp and kk. ! updated column kp is already stored in column kk of w. @@ -39586,17 +39588,17 @@ module stdlib_linalg_lapack_w ! at step k. no need to copy element into column k ! (or k and k+1 for 2-by-2 pivot) of a, since these columns ! will be later overwritten. - a( kp, kp ) = real( a( kk, kk ),KIND=qp) - call stdlib_wcopy( kp-kk-1, a( kk+1, kk ), 1, a( kp, kk+1 ),lda ) - call stdlib_wlacgv( kp-kk-1, a( kp, kk+1 ), lda ) - if( kp1 )call stdlib_wswap( k-1, a( kk, 1 ), lda, a( kp, 1 ), lda ) - call stdlib_wswap( kk, w( kk, 1 ), ldw, w( kp, 1 ), ldw ) + if( k>1 )call stdlib_${ci}$swap( k-1, a( kk, 1 ), lda, a( kp, 1 ), lda ) + call stdlib_${ci}$swap( kk, w( kk, 1 ), ldw, w( kp, 1 ), ldw ) end if if( kstep==1 ) then ! 1-by-1 pivot block d(k): column k of w now holds @@ -39609,25 +39611,25 @@ module stdlib_linalg_lapack_w ! a(k,k) := d(k,k) = w(k,k) ! a(k+1:n,k) := l(k+1:n,k) = w(k+1:n,k)/d(k,k) ! (note: no need to use for hermitian matrix - ! a( k, k ) = real( w( k, k),KIND=qp) to separately copy diagonal + ! a( k, k ) = real( w( k, k),KIND=${ck}$) to separately copy diagonal ! element d(k,k) from w (potentially saves only one load)) - call stdlib_wcopy( n-k+1, w( k, k ), 1, a( k, k ), 1 ) + call stdlib_${ci}$copy( n-k+1, w( k, k ), 1, a( k, k ), 1 ) if( k=sfmin ) then r1 = one / t - call stdlib_wdscal( n-k, r1, a( k+1, k ), 1 ) + call stdlib_${ci}$dscal( n-k, r1, a( k+1, k ), 1 ) else do ii = k + 1, n a( ii, k ) = a( ii, k ) / t end do end if ! (2) conjugate column w(k) - call stdlib_wlacgv( n-k, w( k+1, k ), 1 ) + call stdlib_${ci}$lacgv( n-k, w( k+1, k ), 1 ) ! store the subdiagonal element of d in array e e( k ) = czero end if @@ -39679,7 +39681,7 @@ module stdlib_linalg_lapack_w d21 = w( k+1, k ) d11 = w( k+1, k+1 ) / d21 d22 = w( k, k ) / conjg( d21 ) - t = one / ( real( d11*d22,KIND=qp)-one ) + t = one / ( real( d11*d22,KIND=${ck}$)-one ) ! update elements in columns a(k) and a(k+1) as ! dot products of rows of ( w(k) w(k+1) ) and columns ! of d**(-1) @@ -39697,8 +39699,8 @@ module stdlib_linalg_lapack_w e( k ) = w( k+1, k ) e( k+1 ) = czero ! (2) conjugate columns w(k) and w(k+1) - call stdlib_wlacgv( n-k, w( k+1, k ), 1 ) - call stdlib_wlacgv( n-k-1, w( k+2, k+1 ), 1 ) + call stdlib_${ci}$lacgv( n-k, w( k+1, k ), 1 ) + call stdlib_${ci}$lacgv( n-k-1, w( k+2, k+1 ), 1 ) end if ! end column k is nonsingular end if @@ -39721,23 +39723,23 @@ module stdlib_linalg_lapack_w jb = min( nb, n-j+1 ) ! update the lower triangle of the diagonal block do jj = j, j + jb - 1 - a( jj, jj ) = real( a( jj, jj ),KIND=qp) - call stdlib_wgemv( 'NO TRANSPOSE', j+jb-jj, k-1, -cone,a( jj, 1 ), lda, w( jj,& + a( jj, jj ) = real( a( jj, jj ),KIND=${ck}$) + call stdlib_${ci}$gemv( 'NO TRANSPOSE', j+jb-jj, k-1, -cone,a( jj, 1 ), lda, w( jj,& 1 ), ldw, cone,a( jj, jj ), 1 ) - a( jj, jj ) = real( a( jj, jj ),KIND=qp) + a( jj, jj ) = real( a( jj, jj ),KIND=${ck}$) end do ! update the rectangular subdiagonal block - if( j+jb<=n )call stdlib_wgemm( 'NO TRANSPOSE', 'TRANSPOSE', n-j-jb+1, jb,k-1, -& + if( j+jb<=n )call stdlib_${ci}$gemm( 'NO TRANSPOSE', 'TRANSPOSE', n-j-jb+1, jb,k-1, -& cone, a( j+jb, 1 ), lda, w( j, 1 ),ldw, cone, a( j+jb, j ), lda ) end do ! set kb to the number of columns factorized kb = k - 1 end if return - end subroutine stdlib_wlahef_rk + end subroutine stdlib_${ci}$lahef_rk - pure subroutine stdlib_wlahef_rook( uplo, n, nb, kb, a, lda, ipiv, w, ldw,info ) + pure subroutine stdlib_${ci}$lahef_rook( uplo, n, nb, kb, a, lda, ipiv, w, ldw,info ) !! ZLAHEF_ROOK: computes a partial factorization of a complex Hermitian !! matrix A using the bounded Bunch-Kaufman ("rook") diagonal pivoting !! method. The partial factorization has the form: @@ -39760,11 +39762,11 @@ module stdlib_linalg_lapack_w integer(ilp), intent(in) :: lda, ldw, n, nb ! Array Arguments integer(ilp), intent(out) :: ipiv(*) - complex(qp), intent(inout) :: a(lda,*) - complex(qp), intent(out) :: w(ldw,*) + complex(${ck}$), intent(inout) :: a(lda,*) + complex(${ck}$), intent(out) :: w(ldw,*) ! ===================================================================== ! Parameters - real(qp), parameter :: sevten = 17.0e+0_qp + real(${ck}$), parameter :: sevten = 17.0e+0_${ck}$ @@ -39772,20 +39774,20 @@ module stdlib_linalg_lapack_w logical(lk) :: done integer(ilp) :: imax, itemp, ii, j, jb, jj, jmax, jp1, jp2, k, kk, kkw, kp, kstep, kw, & p - real(qp) :: absakk, alpha, colmax, dtemp, r1, rowmax, t, sfmin - complex(qp) :: d11, d21, d22, z + real(${ck}$) :: absakk, alpha, colmax, dtemp, r1, rowmax, t, sfmin + complex(${ck}$) :: d11, d21, d22, z ! Intrinsic Functions intrinsic :: abs,real,conjg,aimag,max,min,sqrt ! Statement Functions - real(qp) :: cabs1 + real(${ck}$) :: cabs1 ! Statement Function Definitions - cabs1( z ) = abs( real( z,KIND=qp) ) + abs( aimag( z ) ) + cabs1( z ) = abs( real( z,KIND=${ck}$) ) + abs( aimag( z ) ) ! Executable Statements info = 0 ! initialize alpha for use in choosing pivot block size. alpha = ( one+sqrt( sevten ) ) / eight ! compute machine safe minimum - sfmin = stdlib_qlamch( 'S' ) + sfmin = stdlib_${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 @@ -39800,21 +39802,21 @@ module stdlib_linalg_lapack_w kstep = 1 p = k ! copy column k of a to column kw of w and update it - if( k>1 )call stdlib_wcopy( k-1, a( 1, k ), 1, w( 1, kw ), 1 ) - w( k, kw ) = real( a( k, k ),KIND=qp) + if( k>1 )call stdlib_${ci}$copy( k-1, a( 1, k ), 1, w( 1, kw ), 1 ) + w( k, kw ) = real( a( k, k ),KIND=${ck}$) if( k1 ) then - imax = stdlib_iwamax( k-1, w( 1, kw ), 1 ) + imax = stdlib_i${ci}$amax( k-1, w( 1, kw ), 1 ) colmax = cabs1( w( imax, kw ) ) else colmax = zero @@ -39823,8 +39825,8 @@ module stdlib_linalg_lapack_w ! column k is zero or underflow: set info and continue if( info==0 )info = k kp = k - a( k, k ) = real( w( k, kw ),KIND=qp) - if( k>1 )call stdlib_wcopy( k-1, w( 1, kw ), 1, a( 1, k ), 1 ) + a( k, k ) = real( w( k, kw ),KIND=${ck}$) + if( k>1 )call stdlib_${ci}$copy( k-1, w( 1, kw ), 1, a( 1, k ), 1 ) else ! ============================================================ ! begin pivot search @@ -39840,28 +39842,28 @@ module stdlib_linalg_lapack_w 12 continue ! begin pivot search loop body ! copy column imax to column kw-1 of w and update it - if( imax>1 )call stdlib_wcopy( imax-1, a( 1, imax ), 1, w( 1, kw-1 ),1 ) + if( imax>1 )call stdlib_${ci}$copy( imax-1, a( 1, imax ), 1, w( 1, kw-1 ),1 ) - w( imax, kw-1 ) = real( a( imax, imax ),KIND=qp) - call stdlib_wcopy( k-imax, a( imax, imax+1 ), lda,w( imax+1, kw-1 ), 1 ) + w( imax, kw-1 ) = real( a( imax, imax ),KIND=${ck}$) + call stdlib_${ci}$copy( k-imax, a( imax, imax+1 ), lda,w( imax+1, kw-1 ), 1 ) - call stdlib_wlacgv( k-imax, w( imax+1, kw-1 ), 1 ) + call stdlib_${ci}$lacgv( k-imax, w( imax+1, kw-1 ), 1 ) if( k1 ) then - itemp = stdlib_iwamax( imax-1, w( 1, kw-1 ), 1 ) + itemp = stdlib_i${ci}$amax( imax-1, w( 1, kw-1 ), 1 ) dtemp = cabs1( w( itemp, kw-1 ) ) if( dtemp>rowmax ) then rowmax = dtemp @@ -39870,15 +39872,15 @@ module stdlib_linalg_lapack_w end if ! case(2) ! equivalent to testing for - ! abs( real( w( imax,kw-1 ),KIND=qp) )>=alpha*rowmax + ! abs( real( w( imax,kw-1 ),KIND=${ck}$) )>=alpha*rowmax ! (used to handle nan and inf) - if( .not.( abs( real( w( imax,kw-1 ),KIND=qp) )1 )call stdlib_wcopy( p-1, a( 1, k ), 1, a( 1, p ), 1 ) + a( p, p ) = real( a( k, k ),KIND=${ck}$) + call stdlib_${ci}$copy( k-1-p, a( p+1, k ), 1, a( p, p+1 ),lda ) + call stdlib_${ci}$lacgv( k-1-p, a( p, p+1 ), lda ) + if( p>1 )call stdlib_${ci}$copy( p-1, a( 1, k ), 1, a( 1, p ), 1 ) ! interchange rows k and p in the last k+1 to n columns of a ! (columns k and k-1 of a for 2-by-2 pivot will be ! later overwritten). interchange rows k and p ! in last kkw to nb columns of w. - if( k1 )call stdlib_wcopy( kp-1, a( 1, kk ), 1, a( 1, kp ), 1 ) + a( kp, kp ) = real( a( kk, kk ),KIND=${ck}$) + call stdlib_${ci}$copy( kk-1-kp, a( kp+1, kk ), 1, a( kp, kp+1 ),lda ) + call stdlib_${ci}$lacgv( kk-1-kp, a( kp, kp+1 ), lda ) + if( kp>1 )call stdlib_${ci}$copy( kp-1, a( 1, kk ), 1, a( 1, kp ), 1 ) ! interchange rows kk and kp in last k+1 to n columns of a ! (columns k (or k and k-1 for 2-by-2 pivot) of a will be ! later overwritten). interchange rows kk and kp ! in last kkw to nb columns of w. - if( k1 ) then ! (note: no need to check if a(k,k) is not zero, ! since that was ensured earlier in pivot search: ! case a(k,k) = 0 falls into 2x2 pivot case(3)) ! handle division by a small number - t = real( a( k, k ),KIND=qp) + t = real( a( k, k ),KIND=${ck}$) if( abs( t )>=sfmin ) then r1 = one / t - call stdlib_wdscal( k-1, r1, a( 1, k ), 1 ) + call stdlib_${ci}$dscal( k-1, r1, a( 1, k ), 1 ) else do ii = 1, k-1 a( ii, k ) = a( ii, k ) / t end do end if ! (2) conjugate column w(kw) - call stdlib_wlacgv( k-1, w( 1, kw ), 1 ) + call stdlib_${ci}$lacgv( k-1, w( 1, kw ), 1 ) end if else ! 2-by-2 pivot block d(k): columns kw and kw-1 of w now hold @@ -40022,7 +40024,7 @@ module stdlib_linalg_lapack_w d21 = w( k-1, kw ) d11 = w( k, kw ) / conjg( d21 ) d22 = w( k-1, kw-1 ) / d21 - t = one / ( real( d11*d22,KIND=qp)-one ) + t = one / ( real( d11*d22,KIND=${ck}$)-one ) ! update elements in columns a(k-1) and a(k) as ! dot products of rows of ( w(kw-1) w(kw) ) and columns ! of d**(-1) @@ -40036,8 +40038,8 @@ module stdlib_linalg_lapack_w a( k-1, k ) = w( k-1, kw ) a( k, k ) = w( k, kw ) ! (2) conjugate columns w(kw) and w(kw-1) - call stdlib_wlacgv( k-1, w( 1, kw ), 1 ) - call stdlib_wlacgv( k-2, w( 1, kw-1 ), 1 ) + call stdlib_${ci}$lacgv( k-1, w( 1, kw ), 1 ) + call stdlib_${ci}$lacgv( k-2, w( 1, kw-1 ), 1 ) end if end if ! store details of the interchanges in ipiv @@ -40059,13 +40061,13 @@ module stdlib_linalg_lapack_w jb = min( nb, k-j+1 ) ! update the upper triangle of the diagonal block do jj = j, j + jb - 1 - a( jj, jj ) = real( a( jj, jj ),KIND=qp) - call stdlib_wgemv( 'NO TRANSPOSE', jj-j+1, n-k, -cone,a( j, k+1 ), lda, w( jj,& + a( jj, jj ) = real( a( jj, jj ),KIND=${ck}$) + call stdlib_${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 ) - a( jj, jj ) = real( a( jj, jj ),KIND=qp) + a( jj, jj ) = real( a( jj, jj ),KIND=${ck}$) end do ! update the rectangular superdiagonal block - if( j>=2 )call stdlib_wgemm( 'NO TRANSPOSE', 'TRANSPOSE', j-1, jb, n-k,-cone, a( & + if( j>=2 )call stdlib_${ci}$gemm( 'NO TRANSPOSE', 'TRANSPOSE', j-1, jb, n-k,-cone, a( & 1, k+1 ), lda, w( j, kw+1 ), ldw,cone, a( 1, j ), lda ) end do ! put u12 in standard form by partially undoing the interchanges @@ -40089,10 +40091,10 @@ module stdlib_linalg_lapack_w ! (note: here, j is used to determine row length. length n-j+1 ! of the rows to swap back doesn't include diagonal element) j = j + 1 - if( jp2/=jj .and. j<=n )call stdlib_wswap( n-j+1, a( jp2, j ), lda, a( jj, j ), & + if( jp2/=jj .and. j<=n )call stdlib_${ci}$swap( n-j+1, a( jp2, j ), lda, a( jj, j ), & lda ) jj = jj + 1 - if( kstep==2 .and. jp1/=jj .and. j<=n )call stdlib_wswap( n-j+1, a( jp1, j ), & + if( kstep==2 .and. jp1/=jj .and. j<=n )call stdlib_${ci}$swap( n-j+1, a( jp1, j ), & lda, a( jj, j ), lda ) if( j1 ) then - call stdlib_wgemv( 'NO TRANSPOSE', n-k+1, k-1, -cone, a( k, 1 ),lda, w( k, 1 ), & + call stdlib_${ci}$gemv( 'NO TRANSPOSE', n-k+1, k-1, -cone, a( k, 1 ),lda, w( k, 1 ), & ldw, cone, w( k, k ), 1 ) - w( k, k ) = real( w( k, k ),KIND=qp) + w( k, k ) = real( w( k, k ),KIND=${ck}$) end if ! determine rows and columns to be interchanged and whether ! a 1-by-1 or 2-by-2 pivot block will be used - absakk = abs( real( w( k, k ),KIND=qp) ) + absakk = abs( real( w( k, k ),KIND=${ck}$) ) ! 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( k1 ) then - call stdlib_wgemv( 'NO TRANSPOSE', n-k+1, k-1, -cone,a( k, 1 ), lda, w( & + call stdlib_${ci}$gemv( 'NO TRANSPOSE', n-k+1, k-1, -cone,a( k, 1 ), lda, w( & imax, 1 ), ldw,cone, w( k, k+1 ), 1 ) - w( imax, k+1 ) = real( w( imax, k+1 ),KIND=qp) + w( imax, k+1 ) = real( w( imax, k+1 ),KIND=${ck}$) end if ! 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 + stdlib_iwamax( imax-k, w( k, k+1 ), 1 ) + jmax = k - 1 + stdlib_i${ci}$amax( imax-k, w( k, k+1 ), 1 ) rowmax = cabs1( w( jmax, k+1 ) ) else rowmax = zero end if if( imaxrowmax ) then rowmax = dtemp @@ -40178,15 +40180,15 @@ module stdlib_linalg_lapack_w end if ! case(2) ! equivalent to testing for - ! abs( real( w( imax,k+1 ),KIND=qp) )>=alpha*rowmax + ! abs( real( w( imax,k+1 ),KIND=${ck}$) )>=alpha*rowmax ! (used to handle nan and inf) - if( .not.( abs( real( w( imax,k+1 ),KIND=qp) )1 )call stdlib_wswap( k-1, a( k, 1 ), lda, a( p, 1 ), lda ) - call stdlib_wswap( kk, w( k, 1 ), ldw, w( p, 1 ), ldw ) + if( k>1 )call stdlib_${ci}$swap( k-1, a( k, 1 ), lda, a( p, 1 ), lda ) + call stdlib_${ci}$swap( kk, w( k, 1 ), ldw, w( p, 1 ), ldw ) end if ! interchange rows and columns kp and kk. ! updated column kp is already stored in column kk of w. @@ -40238,17 +40240,17 @@ module stdlib_linalg_lapack_w ! at step k. no need to copy element into column k ! (or k and k+1 for 2-by-2 pivot) of a, since these columns ! will be later overwritten. - a( kp, kp ) = real( a( kk, kk ),KIND=qp) - call stdlib_wcopy( kp-kk-1, a( kk+1, kk ), 1, a( kp, kk+1 ),lda ) - call stdlib_wlacgv( kp-kk-1, a( kp, kk+1 ), lda ) - if( kp1 )call stdlib_wswap( k-1, a( kk, 1 ), lda, a( kp, 1 ), lda ) - call stdlib_wswap( kk, w( kk, 1 ), ldw, w( kp, 1 ), ldw ) + if( k>1 )call stdlib_${ci}$swap( k-1, a( kk, 1 ), lda, a( kp, 1 ), lda ) + call stdlib_${ci}$swap( kk, w( kk, 1 ), ldw, w( kp, 1 ), ldw ) end if if( kstep==1 ) then ! 1-by-1 pivot block d(k): column k of w now holds @@ -40261,25 +40263,25 @@ module stdlib_linalg_lapack_w ! a(k,k) := d(k,k) = w(k,k) ! a(k+1:n,k) := l(k+1:n,k) = w(k+1:n,k)/d(k,k) ! (note: no need to use for hermitian matrix - ! a( k, k ) = real( w( k, k),KIND=qp) to separately copy diagonal + ! a( k, k ) = real( w( k, k),KIND=${ck}$) to separately copy diagonal ! element d(k,k) from w (potentially saves only one load)) - call stdlib_wcopy( n-k+1, w( k, k ), 1, a( k, k ), 1 ) + call stdlib_${ci}$copy( n-k+1, w( k, k ), 1, a( k, k ), 1 ) if( k=sfmin ) then r1 = one / t - call stdlib_wdscal( n-k, r1, a( k+1, k ), 1 ) + call stdlib_${ci}$dscal( n-k, r1, a( k+1, k ), 1 ) else do ii = k + 1, n a( ii, k ) = a( ii, k ) / t end do end if ! (2) conjugate column w(k) - call stdlib_wlacgv( n-k, w( k+1, k ), 1 ) + call stdlib_${ci}$lacgv( n-k, w( k+1, k ), 1 ) end if else ! 2-by-2 pivot block d(k): columns k and k+1 of w now hold @@ -40329,7 +40331,7 @@ module stdlib_linalg_lapack_w d21 = w( k+1, k ) d11 = w( k+1, k+1 ) / d21 d22 = w( k, k ) / conjg( d21 ) - t = one / ( real( d11*d22,KIND=qp)-one ) + t = one / ( real( d11*d22,KIND=${ck}$)-one ) ! update elements in columns a(k) and a(k+1) as ! dot products of rows of ( w(k) w(k+1) ) and columns ! of d**(-1) @@ -40343,8 +40345,8 @@ module stdlib_linalg_lapack_w a( k+1, k ) = w( k+1, k ) a( k+1, k+1 ) = w( k+1, k+1 ) ! (2) conjugate columns w(k) and w(k+1) - call stdlib_wlacgv( n-k, w( k+1, k ), 1 ) - call stdlib_wlacgv( n-k-1, w( k+2, k+1 ), 1 ) + call stdlib_${ci}$lacgv( n-k, w( k+1, k ), 1 ) + call stdlib_${ci}$lacgv( n-k-1, w( k+2, k+1 ), 1 ) end if end if ! store details of the interchanges in ipiv @@ -40366,13 +40368,13 @@ module stdlib_linalg_lapack_w jb = min( nb, n-j+1 ) ! update the lower triangle of the diagonal block do jj = j, j + jb - 1 - a( jj, jj ) = real( a( jj, jj ),KIND=qp) - call stdlib_wgemv( 'NO TRANSPOSE', j+jb-jj, k-1, -cone,a( jj, 1 ), lda, w( jj,& + a( jj, jj ) = real( a( jj, jj ),KIND=${ck}$) + call stdlib_${ci}$gemv( 'NO TRANSPOSE', j+jb-jj, k-1, -cone,a( jj, 1 ), lda, w( jj,& 1 ), ldw, cone,a( jj, jj ), 1 ) - a( jj, jj ) = real( a( jj, jj ),KIND=qp) + a( jj, jj ) = real( a( jj, jj ),KIND=${ck}$) end do ! update the rectangular subdiagonal block - if( j+jb<=n )call stdlib_wgemm( 'NO TRANSPOSE', 'TRANSPOSE', n-j-jb+1, jb,k-1, -& + if( j+jb<=n )call stdlib_${ci}$gemm( 'NO TRANSPOSE', 'TRANSPOSE', n-j-jb+1, jb,k-1, -& cone, a( j+jb, 1 ), lda, w( j, 1 ),ldw, cone, a( j+jb, j ), lda ) end do ! put l21 in standard form by partially undoing the interchanges @@ -40396,20 +40398,20 @@ module stdlib_linalg_lapack_w ! (note: here, j is used to determine row length. length j ! of the rows to swap back doesn't include diagonal element) j = j - 1 - if( jp2/=jj .and. j>=1 )call stdlib_wswap( j, a( jp2, 1 ), lda, a( jj, 1 ), lda ) + if( jp2/=jj .and. j>=1 )call stdlib_${ci}$swap( j, a( jp2, 1 ), lda, a( jj, 1 ), lda ) jj = jj -1 - if( kstep==2 .and. jp1/=jj .and. j>=1 )call stdlib_wswap( j, a( jp1, 1 ), lda, a(& + if( kstep==2 .and. jp1/=jj .and. j>=1 )call stdlib_${ci}$swap( j, a( jp1, 1 ), lda, a(& jj, 1 ), lda ) if( j>1 )go to 120 ! set kb to the number of columns factorized kb = k - 1 end if return - end subroutine stdlib_wlahef_rook + end subroutine stdlib_${ci}$lahef_rook - pure subroutine stdlib_wlahqr( wantt, wantz, n, ilo, ihi, h, ldh, w, iloz,ihiz, z, ldz, info & + pure subroutine stdlib_${ci}$lahqr( wantt, wantz, n, ilo, ihi, h, ldh, w, iloz,ihiz, z, ldz, info & !! ZLAHQR: is an auxiliary routine called by CHSEQR to update the !! eigenvalues and Schur decomposition already computed by CHSEQR, by !! dealing with the Hessenberg submatrix in rows and columns ILO to @@ -40423,31 +40425,31 @@ module stdlib_linalg_lapack_w integer(ilp), intent(out) :: info logical(lk), intent(in) :: wantt, wantz ! Array Arguments - complex(qp), intent(inout) :: h(ldh,*), z(ldz,*) - complex(qp), intent(out) :: w(*) + complex(${ck}$), intent(inout) :: h(ldh,*), z(ldz,*) + complex(${ck}$), intent(out) :: w(*) ! ========================================================= ! Parameters - real(qp), parameter :: rzero = 0.0_qp - real(qp), parameter :: rone = 1.0_qp - real(qp), parameter :: dat1 = 3.0_qp/4.0_qp + real(${ck}$), parameter :: rzero = 0.0_${ck}$ + real(${ck}$), parameter :: rone = 1.0_${ck}$ + real(${ck}$), parameter :: dat1 = 3.0_${ck}$/4.0_${ck}$ integer(ilp), parameter :: kexsh = 10 ! Local Scalars - complex(qp) :: cdum, h11, h11s, h22, sc, sum, t, t1, temp, u, v2, x, y - real(qp) :: aa, ab, ba, bb, h10, h21, rtemp, s, safmax, safmin, smlnum, sx, t2, tst, & + complex(${ck}$) :: cdum, h11, h11s, h22, sc, sum, t, t1, temp, u, v2, x, y + real(${ck}$) :: aa, ab, ba, bb, h10, h21, rtemp, s, safmax, safmin, smlnum, sx, t2, tst, & ulp integer(ilp) :: i, i1, i2, its, itmax, j, jhi, jlo, k, l, m, nh, nz, kdefl ! Local Arrays - complex(qp) :: v(2) + complex(${ck}$) :: v(2) ! Statement Functions - real(qp) :: cabs1 + real(${ck}$) :: cabs1 ! Intrinsic Functions intrinsic :: abs,real,conjg,aimag,max,min,sqrt ! Statement Function Definitions - cabs1( cdum ) = abs( real( cdum,KIND=qp) ) + abs( aimag( cdum ) ) + cabs1( cdum ) = abs( real( cdum,KIND=${ck}$) ) + abs( aimag( cdum ) ) ! Executable Statements info = 0 ! quick return if possible @@ -40478,19 +40480,19 @@ module stdlib_linalg_lapack_w sc = h( i, i-1 ) / cabs1( h( i, i-1 ) ) sc = conjg( sc ) / abs( sc ) h( i, i-1 ) = abs( h( i, i-1 ) ) - call stdlib_wscal( jhi-i+1, sc, h( i, i ), ldh ) - call stdlib_wscal( min( jhi, i+1 )-jlo+1, conjg( sc ),h( jlo, i ), 1 ) - if( wantz )call stdlib_wscal( ihiz-iloz+1, conjg( sc ), z( iloz, i ), 1 ) + call stdlib_${ci}$scal( jhi-i+1, sc, h( i, i ), ldh ) + call stdlib_${ci}$scal( min( jhi, i+1 )-jlo+1, conjg( sc ),h( jlo, i ), 1 ) + if( wantz )call stdlib_${ci}$scal( ihiz-iloz+1, conjg( sc ), z( iloz, i ), 1 ) end if end do nh = ihi - ilo + 1 nz = ihiz - iloz + 1 ! set machine-dependent constants for the stopping criterion. - safmin = stdlib_qlamch( 'SAFE MINIMUM' ) + safmin = stdlib_${c2ri(ci)}$lamch( 'SAFE MINIMUM' ) safmax = rone / safmin - call stdlib_qlabad( safmin, safmax ) - ulp = stdlib_qlamch( 'PRECISION' ) - smlnum = safmin*( real( nh,KIND=qp) / ulp ) + call stdlib_${c2ri(ci)}$labad( safmin, safmax ) + ulp = stdlib_${c2ri(ci)}$lamch( 'PRECISION' ) + smlnum = safmin*( real( nh,KIND=${ck}$) / ulp ) ! i1 and i2 are the indices of the first row and last column of h ! to which transformations must be applied. if eigenvalues only are ! being computed, i1 and i2 are set inside the main loop. @@ -40520,14 +40522,14 @@ module stdlib_linalg_lapack_w if( cabs1( h( k, k-1 ) )<=smlnum )go to 50 tst = cabs1( h( k-1, k-1 ) ) + cabs1( h( k, k ) ) if( tst==czero ) then - if( k-2>=ilo )tst = tst + abs( real( h( k-1, k-2 ),KIND=qp) ) - if( k+1<=ihi )tst = tst + abs( real( h( k+1, k ),KIND=qp) ) + if( k-2>=ilo )tst = tst + abs( real( h( k-1, k-2 ),KIND=${ck}$) ) + if( k+1<=ihi )tst = tst + abs( real( h( k+1, k ),KIND=${ck}$) ) end if ! ==== the following is a conservative small subdiagonal ! . deflation criterion due to ahues ! . 1997). it has better mathematical foundation and ! . improves accuracy in some examples. ==== - if( abs( real( h( k, k-1 ),KIND=qp) )<=ulp*tst ) then + if( abs( real( h( k, k-1 ),KIND=${ck}$) )<=ulp*tst ) then ab = max( cabs1( h( k, k-1 ) ), cabs1( h( k-1, k ) ) ) ba = min( cabs1( h( k, k-1 ) ), cabs1( h( k-1, k ) ) ) aa = max( cabs1( h( k, k ) ),cabs1( h( k-1, k-1 )-h( k, k ) ) ) @@ -40554,11 +40556,11 @@ module stdlib_linalg_lapack_w end if if( mod(kdefl,2*kexsh)==0 ) then ! exceptional shift. - s = dat1*abs( real( h( i, i-1 ),KIND=qp) ) + s = dat1*abs( real( h( i, i-1 ),KIND=${ck}$) ) t = s + h( i, i ) else if( mod(kdefl,kexsh)==0 ) then ! exceptional shift. - s = dat1*abs( real( h( l+1, l ),KIND=qp) ) + s = dat1*abs( real( h( l+1, l ),KIND=${ck}$) ) t = s + h( l, l ) else ! wilkinson's shift. @@ -40571,10 +40573,10 @@ module stdlib_linalg_lapack_w s = max( s, cabs1( x ) ) y = s*sqrt( ( x / s )**2+( u / s )**2 ) if( sx>rzero ) then - if( real( x / sx,KIND=qp)*real( y,KIND=qp)+aimag( x / sx )*aimag( y )& + if( real( x / sx,KIND=${ck}$)*real( y,KIND=${ck}$)+aimag( x / sx )*aimag( y )& m )call stdlib_wcopy( 2, h( k, k-1 ), 1, v, 1 ) - call stdlib_wlarfg( 2, v( 1 ), v( 2 ), 1, t1 ) + if( k>m )call stdlib_${ci}$copy( 2, h( k, k-1 ), 1, v, 1 ) + call stdlib_${ci}$larfg( 2, v( 1 ), v( 2 ), 1, t1 ) if( k>m ) then h( k, k-1 ) = v( 1 ) h( k+1, k-1 ) = czero end if v2 = v( 2 ) - t2 = real( t1*v2,KIND=qp) + t2 = real( t1*v2,KIND=${ck}$) ! apply g from the left to transform the rows of the matrix ! in columns k to i2. do j = k, i2 @@ -40657,10 +40659,10 @@ module stdlib_linalg_lapack_w if( m+2<=i )h( m+2, m+1 ) = h( m+2, m+1 )*temp do j = m, i if( j/=m+1 ) then - if( i2>j )call stdlib_wscal( i2-j, temp, h( j, j+1 ), ldh ) - call stdlib_wscal( j-i1, conjg( temp ), h( i1, j ), 1 ) + if( i2>j )call stdlib_${ci}$scal( i2-j, temp, h( j, j+1 ), ldh ) + call stdlib_${ci}$scal( j-i1, conjg( temp ), h( i1, j ), 1 ) if( wantz ) then - call stdlib_wscal( nz, conjg( temp ), z( iloz, j ),1 ) + call stdlib_${ci}$scal( nz, conjg( temp ), z( iloz, j ),1 ) end if end if end do @@ -40672,10 +40674,10 @@ module stdlib_linalg_lapack_w rtemp = abs( temp ) h( i, i-1 ) = rtemp temp = temp / rtemp - if( i2>i )call stdlib_wscal( i2-i, conjg( temp ), h( i, i+1 ), ldh ) - call stdlib_wscal( i-i1, temp, h( i1, i ), 1 ) + if( i2>i )call stdlib_${ci}$scal( i2-i, conjg( temp ), h( i, i+1 ), ldh ) + call stdlib_${ci}$scal( i-i1, temp, h( i1, i ), 1 ) if( wantz ) then - call stdlib_wscal( nz, temp, z( iloz, i ), 1 ) + call stdlib_${ci}$scal( nz, temp, z( iloz, i ), 1 ) end if end if end do loop_130 @@ -40692,10 +40694,10 @@ module stdlib_linalg_lapack_w go to 30 150 continue return - end subroutine stdlib_wlahqr + end subroutine stdlib_${ci}$lahqr - pure subroutine stdlib_wlahr2( n, k, nb, a, lda, tau, t, ldt, y, ldy ) + pure subroutine stdlib_${ci}$lahr2( n, k, nb, a, lda, tau, t, ldt, y, ldy ) !! ZLAHR2: reduces the first NB columns of A complex general n-BY-(n-k+1) !! matrix A so that elements below the k-th subdiagonal are zero. The !! reduction is performed by an unitary similarity transformation @@ -40708,13 +40710,13 @@ module stdlib_linalg_lapack_w ! Scalar Arguments integer(ilp), intent(in) :: k, lda, ldt, ldy, n, nb ! Array Arguments - complex(qp), intent(inout) :: a(lda,*) - complex(qp), intent(out) :: t(ldt,nb), tau(nb), y(ldy,nb) + complex(${ck}$), intent(inout) :: a(lda,*) + complex(${ck}$), intent(out) :: t(ldt,nb), tau(nb), y(ldy,nb) ! ===================================================================== ! Local Scalars integer(ilp) :: i - complex(qp) :: ei + complex(${ck}$) :: ei ! Intrinsic Functions intrinsic :: min ! Executable Statements @@ -40724,68 +40726,68 @@ module stdlib_linalg_lapack_w if( i>1 ) then ! update a(k+1:n,i) ! update i-th column of a - y * v**h - call stdlib_wlacgv( i-1, a( k+i-1, 1 ), lda ) - call stdlib_wgemv( 'NO TRANSPOSE', n-k, i-1, -cone, y(k+1,1), ldy,a( k+i-1, 1 ), & + call stdlib_${ci}$lacgv( i-1, a( k+i-1, 1 ), lda ) + call stdlib_${ci}$gemv( 'NO TRANSPOSE', n-k, i-1, -cone, y(k+1,1), ldy,a( k+i-1, 1 ), & lda, cone, a( k+1, i ), 1 ) - call stdlib_wlacgv( i-1, a( k+i-1, 1 ), lda ) + call stdlib_${ci}$lacgv( i-1, a( k+i-1, 1 ), lda ) ! apply i - v * t**h * v**h to this column (call it b) from the ! left, using the last column of t as workspace ! let v = ( v1 ) and b = ( b1 ) (first i-1 rows) ! ( v2 ) ( b2 ) ! where v1 is unit lower triangular ! w := v1**h * b1 - call stdlib_wcopy( i-1, a( k+1, i ), 1, t( 1, nb ), 1 ) - call stdlib_wtrmv( 'LOWER', 'CONJUGATE TRANSPOSE', 'UNIT',i-1, a( k+1, 1 ),lda, & + call stdlib_${ci}$copy( i-1, a( k+1, i ), 1, t( 1, nb ), 1 ) + call stdlib_${ci}$trmv( 'LOWER', 'CONJUGATE TRANSPOSE', 'UNIT',i-1, a( k+1, 1 ),lda, & t( 1, nb ), 1 ) ! w := w + v2**h * b2 - call stdlib_wgemv( 'CONJUGATE TRANSPOSE', n-k-i+1, i-1,cone, a( k+i, 1 ),lda, a( & + call stdlib_${ci}$gemv( 'CONJUGATE TRANSPOSE', n-k-i+1, i-1,cone, a( k+i, 1 ),lda, a( & k+i, i ), 1, cone, t( 1, nb ), 1 ) ! w := t**h * w - call stdlib_wtrmv( 'UPPER', 'CONJUGATE TRANSPOSE', 'NON-UNIT',i-1, t, ldt,t( 1, & + call stdlib_${ci}$trmv( 'UPPER', 'CONJUGATE TRANSPOSE', 'NON-UNIT',i-1, t, ldt,t( 1, & nb ), 1 ) ! b2 := b2 - v2*w - call stdlib_wgemv( 'NO TRANSPOSE', n-k-i+1, i-1, -cone,a( k+i, 1 ),lda, t( 1, nb & + call stdlib_${ci}$gemv( 'NO TRANSPOSE', n-k-i+1, i-1, -cone,a( k+i, 1 ),lda, t( 1, nb & ), 1, cone, a( k+i, i ), 1 ) ! b1 := b1 - v1*w - call stdlib_wtrmv( 'LOWER', 'NO TRANSPOSE','UNIT', i-1,a( k+1, 1 ), lda, t( 1, & + call stdlib_${ci}$trmv( 'LOWER', 'NO TRANSPOSE','UNIT', i-1,a( k+1, 1 ), lda, t( 1, & nb ), 1 ) - call stdlib_waxpy( i-1, -cone, t( 1, nb ), 1, a( k+1, i ), 1 ) + call stdlib_${ci}$axpy( i-1, -cone, t( 1, nb ), 1, a( k+1, i ), 1 ) a( k+i-1, i-1 ) = ei end if ! generate the elementary reflector h(i) to annihilate ! a(k+i+1:n,i) - call stdlib_wlarfg( n-k-i+1, a( k+i, i ), a( min( k+i+1, n ), i ), 1,tau( i ) ) + call stdlib_${ci}$larfg( n-k-i+1, a( k+i, i ), a( min( k+i+1, n ), i ), 1,tau( i ) ) ei = a( k+i, i ) a( k+i, i ) = cone ! compute y(k+1:n,i) - call stdlib_wgemv( 'NO TRANSPOSE', n-k, n-k-i+1,cone, a( k+1, i+1 ),lda, a( k+i, i )& + call stdlib_${ci}$gemv( 'NO TRANSPOSE', n-k, n-k-i+1,cone, a( k+1, i+1 ),lda, a( k+i, i )& , 1, czero, y( k+1, i ), 1 ) - call stdlib_wgemv( 'CONJUGATE TRANSPOSE', n-k-i+1, i-1,cone, a( k+i, 1 ), lda,a( k+& + call stdlib_${ci}$gemv( 'CONJUGATE TRANSPOSE', n-k-i+1, i-1,cone, a( k+i, 1 ), lda,a( k+& i, i ), 1, czero, t( 1, i ), 1 ) - call stdlib_wgemv( 'NO TRANSPOSE', n-k, i-1, -cone,y( k+1, 1 ), ldy,t( 1, i ), 1, & + call stdlib_${ci}$gemv( 'NO TRANSPOSE', n-k, i-1, -cone,y( k+1, 1 ), ldy,t( 1, i ), 1, & cone, y( k+1, i ), 1 ) - call stdlib_wscal( n-k, tau( i ), y( k+1, i ), 1 ) + call stdlib_${ci}$scal( n-k, tau( i ), y( k+1, i ), 1 ) ! compute t(1:i,i) - call stdlib_wscal( i-1, -tau( i ), t( 1, i ), 1 ) - call stdlib_wtrmv( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT',i-1, t, ldt,t( 1, i ), 1 ) + call stdlib_${ci}$scal( i-1, -tau( i ), t( 1, i ), 1 ) + call stdlib_${ci}$trmv( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT',i-1, t, ldt,t( 1, i ), 1 ) t( i, i ) = tau( i ) end do loop_10 a( k+nb, nb ) = ei ! compute y(1:k,1:nb) - call stdlib_wlacpy( 'ALL', k, nb, a( 1, 2 ), lda, y, ldy ) - call stdlib_wtrmm( 'RIGHT', 'LOWER', 'NO TRANSPOSE','UNIT', k, nb,cone, a( k+1, 1 ), & + call stdlib_${ci}$lacpy( 'ALL', k, nb, a( 1, 2 ), lda, y, ldy ) + call stdlib_${ci}$trmm( 'RIGHT', 'LOWER', 'NO TRANSPOSE','UNIT', k, nb,cone, a( k+1, 1 ), & lda, y, ldy ) - if( n>k+nb )call stdlib_wgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', k,nb, n-k-nb, cone,a( 1,& + if( n>k+nb )call stdlib_${ci}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', k,nb, n-k-nb, cone,a( 1,& 2+nb ), lda, a( k+1+nb, 1 ), lda, cone, y,ldy ) - call stdlib_wtrmm( 'RIGHT', 'UPPER', 'NO TRANSPOSE','NON-UNIT', k, nb,cone, t, ldt, y, & + call stdlib_${ci}$trmm( 'RIGHT', 'UPPER', 'NO TRANSPOSE','NON-UNIT', k, nb,cone, t, ldt, y, & ldy ) return - end subroutine stdlib_wlahr2 + end subroutine stdlib_${ci}$lahr2 - pure subroutine stdlib_wlaic1( job, j, x, sest, w, gamma, sestpr, s, c ) + pure subroutine stdlib_${ci}$laic1( job, j, x, sest, w, gamma, sestpr, s, c ) !! ZLAIC1: applies one step of incremental condition estimation in !! its simplest version: !! Let x, twonorm(x) = 1, be an approximate singular vector of an j-by-j @@ -40811,24 +40813,24 @@ module stdlib_linalg_lapack_w ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments integer(ilp), intent(in) :: j, job - real(qp), intent(in) :: sest - real(qp), intent(out) :: sestpr - complex(qp), intent(out) :: c, s - complex(qp), intent(in) :: gamma + real(${ck}$), intent(in) :: sest + real(${ck}$), intent(out) :: sestpr + complex(${ck}$), intent(out) :: c, s + complex(${ck}$), intent(in) :: gamma ! Array Arguments - complex(qp), intent(in) :: w(j), x(j) + complex(${ck}$), intent(in) :: w(j), x(j) ! ===================================================================== ! Local Scalars - real(qp) :: absalp, absest, absgam, b, eps, norma, s1, s2, scl, t, test, tmp, zeta1, & + real(${ck}$) :: absalp, absest, absgam, b, eps, norma, s1, s2, scl, t, test, tmp, zeta1, & zeta2 - complex(qp) :: alpha, cosine, sine + complex(${ck}$) :: alpha, cosine, sine ! Intrinsic Functions intrinsic :: abs,conjg,max,sqrt ! Executable Statements - eps = stdlib_qlamch( 'EPSILON' ) - alpha = stdlib_wdotc( j, x, 1, w, 1 ) + eps = stdlib_${c2ri(ci)}$lamch( 'EPSILON' ) + alpha = stdlib_${ci}$dotc( j, x, 1, w, 1 ) absalp = abs( alpha ) absgam = abs( gamma ) absest = abs( sest ) @@ -40844,7 +40846,7 @@ module stdlib_linalg_lapack_w else s = alpha / s1 c = gamma / s1 - tmp = real( sqrt( s*conjg( s )+c*conjg( c ) ),KIND=qp) + tmp = real( sqrt( s*conjg( s )+c*conjg( c ) ),KIND=${ck}$) s = s / tmp c = c / tmp sestpr = s1*tmp @@ -40895,13 +40897,13 @@ module stdlib_linalg_lapack_w b = ( one-zeta1*zeta1-zeta2*zeta2 )*half c = zeta1*zeta1 if( b>zero ) then - t = real( c / ( b+sqrt( b*b+c ) ),KIND=qp) + t = real( c / ( b+sqrt( b*b+c ) ),KIND=${ck}$) else - t = real( sqrt( b*b+c ) - b,KIND=qp) + t = real( sqrt( b*b+c ) - b,KIND=${ck}$) end if sine = -( alpha / absest ) / t cosine = -( gamma / absest ) / ( one+t ) - tmp = real( sqrt( sine * conjg( sine )+ cosine * conjg( cosine ) ),KIND=qp) + tmp = real( sqrt( sine * conjg( sine )+ cosine * conjg( cosine ) ),KIND=${ck}$) s = sine / tmp c = cosine / tmp @@ -40923,7 +40925,7 @@ module stdlib_linalg_lapack_w s1 = max( abs( sine ), abs( cosine ) ) s = sine / s1 c = cosine / s1 - tmp = real( sqrt( s*conjg( s )+c*conjg( c ) ),KIND=qp) + tmp = real( sqrt( s*conjg( s )+c*conjg( c ) ),KIND=${ck}$) s = s / tmp c = c / tmp return @@ -40973,7 +40975,7 @@ module stdlib_linalg_lapack_w ! root is close to zero, compute directly b = ( zeta1*zeta1+zeta2*zeta2+one )*half c = zeta2*zeta2 - t = real( c / ( b+sqrt( abs( b*b-c ) ) ),KIND=qp) + t = real( c / ( b+sqrt( abs( b*b-c ) ) ),KIND=${ck}$) sine = ( alpha / absest ) / ( one-t ) cosine = -( gamma / absest ) / t sestpr = sqrt( t+four*eps*eps*norma )*absest @@ -40990,7 +40992,7 @@ module stdlib_linalg_lapack_w cosine = -( gamma / absest ) / ( one+t ) sestpr = sqrt( one+t+four*eps*eps*norma )*absest end if - tmp = real( sqrt( sine * conjg( sine )+ cosine * conjg( cosine ) ),KIND=qp) + tmp = real( sqrt( sine * conjg( sine )+ cosine * conjg( cosine ) ),KIND=${ck}$) s = sine / tmp c = cosine / tmp @@ -40998,10 +41000,10 @@ module stdlib_linalg_lapack_w end if end if return - end subroutine stdlib_wlaic1 + end subroutine stdlib_${ci}$laic1 - pure subroutine stdlib_wlals0( icompq, nl, nr, sqre, nrhs, b, ldb, bx, ldbx,perm, givptr, & + pure subroutine stdlib_${ci}$lals0( icompq, nl, nr, sqre, nrhs, b, ldb, bx, ldbx,perm, givptr, & !! ZLALS0: applies back the multiplying factors of either the left or the !! right singular vector matrix of a diagonal matrix appended by a row !! to the right hand side matrix B in solving the least squares problem @@ -41030,19 +41032,19 @@ module stdlib_linalg_lapack_w integer(ilp), intent(in) :: givptr, icompq, k, ldb, ldbx, ldgcol, ldgnum, nl, nr, nrhs,& sqre integer(ilp), intent(out) :: info - real(qp), intent(in) :: c, s + real(${ck}$), intent(in) :: c, s ! Array Arguments integer(ilp), intent(in) :: givcol(ldgcol,*), perm(*) - real(qp), intent(in) :: difl(*), difr(ldgnum,*), givnum(ldgnum,*), poles(ldgnum,*), z(& + real(${ck}$), intent(in) :: difl(*), difr(ldgnum,*), givnum(ldgnum,*), poles(ldgnum,*), z(& *) - real(qp), intent(out) :: rwork(*) - complex(qp), intent(inout) :: b(ldb,*) - complex(qp), intent(out) :: bx(ldbx,*) + real(${ck}$), intent(out) :: rwork(*) + complex(${ck}$), intent(inout) :: b(ldb,*) + complex(${ck}$), intent(out) :: bx(ldbx,*) ! ===================================================================== ! Local Scalars integer(ilp) :: i, j, jcol, jrow, m, n, nlp1 - real(qp) :: diflj, difrj, dj, dsigj, dsigjp, temp + real(${ck}$) :: diflj, difrj, dj, dsigj, dsigjp, temp ! Intrinsic Functions intrinsic :: real,cmplx,aimag,max ! Executable Statements @@ -41082,20 +41084,20 @@ module stdlib_linalg_lapack_w ! apply back orthogonal transformations from the left. ! step (1l): apply back the givens rotations performed. do i = 1, givptr - call stdlib_wdrot( nrhs, b( givcol( i, 2 ), 1 ), ldb,b( givcol( i, 1 ), 1 ), ldb,& + call stdlib_${ci}$drot( nrhs, b( givcol( i, 2 ), 1 ), ldb,b( givcol( i, 1 ), 1 ), ldb,& givnum( i, 2 ),givnum( i, 1 ) ) end do ! step (2l): permute rows of b. - call stdlib_wcopy( nrhs, b( nlp1, 1 ), ldb, bx( 1, 1 ), ldbx ) + call stdlib_${ci}$copy( nrhs, b( nlp1, 1 ), ldb, bx( 1, 1 ), ldbx ) do i = 2, n - call stdlib_wcopy( nrhs, b( perm( i ), 1 ), ldb, bx( i, 1 ), ldbx ) + call stdlib_${ci}$copy( nrhs, b( perm( i ), 1 ), ldb, bx( i, 1 ), ldbx ) end do ! step (3l): apply the inverse of the left singular vector ! matrix to bx. if( k==1 ) then - call stdlib_wcopy( nrhs, bx, ldbx, b, ldb ) + call stdlib_${ci}$copy( nrhs, bx, ldbx, b, ldb ) if( z( 1 )=one ) ) then rcnd = eps @@ -41617,10 +41619,10 @@ module stdlib_linalg_lapack_w return else if( n==1 ) then if( d( 1 )==zero ) then - call stdlib_wlaset( 'A', 1, nrhs, czero, czero, b, ldb ) + call stdlib_${ci}$laset( 'A', 1, nrhs, czero, czero, b, ldb ) else rank = 1 - call stdlib_wlascl( 'G', 0, 0, d( 1 ), one, 1, nrhs, b, ldb, info ) + call stdlib_${ci}$lascl( 'G', 0, 0, d( 1 ), one, 1, nrhs, b, ldb, info ) d( 1 ) = abs( d( 1 ) ) end if return @@ -41628,12 +41630,12 @@ module stdlib_linalg_lapack_w ! rotate the matrix if it is lower bidiagonal. if( uplo=='L' ) then do i = 1, n - 1 - call stdlib_qlartg( d( i ), e( i ), cs, sn, r ) + call stdlib_${c2ri(ci)}$lartg( d( i ), e( i ), cs, sn, r ) d( i ) = r e( i ) = sn*d( i+1 ) d( i+1 ) = cs*d( i+1 ) if( nrhs==1 ) then - call stdlib_wdrot( 1, b( i, 1 ), 1, b( i+1, 1 ), 1, cs, sn ) + call stdlib_${ci}$drot( 1, b( i, 1 ), 1, b( i+1, 1 ), 1, cs, sn ) else rwork( i*2-1 ) = cs rwork( i*2 ) = sn @@ -41644,20 +41646,20 @@ module stdlib_linalg_lapack_w do j = 1, n - 1 cs = rwork( j*2-1 ) sn = rwork( j*2 ) - call stdlib_wdrot( 1, b( j, i ), 1, b( j+1, i ), 1, cs, sn ) + call stdlib_${ci}$drot( 1, b( j, i ), 1, b( j+1, i ), 1, cs, sn ) end do end do end if end if ! scale. nm1 = n - 1 - orgnrm = stdlib_qlanst( 'M', n, d, e ) + orgnrm = stdlib_${c2ri(ci)}$lanst( 'M', n, d, e ) if( orgnrm==zero ) then - call stdlib_wlaset( 'A', n, nrhs, czero, czero, b, ldb ) + call stdlib_${ci}$laset( 'A', n, nrhs, czero, czero, b, ldb ) return end if - call stdlib_qlascl( 'G', 0, 0, orgnrm, one, n, 1, d, n, info ) - call stdlib_qlascl( 'G', 0, 0, orgnrm, one, nm1, 1, e, nm1, info ) + call stdlib_${c2ri(ci)}$lascl( 'G', 0, 0, orgnrm, one, n, 1, d, n, info ) + call stdlib_${c2ri(ci)}$lascl( 'G', 0, 0, orgnrm, one, nm1, 1, e, nm1, info ) ! if n is smaller than the minimum divide size smlsiz, then solve ! the problem with another solver. if( n<=smlsiz ) then @@ -41667,24 +41669,24 @@ module stdlib_linalg_lapack_w irwrb = irwwrk irwib = irwrb + n*nrhs irwb = irwib + n*nrhs - call stdlib_qlaset( 'A', n, n, zero, one, rwork( irwu ), n ) - call stdlib_qlaset( 'A', n, n, zero, one, rwork( irwvt ), n ) - call stdlib_qlasdq( 'U', 0, n, n, n, 0, d, e, rwork( irwvt ), n,rwork( irwu ), n, & + call stdlib_${c2ri(ci)}$laset( 'A', n, n, zero, one, rwork( irwu ), n ) + call stdlib_${c2ri(ci)}$laset( 'A', n, n, zero, one, rwork( irwvt ), n ) + call stdlib_${c2ri(ci)}$lasdq( 'U', 0, n, n, n, 0, d, e, rwork( irwvt ), n,rwork( irwu ), n, & rwork( irwwrk ), 1,rwork( irwwrk ), info ) if( info/=0 ) then return end if - ! in the real version, b is passed to stdlib_qlasdq and multiplied + ! in the real version, b is passed to stdlib_${c2ri(ci)}$lasdq and multiplied ! internally by q**h. here b is complex and that product is ! computed below in two steps (real and imaginary parts). j = irwb - 1 do jcol = 1, nrhs do jrow = 1, n j = j + 1 - rwork( j ) = real( b( jrow, jcol ),KIND=qp) + rwork( j ) = real( b( jrow, jcol ),KIND=${ck}$) end do end do - call stdlib_qgemm( 'T', 'N', n, nrhs, n, one, rwork( irwu ), n,rwork( irwb ), n, & + call stdlib_${c2ri(ci)}$gemm( 'T', 'N', n, nrhs, n, one, rwork( irwu ), n,rwork( irwb ), n, & zero, rwork( irwrb ), n ) j = irwb - 1 do jcol = 1, nrhs @@ -41693,7 +41695,7 @@ module stdlib_linalg_lapack_w rwork( j ) = aimag( b( jrow, jcol ) ) end do end do - call stdlib_qgemm( 'T', 'N', n, nrhs, n, one, rwork( irwu ), n,rwork( irwb ), n, & + call stdlib_${c2ri(ci)}$gemm( 'T', 'N', n, nrhs, n, one, rwork( irwu ), n,rwork( irwb ), n, & zero, rwork( irwib ), n ) jreal = irwrb - 1 jimag = irwib - 1 @@ -41701,32 +41703,32 @@ module stdlib_linalg_lapack_w do jrow = 1, n jreal = jreal + 1 jimag = jimag + 1 - b( jrow, jcol ) = cmplx( rwork( jreal ),rwork( jimag ),KIND=qp) + b( jrow, jcol ) = cmplx( rwork( jreal ),rwork( jimag ),KIND=${ck}$) end do end do - tol = rcnd*abs( d( stdlib_iqamax( n, d, 1 ) ) ) + tol = rcnd*abs( d( stdlib_i${c2ri(ci)}$amax( n, d, 1 ) ) ) do i = 1, n if( d( i )<=tol ) then - call stdlib_wlaset( 'A', 1, nrhs, czero, czero, b( i, 1 ), ldb ) + call stdlib_${ci}$laset( 'A', 1, nrhs, czero, czero, b( i, 1 ), ldb ) else - call stdlib_wlascl( 'G', 0, 0, d( i ), one, 1, nrhs, b( i, 1 ),ldb, info ) + call stdlib_${ci}$lascl( 'G', 0, 0, d( i ), one, 1, nrhs, b( i, 1 ),ldb, info ) rank = rank + 1 end if end do - ! since b is complex, the following call to stdlib_qgemm is performed + ! since b is complex, the following call to stdlib_${c2ri(ci)}$gemm is performed ! in two steps (real and imaginary parts). that is for v * b ! (in the real version of the code v**h is stored in work). - ! call stdlib_qgemm( 't', 'n', n, nrhs, n, one, work, n, b, ldb, zero, + ! call stdlib_${c2ri(ci)}$gemm( 't', 'n', n, nrhs, n, one, work, n, b, ldb, zero, ! $ work( nwork ), n ) j = irwb - 1 do jcol = 1, nrhs do jrow = 1, n j = j + 1 - rwork( j ) = real( b( jrow, jcol ),KIND=qp) + rwork( j ) = real( b( jrow, jcol ),KIND=${ck}$) end do end do - call stdlib_qgemm( 'T', 'N', n, nrhs, n, one, rwork( irwvt ), n,rwork( irwb ), n, & + call stdlib_${c2ri(ci)}$gemm( 'T', 'N', n, nrhs, n, one, rwork( irwvt ), n,rwork( irwb ), n, & zero, rwork( irwrb ), n ) j = irwb - 1 do jcol = 1, nrhs @@ -41735,7 +41737,7 @@ module stdlib_linalg_lapack_w rwork( j ) = aimag( b( jrow, jcol ) ) end do end do - call stdlib_qgemm( 'T', 'N', n, nrhs, n, one, rwork( irwvt ), n,rwork( irwb ), n, & + call stdlib_${c2ri(ci)}$gemm( 'T', 'N', n, nrhs, n, one, rwork( irwvt ), n,rwork( irwb ), n, & zero, rwork( irwib ), n ) jreal = irwrb - 1 jimag = irwib - 1 @@ -41743,17 +41745,17 @@ module stdlib_linalg_lapack_w do jrow = 1, n jreal = jreal + 1 jimag = jimag + 1 - b( jrow, jcol ) = cmplx( rwork( jreal ),rwork( jimag ),KIND=qp) + b( jrow, jcol ) = cmplx( rwork( jreal ),rwork( jimag ),KIND=${ck}$) end do end do ! unscale. - call stdlib_qlascl( 'G', 0, 0, one, orgnrm, n, 1, d, n, info ) - call stdlib_qlasrt( 'D', n, d, info ) - call stdlib_wlascl( 'G', 0, 0, orgnrm, one, n, nrhs, b, ldb, info ) + call stdlib_${c2ri(ci)}$lascl( 'G', 0, 0, one, orgnrm, n, 1, d, n, info ) + call stdlib_${c2ri(ci)}$lasrt( 'D', n, d, info ) + call stdlib_${ci}$lascl( 'G', 0, 0, orgnrm, one, n, nrhs, b, ldb, info ) return end if ! book-keeping and setting up some constants. - nlvl = int( log( real( n,KIND=qp) / real( smlsiz+1,KIND=qp) ) / log( two ),KIND=ilp) + & + nlvl = int( log( real( n,KIND=${ck}$) / real( smlsiz+1,KIND=${ck}$) ) / log( two ),KIND=ilp) + & 1 smlszp = smlsiz + 1 u = 1 @@ -41809,34 +41811,34 @@ module stdlib_linalg_lapack_w nsub = nsub + 1 iwork( nsub ) = n iwork( sizei+nsub-1 ) = 1 - call stdlib_wcopy( nrhs, b( n, 1 ), ldb, work( bx+nm1 ), n ) + call stdlib_${ci}$copy( nrhs, b( n, 1 ), ldb, work( bx+nm1 ), n ) end if st1 = st - 1 if( nsize==1 ) then ! this is a 1-by-1 subproblem and is not solved ! explicitly. - call stdlib_wcopy( nrhs, b( st, 1 ), ldb, work( bx+st1 ), n ) + call stdlib_${ci}$copy( nrhs, b( st, 1 ), ldb, work( bx+st1 ), n ) else if( nsize<=smlsiz ) then - ! this is a small subproblem and is solved by stdlib_qlasdq. - call stdlib_qlaset( 'A', nsize, nsize, zero, one,rwork( vt+st1 ), n ) - call stdlib_qlaset( 'A', nsize, nsize, zero, one,rwork( u+st1 ), n ) - call stdlib_qlasdq( 'U', 0, nsize, nsize, nsize, 0, d( st ),e( st ), rwork( & + ! this is a small subproblem and is solved by stdlib_${c2ri(ci)}$lasdq. + call stdlib_${c2ri(ci)}$laset( 'A', nsize, nsize, zero, one,rwork( vt+st1 ), n ) + call stdlib_${c2ri(ci)}$laset( 'A', nsize, nsize, zero, one,rwork( u+st1 ), n ) + call stdlib_${c2ri(ci)}$lasdq( 'U', 0, nsize, nsize, nsize, 0, d( st ),e( st ), rwork( & vt+st1 ), n, rwork( u+st1 ),n, rwork( nrwork ), 1, rwork( nrwork ),info ) if( info/=0 ) then return end if - ! in the real version, b is passed to stdlib_qlasdq and multiplied + ! in the real version, b is passed to stdlib_${c2ri(ci)}$lasdq and multiplied ! internally by q**h. here b is complex and that product is ! computed below in two steps (real and imaginary parts). j = irwb - 1 do jcol = 1, nrhs do jrow = st, st + nsize - 1 j = j + 1 - rwork( j ) = real( b( jrow, jcol ),KIND=qp) + rwork( j ) = real( b( jrow, jcol ),KIND=${ck}$) end do end do - call stdlib_qgemm( 'T', 'N', nsize, nrhs, nsize, one,rwork( u+st1 ), n, rwork(& + call stdlib_${c2ri(ci)}$gemm( 'T', 'N', nsize, nrhs, nsize, one,rwork( u+st1 ), n, rwork(& irwb ), nsize,zero, rwork( irwrb ), nsize ) j = irwb - 1 do jcol = 1, nrhs @@ -41845,7 +41847,7 @@ module stdlib_linalg_lapack_w rwork( j ) = aimag( b( jrow, jcol ) ) end do end do - call stdlib_qgemm( 'T', 'N', nsize, nrhs, nsize, one,rwork( u+st1 ), n, rwork(& + call stdlib_${c2ri(ci)}$gemm( 'T', 'N', nsize, nrhs, nsize, one,rwork( u+st1 ), n, rwork(& irwb ), nsize,zero, rwork( irwib ), nsize ) jreal = irwrb - 1 jimag = irwib - 1 @@ -41853,14 +41855,14 @@ module stdlib_linalg_lapack_w do jrow = st, st + nsize - 1 jreal = jreal + 1 jimag = jimag + 1 - b( jrow, jcol ) = cmplx( rwork( jreal ),rwork( jimag ),KIND=qp) + b( jrow, jcol ) = cmplx( rwork( jreal ),rwork( jimag ),KIND=${ck}$) end do end do - call stdlib_wlacpy( 'A', nsize, nrhs, b( st, 1 ), ldb,work( bx+st1 ), n ) + call stdlib_${ci}$lacpy( 'A', nsize, nrhs, b( st, 1 ), ldb,work( bx+st1 ), n ) else ! a large problem. solve it using divide and conquer. - call stdlib_qlasda( icmpq1, smlsiz, nsize, sqre, d( st ),e( st ), rwork( u+& + call stdlib_${c2ri(ci)}$lasda( icmpq1, smlsiz, nsize, sqre, d( st ),e( st ), rwork( u+& st1 ), n, rwork( vt+st1 ),iwork( k+st1 ), rwork( difl+st1 ),rwork( difr+st1 ),& rwork( z+st1 ),rwork( poles+st1 ), iwork( givptr+st1 ),iwork( givcol+st1 ), & n, iwork( perm+st1 ),rwork( givnum+st1 ), rwork( c+st1 ),rwork( s+st1 ), & @@ -41869,7 +41871,7 @@ module stdlib_linalg_lapack_w return end if bxst = bx + st1 - call stdlib_wlalsa( icmpq2, smlsiz, nsize, nrhs, b( st, 1 ),ldb, work( bxst ),& + call stdlib_${ci}$lalsa( icmpq2, smlsiz, nsize, nrhs, b( st, 1 ),ldb, work( bxst ),& n, rwork( u+st1 ), n,rwork( vt+st1 ), iwork( k+st1 ),rwork( difl+st1 ), & rwork( difr+st1 ),rwork( z+st1 ), rwork( poles+st1 ),iwork( givptr+st1 ), & iwork( givcol+st1 ), n,iwork( perm+st1 ), rwork( givnum+st1 ),rwork( c+st1 ),& @@ -41882,15 +41884,15 @@ module stdlib_linalg_lapack_w end if end do loop_240 ! apply the singular values and treat the tiny ones as zero. - tol = rcnd*abs( d( stdlib_iqamax( n, d, 1 ) ) ) + tol = rcnd*abs( d( stdlib_i${c2ri(ci)}$amax( n, d, 1 ) ) ) do i = 1, n ! some of the elements in d can be negative because 1-by-1 ! subproblems were not solved explicitly. if( abs( d( i ) )<=tol ) then - call stdlib_wlaset( 'A', 1, nrhs, czero, czero, work( bx+i-1 ), n ) + call stdlib_${ci}$laset( 'A', 1, nrhs, czero, czero, work( bx+i-1 ), n ) else rank = rank + 1 - call stdlib_wlascl( 'G', 0, 0, d( i ), one, 1, nrhs,work( bx+i-1 ), n, info ) + call stdlib_${ci}$lascl( 'G', 0, 0, d( i ), one, 1, nrhs,work( bx+i-1 ), n, info ) end if d( i ) = abs( d( i ) ) @@ -41903,11 +41905,11 @@ module stdlib_linalg_lapack_w nsize = iwork( sizei+i-1 ) bxst = bx + st1 if( nsize==1 ) then - call stdlib_wcopy( nrhs, work( bxst ), n, b( st, 1 ), ldb ) + call stdlib_${ci}$copy( nrhs, work( bxst ), n, b( st, 1 ), ldb ) else if( nsize<=smlsiz ) then - ! since b and bx are complex, the following call to stdlib_qgemm + ! since b and bx are complex, the following call to stdlib_${c2ri(ci)}$gemm ! is performed in two steps (real and imaginary parts). - ! call stdlib_qgemm( 't', 'n', nsize, nrhs, nsize, one, + ! call stdlib_${c2ri(ci)}$gemm( 't', 'n', nsize, nrhs, nsize, one, ! $ rwork( vt+st1 ), n, rwork( bxst ), n, zero, ! $ b( st, 1 ), ldb ) j = bxst - n - 1 @@ -41916,10 +41918,10 @@ module stdlib_linalg_lapack_w j = j + n do jrow = 1, nsize jreal = jreal + 1 - rwork( jreal ) = real( work( j+jrow ),KIND=qp) + rwork( jreal ) = real( work( j+jrow ),KIND=${ck}$) end do end do - call stdlib_qgemm( 'T', 'N', nsize, nrhs, nsize, one,rwork( vt+st1 ), n, rwork( & + call stdlib_${c2ri(ci)}$gemm( 'T', 'N', nsize, nrhs, nsize, one,rwork( vt+st1 ), n, rwork( & irwb ), nsize, zero,rwork( irwrb ), nsize ) j = bxst - n - 1 jimag = irwb - 1 @@ -41930,7 +41932,7 @@ module stdlib_linalg_lapack_w rwork( jimag ) = aimag( work( j+jrow ) ) end do end do - call stdlib_qgemm( 'T', 'N', nsize, nrhs, nsize, one,rwork( vt+st1 ), n, rwork( & + call stdlib_${c2ri(ci)}$gemm( 'T', 'N', nsize, nrhs, nsize, one,rwork( vt+st1 ), n, rwork( & irwb ), nsize, zero,rwork( irwib ), nsize ) jreal = irwrb - 1 jimag = irwib - 1 @@ -41938,11 +41940,11 @@ module stdlib_linalg_lapack_w do jrow = st, st + nsize - 1 jreal = jreal + 1 jimag = jimag + 1 - b( jrow, jcol ) = cmplx( rwork( jreal ),rwork( jimag ),KIND=qp) + b( jrow, jcol ) = cmplx( rwork( jreal ),rwork( jimag ),KIND=${ck}$) end do end do else - call stdlib_wlalsa( icmpq2, smlsiz, nsize, nrhs, work( bxst ), n,b( st, 1 ), ldb,& + call stdlib_${ci}$lalsa( icmpq2, smlsiz, nsize, nrhs, work( bxst ), n,b( st, 1 ), ldb,& rwork( u+st1 ), n,rwork( vt+st1 ), iwork( k+st1 ),rwork( difl+st1 ), rwork( & difr+st1 ),rwork( z+st1 ), rwork( poles+st1 ),iwork( givptr+st1 ), iwork( & givcol+st1 ), n,iwork( perm+st1 ), rwork( givnum+st1 ),rwork( c+st1 ), rwork( s+& @@ -41953,14 +41955,14 @@ module stdlib_linalg_lapack_w end if end do loop_320 ! unscale and sort the singular values. - call stdlib_qlascl( 'G', 0, 0, one, orgnrm, n, 1, d, n, info ) - call stdlib_qlasrt( 'D', n, d, info ) - call stdlib_wlascl( 'G', 0, 0, orgnrm, one, n, nrhs, b, ldb, info ) + call stdlib_${c2ri(ci)}$lascl( 'G', 0, 0, one, orgnrm, n, 1, d, n, info ) + call stdlib_${c2ri(ci)}$lasrt( 'D', n, d, info ) + call stdlib_${ci}$lascl( 'G', 0, 0, orgnrm, one, n, nrhs, b, ldb, info ) return - end subroutine stdlib_wlalsd + end subroutine stdlib_${ci}$lalsd - pure subroutine stdlib_wlamswlq( side, trans, m, n, k, mb, nb, a, lda, t,ldt, c, ldc, work, & + pure subroutine stdlib_${ci}$lamswlq( side, trans, m, n, k, mb, nb, a, lda, t,ldt, c, ldc, work, & !! ZLAMSWLQ: overwrites the general complex M-by-N matrix C with !! SIDE = 'L' SIDE = 'R' !! TRANS = 'N': Q * C C * Q @@ -41977,9 +41979,9 @@ module stdlib_linalg_lapack_w integer(ilp), intent(out) :: info integer(ilp), intent(in) :: lda, m, n, k, mb, nb, ldt, lwork, ldc ! Array Arguments - complex(qp), intent(in) :: a(lda,*), t(ldt,*) - complex(qp), intent(out) :: work(*) - complex(qp), intent(inout) :: c(ldc,*) + complex(${ck}$), intent(in) :: a(lda,*), t(ldt,*) + complex(${ck}$), intent(out) :: work(*) + complex(${ck}$), intent(inout) :: c(ldc,*) ! ===================================================================== ! Local Scalars logical(lk) :: left, right, tran, notran, lquery @@ -42032,7 +42034,7 @@ module stdlib_linalg_lapack_w return end if if((nb<=k).or.(nb>=max(m,n,k))) then - call stdlib_wgemlqt( side, trans, m, n, k, mb, a, lda,t, ldt, c, ldc, work, info) + call stdlib_${ci}$gemlqt( side, trans, m, n, k, mb, a, lda,t, ldt, c, ldc, work, info) return end if @@ -42042,7 +42044,7 @@ module stdlib_linalg_lapack_w ctr = (m-k)/(nb-k) if (kk>0) then ii=m-kk+1 - call stdlib_wtpmlqt('L','C',kk , n, k, 0, mb, a(1,ii), lda,t(1,ctr*k+1), ldt, c(& + call stdlib_${ci}$tpmlqt('L','C',kk , n, k, 0, mb, a(1,ii), lda,t(1,ctr*k+1), ldt, c(& 1,1), ldc,c(ii,1), ldc, work, info ) else ii=m+1 @@ -42050,28 +42052,28 @@ module stdlib_linalg_lapack_w do i=ii-(nb-k),nb+1,-(nb-k) ! multiply q to the current block of c (1:m,i:i+nb) ctr = ctr - 1 - call stdlib_wtpmlqt('L','C',nb-k , n, k, 0,mb, a(1,i), lda,t(1,ctr*k+1),ldt, c(1,& + call stdlib_${ci}$tpmlqt('L','C',nb-k , n, k, 0,mb, a(1,i), lda,t(1,ctr*k+1),ldt, c(1,& 1), ldc,c(i,1), ldc, work, info ) end do ! multiply q to the first block of c (1:m,1:nb) - call stdlib_wgemlqt('L','C',nb , n, k, mb, a(1,1), lda, t,ldt ,c(1,1), ldc, work, & + call stdlib_${ci}$gemlqt('L','C',nb , n, k, mb, a(1,1), lda, t,ldt ,c(1,1), ldc, work, & info ) else if (left.and.notran) then ! multiply q to the first block of c kk = mod((m-k),(nb-k)) ii=m-kk+1 ctr = 1 - call stdlib_wgemlqt('L','N',nb , n, k, mb, a(1,1), lda, t,ldt ,c(1,1), ldc, work, & + call stdlib_${ci}$gemlqt('L','N',nb , n, k, mb, a(1,1), lda, t,ldt ,c(1,1), ldc, work, & info ) do i=nb+1,ii-nb+k,(nb-k) ! multiply q to the current block of c (i:i+nb,1:n) - call stdlib_wtpmlqt('L','N',nb-k , n, k, 0,mb, a(1,i), lda,t(1, ctr * k + 1), ldt, & + call stdlib_${ci}$tpmlqt('L','N',nb-k , n, k, 0,mb, a(1,i), lda,t(1, ctr * k + 1), ldt, & c(1,1), ldc,c(i,1), ldc, work, info ) ctr = ctr + 1 end do if(ii<=m) then ! multiply q to the last block of c - call stdlib_wtpmlqt('L','N',kk , n, k, 0, mb, a(1,ii), lda,t(1, ctr * k + 1), ldt, & + call stdlib_${ci}$tpmlqt('L','N',kk , n, k, 0, mb, a(1,ii), lda,t(1, ctr * k + 1), ldt, & c(1,1), ldc,c(ii,1), ldc, work, info ) end if else if(right.and.notran) then @@ -42080,7 +42082,7 @@ module stdlib_linalg_lapack_w ctr = (n-k)/(nb-k) if (kk>0) then ii=n-kk+1 - call stdlib_wtpmlqt('R','N',m , kk, k, 0, mb, a(1, ii), lda,t(1, ctr * k + 1), & + call stdlib_${ci}$tpmlqt('R','N',m , kk, k, 0, mb, a(1, ii), lda,t(1, ctr * k + 1), & ldt, c(1,1), ldc,c(1,ii), ldc, work, info ) else ii=n+1 @@ -42088,37 +42090,37 @@ module stdlib_linalg_lapack_w do i=ii-(nb-k),nb+1,-(nb-k) ! multiply q to the current block of c (1:m,i:i+mb) ctr = ctr - 1 - call stdlib_wtpmlqt('R','N', m, nb-k, k, 0, mb, a(1, i), lda,t(1, ctr * k + 1), & + call stdlib_${ci}$tpmlqt('R','N', m, nb-k, k, 0, mb, a(1, i), lda,t(1, ctr * k + 1), & ldt, c(1,1), ldc,c(1,i), ldc, work, info ) end do ! multiply q to the first block of c (1:m,1:mb) - call stdlib_wgemlqt('R','N',m , nb, k, mb, a(1,1), lda, t,ldt ,c(1,1), ldc, work, & + call stdlib_${ci}$gemlqt('R','N',m , nb, k, mb, a(1,1), lda, t,ldt ,c(1,1), ldc, work, & info ) else if (right.and.tran) then ! multiply q to the first block of c kk = mod((n-k),(nb-k)) ii=n-kk+1 - call stdlib_wgemlqt('R','C',m , nb, k, mb, a(1,1), lda, t,ldt ,c(1,1), ldc, work, & + call stdlib_${ci}$gemlqt('R','C',m , nb, k, mb, a(1,1), lda, t,ldt ,c(1,1), ldc, work, & info ) ctr = 1 do i=nb+1,ii-nb+k,(nb-k) ! multiply q to the current block of c (1:m,i:i+mb) - call stdlib_wtpmlqt('R','C',m , nb-k, k, 0,mb, a(1,i), lda,t(1,ctr *k+1), ldt, c(1,& + call stdlib_${ci}$tpmlqt('R','C',m , nb-k, k, 0,mb, a(1,i), lda,t(1,ctr *k+1), ldt, c(1,& 1), ldc,c(1,i), ldc, work, info ) ctr = ctr + 1 end do if(ii<=n) then ! multiply q to the last block of c - call stdlib_wtpmlqt('R','C',m , kk, k, 0,mb, a(1,ii), lda,t(1, ctr * k + 1),ldt, c(& + call stdlib_${ci}$tpmlqt('R','C',m , kk, k, 0,mb, a(1,ii), lda,t(1, ctr * k + 1),ldt, c(& 1,1), ldc,c(1,ii), ldc, work, info ) end if end if work(1) = lw return - end subroutine stdlib_wlamswlq + end subroutine stdlib_${ci}$lamswlq - pure subroutine stdlib_wlamtsqr( side, trans, m, n, k, mb, nb, a, lda, t,ldt, c, ldc, work, & + pure subroutine stdlib_${ci}$lamtsqr( side, trans, m, n, k, mb, nb, a, lda, t,ldt, c, ldc, work, & !! ZLAMTSQR: overwrites the general complex M-by-N matrix C with !! SIDE = 'L' SIDE = 'R' !! TRANS = 'N': Q * C C * Q @@ -42135,9 +42137,9 @@ module stdlib_linalg_lapack_w integer(ilp), intent(out) :: info integer(ilp), intent(in) :: lda, m, n, k, mb, nb, ldt, lwork, ldc ! Array Arguments - complex(qp), intent(in) :: a(lda,*), t(ldt,*) - complex(qp), intent(out) :: work(*) - complex(qp), intent(inout) :: c(ldc,*) + complex(${ck}$), intent(in) :: a(lda,*), t(ldt,*) + complex(${ck}$), intent(out) :: work(*) + complex(${ck}$), intent(inout) :: c(ldc,*) ! ===================================================================== ! Local Scalars logical(lk) :: left, right, tran, notran, lquery @@ -42194,7 +42196,7 @@ module stdlib_linalg_lapack_w return end if if((mb<=k).or.(mb>=max(m,n,k))) then - call stdlib_wgemqrt( side, trans, m, n, k, nb, a, lda,t, ldt, c, ldc, work, info) + call stdlib_${ci}$gemqrt( side, trans, m, n, k, nb, a, lda,t, ldt, c, ldc, work, info) return end if @@ -42204,7 +42206,7 @@ module stdlib_linalg_lapack_w ctr = (m-k)/(mb-k) if (kk>0) then ii=m-kk+1 - call stdlib_wtpmqrt('L','N',kk , n, k, 0, nb, a(ii,1), lda,t(1, ctr * k + 1),ldt ,& + call stdlib_${ci}$tpmqrt('L','N',kk , n, k, 0, nb, a(ii,1), lda,t(1, ctr * k + 1),ldt ,& c(1,1), ldc,c(ii,1), ldc, work, info ) else ii=m+1 @@ -42212,28 +42214,28 @@ module stdlib_linalg_lapack_w do i=ii-(mb-k),mb+1,-(mb-k) ! multiply q to the current block of c (i:i+mb,1:n) ctr = ctr - 1 - call stdlib_wtpmqrt('L','N',mb-k , n, k, 0,nb, a(i,1), lda,t(1,ctr * k + 1),ldt, & + call stdlib_${ci}$tpmqrt('L','N',mb-k , n, k, 0,nb, a(i,1), lda,t(1,ctr * k + 1),ldt, & c(1,1), ldc,c(i,1), ldc, work, info ) end do ! multiply q to the first block of c (1:mb,1:n) - call stdlib_wgemqrt('L','N',mb , n, k, nb, a(1,1), lda, t,ldt ,c(1,1), ldc, work, & + call stdlib_${ci}$gemqrt('L','N',mb , n, k, nb, a(1,1), lda, t,ldt ,c(1,1), ldc, work, & info ) else if (left.and.tran) then ! multiply q to the first block of c kk = mod((m-k),(mb-k)) ii=m-kk+1 ctr = 1 - call stdlib_wgemqrt('L','C',mb , n, k, nb, a(1,1), lda, t,ldt ,c(1,1), ldc, work, & + call stdlib_${ci}$gemqrt('L','C',mb , n, k, nb, a(1,1), lda, t,ldt ,c(1,1), ldc, work, & info ) do i=mb+1,ii-mb+k,(mb-k) ! multiply q to the current block of c (i:i+mb,1:n) - call stdlib_wtpmqrt('L','C',mb-k , n, k, 0,nb, a(i,1), lda,t(1,ctr * k + 1),ldt, c(& + call stdlib_${ci}$tpmqrt('L','C',mb-k , n, k, 0,nb, a(i,1), lda,t(1,ctr * k + 1),ldt, c(& 1,1), ldc,c(i,1), ldc, work, info ) ctr = ctr + 1 end do if(ii<=m) then ! multiply q to the last block of c - call stdlib_wtpmqrt('L','C',kk , n, k, 0,nb, a(ii,1), lda,t(1, ctr * k + 1), ldt, & + call stdlib_${ci}$tpmqrt('L','C',kk , n, k, 0,nb, a(ii,1), lda,t(1, ctr * k + 1), ldt, & c(1,1), ldc,c(ii,1), ldc, work, info ) end if else if(right.and.tran) then @@ -42242,7 +42244,7 @@ module stdlib_linalg_lapack_w ctr = (n-k)/(mb-k) if (kk>0) then ii=n-kk+1 - call stdlib_wtpmqrt('R','C',m , kk, k, 0, nb, a(ii,1), lda,t(1,ctr * k + 1), ldt,& + call stdlib_${ci}$tpmqrt('R','C',m , kk, k, 0, nb, a(ii,1), lda,t(1,ctr * k + 1), ldt,& c(1,1), ldc,c(1,ii), ldc, work, info ) else ii=n+1 @@ -42250,37 +42252,37 @@ module stdlib_linalg_lapack_w do i=ii-(mb-k),mb+1,-(mb-k) ! multiply q to the current block of c (1:m,i:i+mb) ctr = ctr - 1 - call stdlib_wtpmqrt('R','C',m , mb-k, k, 0,nb, a(i,1), lda,t(1, ctr * k + 1), & + call stdlib_${ci}$tpmqrt('R','C',m , mb-k, k, 0,nb, a(i,1), lda,t(1, ctr * k + 1), & ldt, c(1,1), ldc,c(1,i), ldc, work, info ) end do ! multiply q to the first block of c (1:m,1:mb) - call stdlib_wgemqrt('R','C',m , mb, k, nb, a(1,1), lda, t,ldt ,c(1,1), ldc, work, & + call stdlib_${ci}$gemqrt('R','C',m , mb, k, nb, a(1,1), lda, t,ldt ,c(1,1), ldc, work, & info ) else if (right.and.notran) then ! multiply q to the first block of c kk = mod((n-k),(mb-k)) ii=n-kk+1 ctr = 1 - call stdlib_wgemqrt('R','N', m, mb , k, nb, a(1,1), lda, t,ldt ,c(1,1), ldc, work, & + call stdlib_${ci}$gemqrt('R','N', m, mb , k, nb, a(1,1), lda, t,ldt ,c(1,1), ldc, work, & info ) do i=mb+1,ii-mb+k,(mb-k) ! multiply q to the current block of c (1:m,i:i+mb) - call stdlib_wtpmqrt('R','N', m, mb-k, k, 0,nb, a(i,1), lda,t(1, ctr * k + 1),ldt, & + call stdlib_${ci}$tpmqrt('R','N', m, mb-k, k, 0,nb, a(i,1), lda,t(1, ctr * k + 1),ldt, & c(1,1), ldc,c(1,i), ldc, work, info ) ctr = ctr + 1 end do if(ii<=n) then ! multiply q to the last block of c - call stdlib_wtpmqrt('R','N', m, kk , k, 0,nb, a(ii,1), lda,t(1,ctr * k + 1),ldt, c(& + call stdlib_${ci}$tpmqrt('R','N', m, kk , k, 0,nb, a(ii,1), lda,t(1,ctr * k + 1),ldt, c(& 1,1), ldc,c(1,ii), ldc, work, info ) end if end if work(1) = lw return - end subroutine stdlib_wlamtsqr + end subroutine stdlib_${ci}$lamtsqr - real(qp) function stdlib_wlangb( norm, n, kl, ku, ab, ldab,work ) + real(${ck}$) function stdlib_${ci}$langb( norm, n, kl, ku, ab, ldab,work ) !! ZLANGB: returns the value of the one norm, or the Frobenius norm, or !! the infinity norm, or the element of largest absolute value of an !! n by n band matrix A, with kl sub-diagonals and ku super-diagonals. @@ -42291,13 +42293,13 @@ module stdlib_linalg_lapack_w character, intent(in) :: norm integer(ilp), intent(in) :: kl, ku, ldab, n ! Array Arguments - real(qp), intent(out) :: work(*) - complex(qp), intent(in) :: ab(ldab,*) + real(${ck}$), intent(out) :: work(*) + complex(${ck}$), intent(in) :: ab(ldab,*) ! ===================================================================== ! Local Scalars integer(ilp) :: i, j, k, l - real(qp) :: scale, sum, value, temp + real(${ck}$) :: scale, sum, value, temp ! Intrinsic Functions intrinsic :: abs,max,min,sqrt ! Executable Statements @@ -42309,7 +42311,7 @@ module stdlib_linalg_lapack_w do j = 1, n do i = max( ku+2-j, 1 ), min( n+ku+1-j, kl+ku+1 ) temp = abs( ab( i, j ) ) - if( value1 ) then - call stdlib_wlassq( n-1, dl, 1, scale, sum ) - call stdlib_wlassq( n-1, du, 1, scale, sum ) + call stdlib_${ci}$lassq( n-1, dl, 1, scale, sum ) + call stdlib_${ci}$lassq( n-1, du, 1, scale, sum ) end if anorm = scale*sqrt( sum ) end if - stdlib_wlangt = anorm + stdlib_${ci}$langt = anorm return - end function stdlib_wlangt + end function stdlib_${ci}$langt - real(qp) function stdlib_wlanhb( norm, uplo, n, k, ab, ldab,work ) + real(${ck}$) function stdlib_${ci}$lanhb( norm, uplo, n, k, ab, ldab,work ) !! ZLANHB: returns the value of the one norm, or the Frobenius norm, or !! the infinity norm, or the element of largest absolute value of an !! n by n hermitian band matrix A, with k super-diagonals. @@ -42514,13 +42516,13 @@ module stdlib_linalg_lapack_w character, intent(in) :: norm, uplo integer(ilp), intent(in) :: k, ldab, n ! Array Arguments - real(qp), intent(out) :: work(*) - complex(qp), intent(in) :: ab(ldab,*) + real(${ck}$), intent(out) :: work(*) + complex(${ck}$), intent(in) :: ab(ldab,*) ! ===================================================================== ! Local Scalars integer(ilp) :: i, j, l - real(qp) :: absa, scale, sum, value + real(${ck}$) :: absa, scale, sum, value ! Intrinsic Functions intrinsic :: abs,real,max,min,sqrt ! Executable Statements @@ -42533,18 +42535,18 @@ module stdlib_linalg_lapack_w do j = 1, n do i = max( k+2-j, 1 ), k sum = abs( ab( i, j ) ) - if( value < sum .or. stdlib_qisnan( sum ) ) value = sum + if( value < sum .or. stdlib_${c2ri(ci)}$isnan( sum ) ) value = sum end do - sum = abs( real( ab( k+1, j ),KIND=qp) ) - if( value < sum .or. stdlib_qisnan( sum ) ) value = sum + sum = abs( real( ab( k+1, j ),KIND=${ck}$) ) + if( value < sum .or. stdlib_${c2ri(ci)}$isnan( sum ) ) value = sum end do else do j = 1, n - sum = abs( real( ab( 1, j ),KIND=qp) ) - if( value < sum .or. stdlib_qisnan( sum ) ) value = sum + sum = abs( real( ab( 1, j ),KIND=${ck}$) ) + if( value < sum .or. stdlib_${c2ri(ci)}$isnan( sum ) ) value = sum do i = 2, min( n+1-j, k+1 ) sum = abs( ab( i, j ) ) - if( value < sum .or. stdlib_qisnan( sum ) ) value = sum + if( value < sum .or. stdlib_${c2ri(ci)}$isnan( sum ) ) value = sum end do end do end if @@ -42561,25 +42563,25 @@ module stdlib_linalg_lapack_w sum = sum + absa work( i ) = work( i ) + absa end do - work( j ) = sum + abs( real( ab( k+1, j ),KIND=qp) ) + work( j ) = sum + abs( real( ab( k+1, j ),KIND=${ck}$) ) end do do i = 1, n sum = work( i ) - if( value < sum .or. stdlib_qisnan( sum ) ) value = sum + if( value < sum .or. stdlib_${c2ri(ci)}$isnan( sum ) ) value = sum end do else do i = 1, n work( i ) = zero end do do j = 1, n - sum = work( j ) + abs( real( ab( 1, j ),KIND=qp) ) + sum = work( j ) + abs( real( ab( 1, j ),KIND=${ck}$) ) l = 1 - j do i = j + 1, min( n, j+k ) absa = abs( ab( l+i, j ) ) sum = sum + absa work( i ) = work( i ) + absa end do - if( value < sum .or. stdlib_qisnan( sum ) ) value = sum + if( value < sum .or. stdlib_${c2ri(ci)}$isnan( sum ) ) value = sum end do end if else if( ( stdlib_lsame( norm, 'F' ) ) .or. ( stdlib_lsame( norm, 'E' ) ) ) & @@ -42590,13 +42592,13 @@ module stdlib_linalg_lapack_w if( k>0 ) then if( stdlib_lsame( uplo, 'U' ) ) then do j = 2, n - call stdlib_wlassq( min( j-1, k ), ab( max( k+2-j, 1 ), j ),1, scale, sum ) + call stdlib_${ci}$lassq( min( j-1, k ), ab( max( k+2-j, 1 ), j ),1, scale, sum ) end do l = k + 1 else do j = 1, n - 1 - call stdlib_wlassq( min( n-j, k ), ab( 2, j ), 1, scale,sum ) + call stdlib_${ci}$lassq( min( n-j, k ), ab( 2, j ), 1, scale,sum ) end do l = 1 end if @@ -42605,8 +42607,8 @@ module stdlib_linalg_lapack_w l = 1 end if do j = 1, n - if( real( ab( l, j ),KIND=qp)/=zero ) then - absa = abs( real( ab( l, j ),KIND=qp) ) + if( real( ab( l, j ),KIND=${ck}$)/=zero ) then + absa = abs( real( ab( l, j ),KIND=${ck}$) ) if( scale l(0,0) - temp = abs( real( a( j+j*lda ),KIND=qp) ) - if( value < temp .or. stdlib_qisnan( temp ) )value = temp + temp = abs( real( a( j+j*lda ),KIND=${ck}$) ) + if( value < temp .or. stdlib_${c2ri(ci)}$isnan( temp ) )value = temp do i = 1, n - 1 temp = abs( a( i+j*lda ) ) - if( value < temp .or. stdlib_qisnan( temp ) )value = temp + if( value < temp .or. stdlib_${c2ri(ci)}$isnan( temp ) )value = temp end do do j = 1, k - 1 do i = 0, j - 2 temp = abs( a( i+j*lda ) ) - if( value < temp .or. stdlib_qisnan( temp ) )value = temp + if( value < temp .or. stdlib_${c2ri(ci)}$isnan( temp ) )value = temp end do i = j - 1 ! l(k+j,k+j) - temp = abs( real( a( i+j*lda ),KIND=qp) ) - if( value < temp .or. stdlib_qisnan( temp ) )value = temp + temp = abs( real( a( i+j*lda ),KIND=${ck}$) ) + if( value < temp .or. stdlib_${c2ri(ci)}$isnan( temp ) )value = temp i = j ! -> l(j,j) - temp = abs( real( a( i+j*lda ),KIND=qp) ) - if( value < temp .or. stdlib_qisnan( temp ) )value = temp + temp = abs( real( a( i+j*lda ),KIND=${ck}$) ) + if( value < temp .or. stdlib_${c2ri(ci)}$isnan( temp ) )value = temp do i = j + 1, n - 1 temp = abs( a( i+j*lda ) ) - if( value < temp .or. stdlib_qisnan( temp ) )value = temp + if( value < temp .or. stdlib_${c2ri(ci)}$isnan( temp ) )value = temp end do end do else @@ -42824,29 +42826,29 @@ module stdlib_linalg_lapack_w do j = 0, k - 2 do i = 0, k + j - 2 temp = abs( a( i+j*lda ) ) - if( value < temp .or. stdlib_qisnan( temp ) )value = temp + if( value < temp .or. stdlib_${c2ri(ci)}$isnan( temp ) )value = temp end do i = k + j - 1 ! -> u(i,i) - temp = abs( real( a( i+j*lda ),KIND=qp) ) - if( value < temp .or. stdlib_qisnan( temp ) )value = temp + temp = abs( real( a( i+j*lda ),KIND=${ck}$) ) + if( value < temp .or. stdlib_${c2ri(ci)}$isnan( temp ) )value = temp i = i + 1 ! =k+j; i -> u(j,j) - temp = abs( real( a( i+j*lda ),KIND=qp) ) - if( value < temp .or. stdlib_qisnan( temp ) )value = temp + temp = abs( real( a( i+j*lda ),KIND=${ck}$) ) + if( value < temp .or. stdlib_${c2ri(ci)}$isnan( temp ) )value = temp do i = k + j + 1, n - 1 temp = abs( a( i+j*lda ) ) - if( value < temp .or. stdlib_qisnan( temp ) )value = temp + if( value < temp .or. stdlib_${c2ri(ci)}$isnan( temp ) )value = temp end do end do do i = 0, n - 2 temp = abs( a( i+j*lda ) ) - if( value < temp .or. stdlib_qisnan( temp ) )value = temp + if( value < temp .or. stdlib_${c2ri(ci)}$isnan( temp ) )value = temp ! j=k-1 end do ! i=n-1 -> u(n-1,n-1) - temp = abs( real( a( i+j*lda ),KIND=qp) ) - if( value < temp .or. stdlib_qisnan( temp ) )value = temp + temp = abs( real( a( i+j*lda ),KIND=${ck}$) ) + if( value < temp .or. stdlib_${c2ri(ci)}$isnan( temp ) )value = temp end if else ! xpose case; a is k by n @@ -42855,34 +42857,34 @@ module stdlib_linalg_lapack_w do j = 0, k - 2 do i = 0, j - 1 temp = abs( a( i+j*lda ) ) - if( value < temp .or. stdlib_qisnan( temp ) )value = temp + if( value < temp .or. stdlib_${c2ri(ci)}$isnan( temp ) )value = temp end do i = j ! l(i,i) - temp = abs( real( a( i+j*lda ),KIND=qp) ) - if( value < temp .or. stdlib_qisnan( temp ) )value = temp + temp = abs( real( a( i+j*lda ),KIND=${ck}$) ) + if( value < temp .or. stdlib_${c2ri(ci)}$isnan( temp ) )value = temp i = j + 1 ! l(j+k,j+k) - temp = abs( real( a( i+j*lda ),KIND=qp) ) - if( value < temp .or. stdlib_qisnan( temp ) )value = temp + temp = abs( real( a( i+j*lda ),KIND=${ck}$) ) + if( value < temp .or. stdlib_${c2ri(ci)}$isnan( temp ) )value = temp do i = j + 2, k - 1 temp = abs( a( i+j*lda ) ) - if( value < temp .or. stdlib_qisnan( temp ) )value = temp + if( value < temp .or. stdlib_${c2ri(ci)}$isnan( temp ) )value = temp end do end do j = k - 1 do i = 0, k - 2 temp = abs( a( i+j*lda ) ) - if( value < temp .or. stdlib_qisnan( temp ) )value = temp + if( value < temp .or. stdlib_${c2ri(ci)}$isnan( temp ) )value = temp end do i = k - 1 ! -> l(i,i) is at a(i,j) - temp = abs( real( a( i+j*lda ),KIND=qp) ) - if( value < temp .or. stdlib_qisnan( temp ) )value = temp + temp = abs( real( a( i+j*lda ),KIND=${ck}$) ) + if( value < temp .or. stdlib_${c2ri(ci)}$isnan( temp ) )value = temp do j = k, n - 1 do i = 0, k - 1 temp = abs( a( i+j*lda ) ) - if( value < temp .or. stdlib_qisnan( temp ) )value = temp + if( value < temp .or. stdlib_${c2ri(ci)}$isnan( temp ) )value = temp end do end do else @@ -42890,33 +42892,33 @@ module stdlib_linalg_lapack_w do j = 0, k - 2 do i = 0, k - 1 temp = abs( a( i+j*lda ) ) - if( value < temp .or. stdlib_qisnan( temp ) )value = temp + if( value < temp .or. stdlib_${c2ri(ci)}$isnan( temp ) )value = temp end do end do j = k - 1 ! -> u(j,j) is at a(0,j) - temp = abs( real( a( 0+j*lda ),KIND=qp) ) - if( value < temp .or. stdlib_qisnan( temp ) )value = temp + temp = abs( real( a( 0+j*lda ),KIND=${ck}$) ) + if( value < temp .or. stdlib_${c2ri(ci)}$isnan( temp ) )value = temp do i = 1, k - 1 temp = abs( a( i+j*lda ) ) - if( value < temp .or. stdlib_qisnan( temp ) )value = temp + if( value < temp .or. stdlib_${c2ri(ci)}$isnan( temp ) )value = temp end do do j = k, n - 1 do i = 0, j - k - 1 temp = abs( a( i+j*lda ) ) - if( value < temp .or. stdlib_qisnan( temp ) )value = temp + if( value < temp .or. stdlib_${c2ri(ci)}$isnan( temp ) )value = temp end do i = j - k ! -> u(i,i) at a(i,j) - temp = abs( real( a( i+j*lda ),KIND=qp) ) - if( value < temp .or. stdlib_qisnan( temp ) )value = temp + temp = abs( real( a( i+j*lda ),KIND=${ck}$) ) + if( value < temp .or. stdlib_${c2ri(ci)}$isnan( temp ) )value = temp i = j - k + 1 ! u(j,j) - temp = abs( real( a( i+j*lda ),KIND=qp) ) - if( value < temp .or. stdlib_qisnan( temp ) )value = temp + temp = abs( real( a( i+j*lda ),KIND=${ck}$) ) + if( value < temp .or. stdlib_${c2ri(ci)}$isnan( temp ) )value = temp do i = j - k + 2, k - 1 temp = abs( a( i+j*lda ) ) - if( value < temp .or. stdlib_qisnan( temp ) )value = temp + if( value < temp .or. stdlib_${c2ri(ci)}$isnan( temp ) )value = temp end do end do end if @@ -42929,30 +42931,30 @@ module stdlib_linalg_lapack_w ! uplo ='l' j = 0 ! -> l(k,k) - temp = abs( real( a( j+j*lda ),KIND=qp) ) - if( value < temp .or. stdlib_qisnan( temp ) )value = temp - temp = abs( real( a( j+1+j*lda ),KIND=qp) ) - if( value < temp .or. stdlib_qisnan( temp ) )value = temp + temp = abs( real( a( j+j*lda ),KIND=${ck}$) ) + if( value < temp .or. stdlib_${c2ri(ci)}$isnan( temp ) )value = temp + temp = abs( real( a( j+1+j*lda ),KIND=${ck}$) ) + if( value < temp .or. stdlib_${c2ri(ci)}$isnan( temp ) )value = temp do i = 2, n temp = abs( a( i+j*lda ) ) - if( value < temp .or. stdlib_qisnan( temp ) )value = temp + if( value < temp .or. stdlib_${c2ri(ci)}$isnan( temp ) )value = temp end do do j = 1, k - 1 do i = 0, j - 1 temp = abs( a( i+j*lda ) ) - if( value < temp .or. stdlib_qisnan( temp ) )value = temp + if( value < temp .or. stdlib_${c2ri(ci)}$isnan( temp ) )value = temp end do i = j ! l(k+j,k+j) - temp = abs( real( a( i+j*lda ),KIND=qp) ) - if( value < temp .or. stdlib_qisnan( temp ) )value = temp + temp = abs( real( a( i+j*lda ),KIND=${ck}$) ) + if( value < temp .or. stdlib_${c2ri(ci)}$isnan( temp ) )value = temp i = j + 1 ! -> l(j,j) - temp = abs( real( a( i+j*lda ),KIND=qp) ) - if( value < temp .or. stdlib_qisnan( temp ) )value = temp + temp = abs( real( a( i+j*lda ),KIND=${ck}$) ) + if( value < temp .or. stdlib_${c2ri(ci)}$isnan( temp ) )value = temp do i = j + 2, n temp = abs( a( i+j*lda ) ) - if( value < temp .or. stdlib_qisnan( temp ) )value = temp + if( value < temp .or. stdlib_${c2ri(ci)}$isnan( temp ) )value = temp end do end do else @@ -42960,33 +42962,33 @@ module stdlib_linalg_lapack_w do j = 0, k - 2 do i = 0, k + j - 1 temp = abs( a( i+j*lda ) ) - if( value < temp .or. stdlib_qisnan( temp ) )value = temp + if( value < temp .or. stdlib_${c2ri(ci)}$isnan( temp ) )value = temp end do i = k + j ! -> u(i,i) - temp = abs( real( a( i+j*lda ),KIND=qp) ) - if( value < temp .or. stdlib_qisnan( temp ) )value = temp + temp = abs( real( a( i+j*lda ),KIND=${ck}$) ) + if( value < temp .or. stdlib_${c2ri(ci)}$isnan( temp ) )value = temp i = i + 1 ! =k+j+1; i -> u(j,j) - temp = abs( real( a( i+j*lda ),KIND=qp) ) - if( value < temp .or. stdlib_qisnan( temp ) )value = temp + temp = abs( real( a( i+j*lda ),KIND=${ck}$) ) + if( value < temp .or. stdlib_${c2ri(ci)}$isnan( temp ) )value = temp do i = k + j + 2, n temp = abs( a( i+j*lda ) ) - if( value < temp .or. stdlib_qisnan( temp ) )value = temp + if( value < temp .or. stdlib_${c2ri(ci)}$isnan( temp ) )value = temp end do end do do i = 0, n - 2 temp = abs( a( i+j*lda ) ) - if( value < temp .or. stdlib_qisnan( temp ) )value = temp + if( value < temp .or. stdlib_${c2ri(ci)}$isnan( temp ) )value = temp ! j=k-1 end do ! i=n-1 -> u(n-1,n-1) - temp = abs( real( a( i+j*lda ),KIND=qp) ) - if( value < temp .or. stdlib_qisnan( temp ) )value = temp + temp = abs( real( a( i+j*lda ),KIND=${ck}$) ) + if( value < temp .or. stdlib_${c2ri(ci)}$isnan( temp ) )value = temp i = n ! -> u(k-1,k-1) - temp = abs( real( a( i+j*lda ),KIND=qp) ) - if( value < temp .or. stdlib_qisnan( temp ) )value = temp + temp = abs( real( a( i+j*lda ),KIND=${ck}$) ) + if( value < temp .or. stdlib_${c2ri(ci)}$isnan( temp ) )value = temp end if else ! xpose case; a is k by n+1 @@ -42994,43 +42996,43 @@ module stdlib_linalg_lapack_w ! uplo ='l' j = 0 ! -> l(k,k) at a(0,0) - temp = abs( real( a( j+j*lda ),KIND=qp) ) - if( value < temp .or. stdlib_qisnan( temp ) )value = temp + temp = abs( real( a( j+j*lda ),KIND=${ck}$) ) + if( value < temp .or. stdlib_${c2ri(ci)}$isnan( temp ) )value = temp do i = 1, k - 1 temp = abs( a( i+j*lda ) ) - if( value < temp .or. stdlib_qisnan( temp ) )value = temp + if( value < temp .or. stdlib_${c2ri(ci)}$isnan( temp ) )value = temp end do do j = 1, k - 1 do i = 0, j - 2 temp = abs( a( i+j*lda ) ) - if( value < temp .or. stdlib_qisnan( temp ) )value = temp + if( value < temp .or. stdlib_${c2ri(ci)}$isnan( temp ) )value = temp end do i = j - 1 ! l(i,i) - temp = abs( real( a( i+j*lda ),KIND=qp) ) - if( value < temp .or. stdlib_qisnan( temp ) )value = temp + temp = abs( real( a( i+j*lda ),KIND=${ck}$) ) + if( value < temp .or. stdlib_${c2ri(ci)}$isnan( temp ) )value = temp i = j ! l(j+k,j+k) - temp = abs( real( a( i+j*lda ),KIND=qp) ) - if( value < temp .or. stdlib_qisnan( temp ) )value = temp + temp = abs( real( a( i+j*lda ),KIND=${ck}$) ) + if( value < temp .or. stdlib_${c2ri(ci)}$isnan( temp ) )value = temp do i = j + 1, k - 1 temp = abs( a( i+j*lda ) ) - if( value < temp .or. stdlib_qisnan( temp ) )value = temp + if( value < temp .or. stdlib_${c2ri(ci)}$isnan( temp ) )value = temp end do end do j = k do i = 0, k - 2 temp = abs( a( i+j*lda ) ) - if( value < temp .or. stdlib_qisnan( temp ) )value = temp + if( value < temp .or. stdlib_${c2ri(ci)}$isnan( temp ) )value = temp end do i = k - 1 ! -> l(i,i) is at a(i,j) - temp = abs( real( a( i+j*lda ),KIND=qp) ) - if( value < temp .or. stdlib_qisnan( temp ) )value = temp + temp = abs( real( a( i+j*lda ),KIND=${ck}$) ) + if( value < temp .or. stdlib_${c2ri(ci)}$isnan( temp ) )value = temp do j = k + 1, n do i = 0, k - 1 temp = abs( a( i+j*lda ) ) - if( value < temp .or. stdlib_qisnan( temp ) )value = temp + if( value < temp .or. stdlib_${c2ri(ci)}$isnan( temp ) )value = temp end do end do else @@ -43038,44 +43040,44 @@ module stdlib_linalg_lapack_w do j = 0, k - 1 do i = 0, k - 1 temp = abs( a( i+j*lda ) ) - if( value < temp .or. stdlib_qisnan( temp ) )value = temp + if( value < temp .or. stdlib_${c2ri(ci)}$isnan( temp ) )value = temp end do end do j = k ! -> u(j,j) is at a(0,j) - temp = abs( real( a( 0+j*lda ),KIND=qp) ) - if( value < temp .or. stdlib_qisnan( temp ) )value = temp + temp = abs( real( a( 0+j*lda ),KIND=${ck}$) ) + if( value < temp .or. stdlib_${c2ri(ci)}$isnan( temp ) )value = temp do i = 1, k - 1 temp = abs( a( i+j*lda ) ) - if( value < temp .or. stdlib_qisnan( temp ) )value = temp + if( value < temp .or. stdlib_${c2ri(ci)}$isnan( temp ) )value = temp end do do j = k + 1, n - 1 do i = 0, j - k - 2 temp = abs( a( i+j*lda ) ) - if( value < temp .or. stdlib_qisnan( temp ) )value = temp + if( value < temp .or. stdlib_${c2ri(ci)}$isnan( temp ) )value = temp end do i = j - k - 1 ! -> u(i,i) at a(i,j) - temp = abs( real( a( i+j*lda ),KIND=qp) ) - if( value < temp .or. stdlib_qisnan( temp ) )value = temp + temp = abs( real( a( i+j*lda ),KIND=${ck}$) ) + if( value < temp .or. stdlib_${c2ri(ci)}$isnan( temp ) )value = temp i = j - k ! u(j,j) - temp = abs( real( a( i+j*lda ),KIND=qp) ) - if( value < temp .or. stdlib_qisnan( temp ) )value = temp + temp = abs( real( a( i+j*lda ),KIND=${ck}$) ) + if( value < temp .or. stdlib_${c2ri(ci)}$isnan( temp ) )value = temp do i = j - k + 1, k - 1 temp = abs( a( i+j*lda ) ) - if( value < temp .or. stdlib_qisnan( temp ) )value = temp + if( value < temp .or. stdlib_${c2ri(ci)}$isnan( temp ) )value = temp end do end do j = n do i = 0, k - 2 temp = abs( a( i+j*lda ) ) - if( value < temp .or. stdlib_qisnan( temp ) )value = temp + if( value < temp .or. stdlib_${c2ri(ci)}$isnan( temp ) )value = temp end do i = k - 1 ! u(k,k) at a(i,j) - temp = abs( real( a( i+j*lda ),KIND=qp) ) - if( value < temp .or. stdlib_qisnan( temp ) )value = temp + temp = abs( real( a( i+j*lda ),KIND=${ck}$) ) + if( value < temp .or. stdlib_${c2ri(ci)}$isnan( temp ) )value = temp end if end if end if @@ -43100,12 +43102,12 @@ module stdlib_linalg_lapack_w s = s + aa work( i ) = work( i ) + aa end do - aa = abs( real( a( i+j*lda ),KIND=qp) ) + aa = abs( real( a( i+j*lda ),KIND=${ck}$) ) ! -> a(j+k,j+k) work( j+k ) = s + aa if( i==k+k )go to 10 i = i + 1 - aa = abs( real( a( i+j*lda ),KIND=qp) ) + aa = abs( real( a( i+j*lda ),KIND=${ck}$) ) ! -> a(j,j) work( j ) = work( j ) + aa s = zero @@ -43122,7 +43124,7 @@ module stdlib_linalg_lapack_w value = work( 0 ) do i = 1, n-1 temp = work( i ) - if( value < temp .or. stdlib_qisnan( temp ) )value = temp + if( value < temp .or. stdlib_${c2ri(ci)}$isnan( temp ) )value = temp end do else ! ilu = 1 @@ -43140,14 +43142,14 @@ module stdlib_linalg_lapack_w work( i+k ) = work( i+k ) + aa end do if( j>0 ) then - aa = abs( real( a( i+j*lda ),KIND=qp) ) + aa = abs( real( a( i+j*lda ),KIND=${ck}$) ) ! -> a(j+k,j+k) s = s + aa work( i+k ) = work( i+k ) + s ! i=j i = i + 1 end if - aa = abs( real( a( i+j*lda ),KIND=qp) ) + aa = abs( real( a( i+j*lda ),KIND=${ck}$) ) ! -> a(j,j) work( j ) = aa s = zero @@ -43163,7 +43165,7 @@ module stdlib_linalg_lapack_w value = work( 0 ) do i = 1, n-1 temp = work( i ) - if( value < temp .or. stdlib_qisnan( temp ) )value = temp + if( value < temp .or. stdlib_${c2ri(ci)}$isnan( temp ) )value = temp end do end if else @@ -43181,11 +43183,11 @@ module stdlib_linalg_lapack_w s = s + aa work( i ) = work( i ) + aa end do - aa = abs( real( a( i+j*lda ),KIND=qp) ) + aa = abs( real( a( i+j*lda ),KIND=${ck}$) ) ! -> a(j+k,j+k) work( j+k ) = s + aa i = i + 1 - aa = abs( real( a( i+j*lda ),KIND=qp) ) + aa = abs( real( a( i+j*lda ),KIND=${ck}$) ) ! -> a(j,j) work( j ) = work( j ) + aa s = zero @@ -43201,7 +43203,7 @@ module stdlib_linalg_lapack_w value = work( 0 ) do i = 1, n-1 temp = work( i ) - if( value < temp .or. stdlib_qisnan( temp ) )value = temp + if( value < temp .or. stdlib_${c2ri(ci)}$isnan( temp ) )value = temp end do else ! ilu = 1 @@ -43216,13 +43218,13 @@ module stdlib_linalg_lapack_w s = s + aa work( i+k ) = work( i+k ) + aa end do - aa = abs( real( a( i+j*lda ),KIND=qp) ) + aa = abs( real( a( i+j*lda ),KIND=${ck}$) ) ! -> a(j+k,j+k) s = s + aa work( i+k ) = work( i+k ) + s ! i=j i = i + 1 - aa = abs( real( a( i+j*lda ),KIND=qp) ) + aa = abs( real( a( i+j*lda ),KIND=${ck}$) ) ! -> a(j,j) work( j ) = aa s = zero @@ -43238,7 +43240,7 @@ module stdlib_linalg_lapack_w value = work( 0 ) do i = 1, n-1 temp = work( i ) - if( value < temp .or. stdlib_qisnan( temp ) )value = temp + if( value < temp .or. stdlib_${c2ri(ci)}$isnan( temp ) )value = temp end do end if end if @@ -43267,7 +43269,7 @@ module stdlib_linalg_lapack_w work( j ) = s end do ! j=n1=k-1 is special - s = abs( real( a( 0+j*lda ),KIND=qp) ) + s = abs( real( a( 0+j*lda ),KIND=${ck}$) ) ! a(k-1,k-1) do i = 1, k - 1 aa = abs( a( i+j*lda ) ) @@ -43285,12 +43287,12 @@ module stdlib_linalg_lapack_w s = s + aa end do ! i=j-k - aa = abs( real( a( i+j*lda ),KIND=qp) ) + aa = abs( real( a( i+j*lda ),KIND=${ck}$) ) ! a(j-k,j-k) s = s + aa work( j-k ) = work( j-k ) + s i = i + 1 - s = abs( real( a( i+j*lda ),KIND=qp) ) + s = abs( real( a( i+j*lda ),KIND=${ck}$) ) ! a(j,j) do l = j + 1, n - 1 i = i + 1 @@ -43304,7 +43306,7 @@ module stdlib_linalg_lapack_w value = work( 0 ) do i = 1, n-1 temp = work( i ) - if( value < temp .or. stdlib_qisnan( temp ) )value = temp + if( value < temp .or. stdlib_${c2ri(ci)}$isnan( temp ) )value = temp end do else ! ilu=1 @@ -43322,14 +43324,14 @@ module stdlib_linalg_lapack_w work( i ) = work( i ) + aa s = s + aa end do - aa = abs( real( a( i+j*lda ),KIND=qp) ) + aa = abs( real( a( i+j*lda ),KIND=${ck}$) ) ! i=j so process of a(j,j) s = s + aa work( j ) = s ! is initialised here i = i + 1 ! i=j process a(j+k,j+k) - aa = abs( real( a( i+j*lda ),KIND=qp) ) + aa = abs( real( a( i+j*lda ),KIND=${ck}$) ) s = aa do l = k + j + 1, n - 1 i = i + 1 @@ -43349,7 +43351,7 @@ module stdlib_linalg_lapack_w s = s + aa end do ! i=k-1 - aa = abs( real( a( i+j*lda ),KIND=qp) ) + aa = abs( real( a( i+j*lda ),KIND=${ck}$) ) ! a(k-1,k-1) s = s + aa work( i ) = s @@ -43368,7 +43370,7 @@ module stdlib_linalg_lapack_w value = work( 0 ) do i = 1, n-1 temp = work( i ) - if( value < temp .or. stdlib_qisnan( temp ) )value = temp + if( value < temp .or. stdlib_${c2ri(ci)}$isnan( temp ) )value = temp end do end if else @@ -43389,7 +43391,7 @@ module stdlib_linalg_lapack_w work( j ) = s end do ! j=k - aa = abs( real( a( 0+j*lda ),KIND=qp) ) + aa = abs( real( a( 0+j*lda ),KIND=${ck}$) ) ! a(k,k) s = aa do i = 1, k - 1 @@ -43408,12 +43410,12 @@ module stdlib_linalg_lapack_w s = s + aa end do ! i=j-1-k - aa = abs( real( a( i+j*lda ),KIND=qp) ) + aa = abs( real( a( i+j*lda ),KIND=${ck}$) ) ! a(j-k-1,j-k-1) s = s + aa work( j-k-1 ) = work( j-k-1 ) + s i = i + 1 - aa = abs( real( a( i+j*lda ),KIND=qp) ) + aa = abs( real( a( i+j*lda ),KIND=${ck}$) ) ! a(j,j) s = aa do l = j + 1, n - 1 @@ -43434,14 +43436,14 @@ module stdlib_linalg_lapack_w s = s + aa end do ! i=k-1 - aa = abs( real( a( i+j*lda ),KIND=qp) ) + aa = abs( real( a( i+j*lda ),KIND=${ck}$) ) ! a(k-1,k-1) s = s + aa work( i ) = work( i ) + s value = work( 0 ) do i = 1, n-1 temp = work( i ) - if( value < temp .or. stdlib_qisnan( temp ) )value = temp + if( value < temp .or. stdlib_${c2ri(ci)}$isnan( temp ) )value = temp end do else ! ilu=1 @@ -43449,7 +43451,7 @@ module stdlib_linalg_lapack_w work( i ) = zero end do ! j=0 is special :process col a(k:n-1,k) - s = abs( real( a( 0 ),KIND=qp) ) + s = abs( real( a( 0 ),KIND=${ck}$) ) ! a(k,k) do i = 1, k - 1 aa = abs( a( i ) ) @@ -43467,14 +43469,14 @@ module stdlib_linalg_lapack_w work( i ) = work( i ) + aa s = s + aa end do - aa = abs( real( a( i+j*lda ),KIND=qp) ) + aa = abs( real( a( i+j*lda ),KIND=${ck}$) ) ! i=j-1 so process of a(j-1,j-1) s = s + aa work( j-1 ) = s ! is initialised here i = i + 1 ! i=j process a(j+k,j+k) - aa = abs( real( a( i+j*lda ),KIND=qp) ) + aa = abs( real( a( i+j*lda ),KIND=${ck}$) ) s = aa do l = k + j + 1, n - 1 i = i + 1 @@ -43494,7 +43496,7 @@ module stdlib_linalg_lapack_w s = s + aa end do ! i=k-1 - aa = abs( real( a( i+j*lda ),KIND=qp) ) + aa = abs( real( a( i+j*lda ),KIND=${ck}$) ) ! a(k-1,k-1) s = s + aa work( i ) = s @@ -43513,7 +43515,7 @@ module stdlib_linalg_lapack_w value = work( 0 ) do i = 1, n-1 temp = work( i ) - if( value < temp .or. stdlib_qisnan( temp ) )value = temp + if( value < temp .or. stdlib_${c2ri(ci)}$isnan( temp ) )value = temp end do end if end if @@ -43531,11 +43533,11 @@ module stdlib_linalg_lapack_w if( ilu==0 ) then ! a is upper do j = 0, k - 3 - call stdlib_wlassq( k-j-2, a( k+j+1+j*lda ), 1, scale, s ) + call stdlib_${ci}$lassq( k-j-2, a( k+j+1+j*lda ), 1, scale, s ) ! l at a(k,0) end do do j = 0, k - 1 - call stdlib_wlassq( k+j-1, a( 0+j*lda ), 1, scale, s ) + call stdlib_${ci}$lassq( k+j-1, a( 0+j*lda ), 1, scale, s ) ! trap u at a(0,0) end do s = s + s @@ -43543,7 +43545,7 @@ module stdlib_linalg_lapack_w l = k - 1 ! -> u(k,k) at a(k-1,0) do i = 0, k - 2 - aa = real( a( l ),KIND=qp) + aa = real( a( l ),KIND=${ck}$) ! u(k+i,k+i) if( aa/=zero ) then if( scale l(k,k) at a(0,1) do i = 1, k - 1 - aa = real( a( l ),KIND=qp) + aa = real( a( l ),KIND=${ck}$) ! l(k-1+i,k-1+i) if( aa/=zero ) then if( scale u(k-1,k-1) at a(0,k-1) - aa = real( a( l ),KIND=qp) + aa = real( a( l ),KIND=${ck}$) ! u(k-1,k-1) if( aa/=zero ) then if( scale u(0,0) at a(0,k) do j = k, n - 1 - aa = real( a( l ),KIND=qp) + aa = real( a( l ),KIND=${ck}$) ! -> u(j-k,j-k) if( aa/=zero ) then if( scale u(j,j) if( aa/=zero ) then if( scale l(0,0) at a(0,0) do i = 0, k - 2 - aa = real( a( l ),KIND=qp) + aa = real( a( l ),KIND=${ck}$) ! l(i,i) if( aa/=zero ) then if( scale k-1 + (k-1)*lda or l(k-1,k-1) at a(k-1,k-1) - aa = real( a( l ),KIND=qp) + aa = real( a( l ),KIND=${ck}$) ! l(k-1,k-1) at a(k-1,k-1) if( aa/=zero ) then if( scale u(k,k) at a(k,0) do i = 0, k - 1 - aa = real( a( l ),KIND=qp) + aa = real( a( l ),KIND=${ck}$) ! u(k+i,k+i) if( aa/=zero ) then if( scale l(k,k) at a(0,0) do i = 0, k - 1 - aa = real( a( l ),KIND=qp) + aa = real( a( l ),KIND=${ck}$) ! l(k-1+i,k-1+i) if( aa/=zero ) then if( scale u(k,k) at a(0,k) - aa = real( a( l ),KIND=qp) + aa = real( a( l ),KIND=${ck}$) ! u(k,k) if( aa/=zero ) then if( scale u(0,0) at a(0,k+1) do j = k + 1, n - 1 - aa = real( a( l ),KIND=qp) + aa = real( a( l ),KIND=${ck}$) ! -> u(j-k-1,j-k-1) if( aa/=zero ) then if( scale u(j,j) if( aa/=zero ) then if( scale u(k-1,k-1) at a(k-1,n) - aa = real( a( l ),KIND=qp) + aa = real( a( l ),KIND=${ck}$) ! u(k,k) if( aa/=zero ) then if( scale l(k,k) at a(0,0) - aa = real( a( l ),KIND=qp) + aa = real( a( l ),KIND=${ck}$) ! l(k,k) at a(0,0) if( aa/=zero ) then if( scale l(0,0) at a(0,1) do i = 0, k - 2 - aa = real( a( l ),KIND=qp) + aa = real( a( l ),KIND=${ck}$) ! l(i,i) if( aa/=zero ) then if( scale k - 1 + k*lda or l(k-1,k-1) at a(k-1,k) - aa = real( a( l ),KIND=qp) + aa = real( a( l ),KIND=${ck}$) ! l(k-1,k-1) at a(k-1,k) if( aa/=zero ) then if( scale1 ) then - call stdlib_wlassq( n-1, e, 1, scale, sum ) + call stdlib_${ci}$lassq( n-1, e, 1, scale, sum ) sum = 2*sum end if - call stdlib_qlassq( n, d, 1, scale, sum ) + call stdlib_${c2ri(ci)}$lassq( n, d, 1, scale, sum ) anorm = scale*sqrt( sum ) end if - stdlib_wlanht = anorm + stdlib_${ci}$lanht = anorm return - end function stdlib_wlanht + end function stdlib_${ci}$lanht - real(qp) function stdlib_wlansb( norm, uplo, n, k, ab, ldab,work ) + real(${ck}$) function stdlib_${ci}$lansb( norm, uplo, n, k, ab, ldab,work ) !! ZLANSB: returns the value of the one norm, or the Frobenius norm, or !! the infinity norm, or the element of largest absolute value of an !! n by n symmetric band matrix A, with k super-diagonals. @@ -44226,13 +44228,13 @@ module stdlib_linalg_lapack_w character, intent(in) :: norm, uplo integer(ilp), intent(in) :: k, ldab, n ! Array Arguments - real(qp), intent(out) :: work(*) - complex(qp), intent(in) :: ab(ldab,*) + real(${ck}$), intent(out) :: work(*) + complex(${ck}$), intent(in) :: ab(ldab,*) ! ===================================================================== ! Local Scalars integer(ilp) :: i, j, l - real(qp) :: absa, scale, sum, value + real(${ck}$) :: absa, scale, sum, value ! Intrinsic Functions intrinsic :: abs,max,min,sqrt ! Executable Statements @@ -44245,14 +44247,14 @@ module stdlib_linalg_lapack_w do j = 1, n do i = max( k+2-j, 1 ), k + 1 sum = abs( ab( i, j ) ) - if( value < sum .or. stdlib_qisnan( sum ) ) value = sum + if( value < sum .or. stdlib_${c2ri(ci)}$isnan( sum ) ) value = sum end do end do else do j = 1, n do i = 1, min( n+1-j, k+1 ) sum = abs( ab( i, j ) ) - if( value < sum .or. stdlib_qisnan( sum ) ) value = sum + if( value < sum .or. stdlib_${c2ri(ci)}$isnan( sum ) ) value = sum end do end do end if @@ -44273,7 +44275,7 @@ module stdlib_linalg_lapack_w end do do i = 1, n sum = work( i ) - if( value < sum .or. stdlib_qisnan( sum ) ) value = sum + if( value < sum .or. stdlib_${c2ri(ci)}$isnan( sum ) ) value = sum end do else do i = 1, n @@ -44287,7 +44289,7 @@ module stdlib_linalg_lapack_w sum = sum + absa work( i ) = work( i ) + absa end do - if( value < sum .or. stdlib_qisnan( sum ) ) value = sum + if( value < sum .or. stdlib_${c2ri(ci)}$isnan( sum ) ) value = sum end do end if else if( ( stdlib_lsame( norm, 'F' ) ) .or. ( stdlib_lsame( norm, 'E' ) ) ) & @@ -44298,13 +44300,13 @@ module stdlib_linalg_lapack_w if( k>0 ) then if( stdlib_lsame( uplo, 'U' ) ) then do j = 2, n - call stdlib_wlassq( min( j-1, k ), ab( max( k+2-j, 1 ), j ),1, scale, sum ) + call stdlib_${ci}$lassq( min( j-1, k ), ab( max( k+2-j, 1 ), j ),1, scale, sum ) end do l = k + 1 else do j = 1, n - 1 - call stdlib_wlassq( min( n-j, k ), ab( 2, j ), 1, scale,sum ) + call stdlib_${ci}$lassq( min( n-j, k ), ab( 2, j ), 1, scale,sum ) end do l = 1 end if @@ -44312,15 +44314,15 @@ module stdlib_linalg_lapack_w else l = 1 end if - call stdlib_wlassq( n, ab( l, 1 ), ldab, scale, sum ) + call stdlib_${ci}$lassq( n, ab( l, 1 ), ldab, scale, sum ) value = scale*sqrt( sum ) end if - stdlib_wlansb = value + stdlib_${ci}$lansb = value return - end function stdlib_wlansb + end function stdlib_${ci}$lansb - real(qp) function stdlib_wlansp( norm, uplo, n, ap, work ) + real(${ck}$) function stdlib_${ci}$lansp( norm, uplo, n, ap, work ) !! ZLANSP: returns the value of the one norm, or the Frobenius norm, or !! the infinity norm, or the element of largest absolute value of a !! complex symmetric matrix A, supplied in packed form. @@ -44331,13 +44333,13 @@ module stdlib_linalg_lapack_w character, intent(in) :: norm, uplo integer(ilp), intent(in) :: n ! Array Arguments - real(qp), intent(out) :: work(*) - complex(qp), intent(in) :: ap(*) + real(${ck}$), intent(out) :: work(*) + complex(${ck}$), intent(in) :: ap(*) ! ===================================================================== ! Local Scalars integer(ilp) :: i, j, k - real(qp) :: absa, scale, sum, value + real(${ck}$) :: absa, scale, sum, value ! Intrinsic Functions intrinsic :: abs,real,aimag,sqrt ! Executable Statements @@ -44351,7 +44353,7 @@ module stdlib_linalg_lapack_w do j = 1, n do i = k, k + j - 1 sum = abs( ap( i ) ) - if( value < sum .or. stdlib_qisnan( sum ) ) value = sum + if( value < sum .or. stdlib_${c2ri(ci)}$isnan( sum ) ) value = sum end do k = k + j end do @@ -44360,7 +44362,7 @@ module stdlib_linalg_lapack_w do j = 1, n do i = k, k + n - j sum = abs( ap( i ) ) - if( value < sum .or. stdlib_qisnan( sum ) ) value = sum + if( value < sum .or. stdlib_${c2ri(ci)}$isnan( sum ) ) value = sum end do k = k + n - j + 1 end do @@ -44384,7 +44386,7 @@ module stdlib_linalg_lapack_w end do do i = 1, n sum = work( i ) - if( value < sum .or. stdlib_qisnan( sum ) ) value = sum + if( value < sum .or. stdlib_${c2ri(ci)}$isnan( sum ) ) value = sum end do else do i = 1, n @@ -44399,7 +44401,7 @@ module stdlib_linalg_lapack_w work( i ) = work( i ) + absa k = k + 1 end do - if( value < sum .or. stdlib_qisnan( sum ) ) value = sum + if( value < sum .or. stdlib_${c2ri(ci)}$isnan( sum ) ) value = sum end do end if else if( ( stdlib_lsame( norm, 'F' ) ) .or. ( stdlib_lsame( norm, 'E' ) ) ) & @@ -44410,20 +44412,20 @@ module stdlib_linalg_lapack_w k = 2 if( stdlib_lsame( uplo, 'U' ) ) then do j = 2, n - call stdlib_wlassq( j-1, ap( k ), 1, scale, sum ) + call stdlib_${ci}$lassq( j-1, ap( k ), 1, scale, sum ) k = k + j end do else do j = 1, n - 1 - call stdlib_wlassq( n-j, ap( k ), 1, scale, sum ) + call stdlib_${ci}$lassq( n-j, ap( k ), 1, scale, sum ) k = k + n - j + 1 end do end if sum = 2*sum k = 1 do i = 1, n - if( real( ap( k ),KIND=qp)/=zero ) then - absa = abs( real( ap( k ),KIND=qp) ) + if( real( ap( k ),KIND=${ck}$)/=zero ) then + absa = abs( real( ap( k ),KIND=${ck}$) ) if( scale0 ) then do j = 2, n - call stdlib_wlassq( min( j-1, k ),ab( max( k+2-j, 1 ), j ), 1, scale,& + call stdlib_${ci}$lassq( min( j-1, k ),ab( max( k+2-j, 1 ), j ), 1, scale,& sum ) end do end if @@ -44714,7 +44716,7 @@ module stdlib_linalg_lapack_w scale = zero sum = one do j = 1, n - call stdlib_wlassq( min( j, k+1 ), ab( max( k+2-j, 1 ), j ),1, scale, sum ) + call stdlib_${ci}$lassq( min( j, k+1 ), ab( max( k+2-j, 1 ), j ),1, scale, sum ) end do end if @@ -44724,25 +44726,25 @@ module stdlib_linalg_lapack_w sum = n if( k>0 ) then do j = 1, n - 1 - call stdlib_wlassq( min( n-j, k ), ab( 2, j ), 1, scale,sum ) + call stdlib_${ci}$lassq( min( n-j, k ), ab( 2, j ), 1, scale,sum ) end do end if else scale = zero sum = one do j = 1, n - call stdlib_wlassq( min( n-j+1, k+1 ), ab( 1, j ), 1, scale,sum ) + call stdlib_${ci}$lassq( min( n-j+1, k+1 ), ab( 1, j ), 1, scale,sum ) end do end if end if value = scale*sqrt( sum ) end if - stdlib_wlantb = value + stdlib_${ci}$lantb = value return - end function stdlib_wlantb + end function stdlib_${ci}$lantb - real(qp) function stdlib_wlantp( norm, uplo, diag, n, ap, work ) + real(${ck}$) function stdlib_${ci}$lantp( norm, uplo, diag, n, ap, work ) !! ZLANTP: returns the value of the one norm, or the Frobenius norm, or !! the infinity norm, or the element of largest absolute value of a !! triangular matrix A, supplied in packed form. @@ -44753,14 +44755,14 @@ module stdlib_linalg_lapack_w character, intent(in) :: diag, norm, uplo integer(ilp), intent(in) :: n ! Array Arguments - real(qp), intent(out) :: work(*) - complex(qp), intent(in) :: ap(*) + real(${ck}$), intent(out) :: work(*) + complex(${ck}$), intent(in) :: ap(*) ! ===================================================================== ! Local Scalars logical(lk) :: udiag integer(ilp) :: i, j, k - real(qp) :: scale, sum, value + real(${ck}$) :: scale, sum, value ! Intrinsic Functions intrinsic :: abs,sqrt ! Executable Statements @@ -44775,7 +44777,7 @@ module stdlib_linalg_lapack_w do j = 1, n do i = k, k + j - 2 sum = abs( ap( i ) ) - if( value < sum .or. stdlib_qisnan( sum ) ) value = sum + if( value < sum .or. stdlib_${c2ri(ci)}$isnan( sum ) ) value = sum end do k = k + j end do @@ -44783,7 +44785,7 @@ module stdlib_linalg_lapack_w do j = 1, n do i = k + 1, k + n - j sum = abs( ap( i ) ) - if( value < sum .or. stdlib_qisnan( sum ) ) value = sum + if( value < sum .or. stdlib_${c2ri(ci)}$isnan( sum ) ) value = sum end do k = k + n - j + 1 end do @@ -44794,7 +44796,7 @@ module stdlib_linalg_lapack_w do j = 1, n do i = k, k + j - 1 sum = abs( ap( i ) ) - if( value < sum .or. stdlib_qisnan( sum ) ) value = sum + if( value < sum .or. stdlib_${c2ri(ci)}$isnan( sum ) ) value = sum end do k = k + j end do @@ -44802,7 +44804,7 @@ module stdlib_linalg_lapack_w do j = 1, n do i = k, k + n - j sum = abs( ap( i ) ) - if( value < sum .or. stdlib_qisnan( sum ) ) value = sum + if( value < sum .or. stdlib_${c2ri(ci)}$isnan( sum ) ) value = sum end do k = k + n - j + 1 end do @@ -44827,7 +44829,7 @@ module stdlib_linalg_lapack_w end do end if k = k + j - if( value < sum .or. stdlib_qisnan( sum ) ) value = sum + if( value < sum .or. stdlib_${c2ri(ci)}$isnan( sum ) ) value = sum end do else do j = 1, n @@ -44843,7 +44845,7 @@ module stdlib_linalg_lapack_w end do end if k = k + n - j + 1 - if( value < sum .or. stdlib_qisnan( sum ) ) value = sum + if( value < sum .or. stdlib_${c2ri(ci)}$isnan( sum ) ) value = sum end do end if else if( stdlib_lsame( norm, 'I' ) ) then @@ -44899,7 +44901,7 @@ module stdlib_linalg_lapack_w value = zero do i = 1, n sum = work( i ) - if( value < sum .or. stdlib_qisnan( sum ) ) value = sum + if( value < sum .or. stdlib_${c2ri(ci)}$isnan( sum ) ) value = sum end do else if( ( stdlib_lsame( norm, 'F' ) ) .or. ( stdlib_lsame( norm, 'E' ) ) ) & then @@ -44910,7 +44912,7 @@ module stdlib_linalg_lapack_w sum = n k = 2 do j = 2, n - call stdlib_wlassq( j-1, ap( k ), 1, scale, sum ) + call stdlib_${ci}$lassq( j-1, ap( k ), 1, scale, sum ) k = k + j end do else @@ -44918,7 +44920,7 @@ module stdlib_linalg_lapack_w sum = one k = 1 do j = 1, n - call stdlib_wlassq( j, ap( k ), 1, scale, sum ) + call stdlib_${ci}$lassq( j, ap( k ), 1, scale, sum ) k = k + j end do end if @@ -44928,7 +44930,7 @@ module stdlib_linalg_lapack_w sum = n k = 2 do j = 1, n - 1 - call stdlib_wlassq( n-j, ap( k ), 1, scale, sum ) + call stdlib_${ci}$lassq( n-j, ap( k ), 1, scale, sum ) k = k + n - j + 1 end do else @@ -44936,19 +44938,19 @@ module stdlib_linalg_lapack_w sum = one k = 1 do j = 1, n - call stdlib_wlassq( n-j+1, ap( k ), 1, scale, sum ) + call stdlib_${ci}$lassq( n-j+1, ap( k ), 1, scale, sum ) k = k + n - j + 1 end do end if end if value = scale*sqrt( sum ) end if - stdlib_wlantp = value + stdlib_${ci}$lantp = value return - end function stdlib_wlantp + end function stdlib_${ci}$lantp - real(qp) function stdlib_wlantr( norm, uplo, diag, m, n, a, lda,work ) + real(${ck}$) function stdlib_${ci}$lantr( norm, uplo, diag, m, n, a, lda,work ) !! ZLANTR: returns the value of the one norm, or the Frobenius norm, or !! the infinity norm, or the element of largest absolute value of a !! trapezoidal or triangular matrix A. @@ -44959,14 +44961,14 @@ module stdlib_linalg_lapack_w character, intent(in) :: diag, norm, uplo integer(ilp), intent(in) :: lda, m, n ! Array Arguments - real(qp), intent(out) :: work(*) - complex(qp), intent(in) :: a(lda,*) + real(${ck}$), intent(out) :: work(*) + complex(${ck}$), intent(in) :: a(lda,*) ! ===================================================================== ! Local Scalars logical(lk) :: udiag integer(ilp) :: i, j - real(qp) :: scale, sum, value + real(${ck}$) :: scale, sum, value ! Intrinsic Functions intrinsic :: abs,min,sqrt ! Executable Statements @@ -44980,14 +44982,14 @@ module stdlib_linalg_lapack_w do j = 1, n do i = 1, min( m, j-1 ) sum = abs( a( i, j ) ) - if( value < sum .or. stdlib_qisnan( sum ) ) value = sum + if( value < sum .or. stdlib_${c2ri(ci)}$isnan( sum ) ) value = sum end do end do else do j = 1, n do i = j + 1, m sum = abs( a( i, j ) ) - if( value < sum .or. stdlib_qisnan( sum ) ) value = sum + if( value < sum .or. stdlib_${c2ri(ci)}$isnan( sum ) ) value = sum end do end do end if @@ -44997,14 +44999,14 @@ module stdlib_linalg_lapack_w do j = 1, n do i = 1, min( m, j ) sum = abs( a( i, j ) ) - if( value < sum .or. stdlib_qisnan( sum ) ) value = sum + if( value < sum .or. stdlib_${c2ri(ci)}$isnan( sum ) ) value = sum end do end do else do j = 1, n do i = j, m sum = abs( a( i, j ) ) - if( value < sum .or. stdlib_qisnan( sum ) ) value = sum + if( value < sum .or. stdlib_${c2ri(ci)}$isnan( sum ) ) value = sum end do end do end if @@ -45026,7 +45028,7 @@ module stdlib_linalg_lapack_w sum = sum + abs( a( i, j ) ) end do end if - if( value < sum .or. stdlib_qisnan( sum ) ) value = sum + if( value < sum .or. stdlib_${c2ri(ci)}$isnan( sum ) ) value = sum end do else do j = 1, n @@ -45041,7 +45043,7 @@ module stdlib_linalg_lapack_w sum = sum + abs( a( i, j ) ) end do end if - if( value < sum .or. stdlib_qisnan( sum ) ) value = sum + if( value < sum .or. stdlib_${c2ri(ci)}$isnan( sum ) ) value = sum end do end if else if( stdlib_lsame( norm, 'I' ) ) then @@ -45093,7 +45095,7 @@ module stdlib_linalg_lapack_w value = zero do i = 1, m sum = work( i ) - if( value < sum .or. stdlib_qisnan( sum ) ) value = sum + if( value < sum .or. stdlib_${c2ri(ci)}$isnan( sum ) ) value = sum end do else if( ( stdlib_lsame( norm, 'F' ) ) .or. ( stdlib_lsame( norm, 'E' ) ) ) & then @@ -45103,13 +45105,13 @@ module stdlib_linalg_lapack_w scale = one sum = min( m, n ) do j = 2, n - call stdlib_wlassq( min( m, j-1 ), a( 1, j ), 1, scale, sum ) + call stdlib_${ci}$lassq( min( m, j-1 ), a( 1, j ), 1, scale, sum ) end do else scale = zero sum = one do j = 1, n - call stdlib_wlassq( min( m, j ), a( 1, j ), 1, scale, sum ) + call stdlib_${ci}$lassq( min( m, j ), a( 1, j ), 1, scale, sum ) end do end if else @@ -45117,24 +45119,24 @@ module stdlib_linalg_lapack_w scale = one sum = min( m, n ) do j = 1, n - call stdlib_wlassq( m-j, a( min( m, j+1 ), j ), 1, scale,sum ) + call stdlib_${ci}$lassq( m-j, a( min( m, j+1 ), j ), 1, scale,sum ) end do else scale = zero sum = one do j = 1, n - call stdlib_wlassq( m-j+1, a( j, j ), 1, scale, sum ) + call stdlib_${ci}$lassq( m-j+1, a( j, j ), 1, scale, sum ) end do end if end if value = scale*sqrt( sum ) end if - stdlib_wlantr = value + stdlib_${ci}$lantr = value return - end function stdlib_wlantr + end function stdlib_${ci}$lantr - pure subroutine stdlib_wlapll( n, x, incx, y, incy, ssmin ) + pure subroutine stdlib_${ci}$lapll( n, x, incx, y, incy, ssmin ) !! Given two column vectors X and Y, let !! A = ( X Y ). !! The subroutine first computes the QR factorization of A = Q*R, @@ -45146,15 +45148,15 @@ module stdlib_linalg_lapack_w ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments integer(ilp), intent(in) :: incx, incy, n - real(qp), intent(out) :: ssmin + real(${ck}$), intent(out) :: ssmin ! Array Arguments - complex(qp), intent(inout) :: x(*), y(*) + complex(${ck}$), intent(inout) :: x(*), y(*) ! ===================================================================== ! Local Scalars - real(qp) :: ssmax - complex(qp) :: a11, a12, a22, c, tau + real(${ck}$) :: ssmax + complex(${ck}$) :: a11, a12, a22, c, tau ! Intrinsic Functions intrinsic :: abs,conjg ! Executable Statements @@ -45164,21 +45166,21 @@ module stdlib_linalg_lapack_w return end if ! compute the qr factorization of the n-by-2 matrix ( x y ) - call stdlib_wlarfg( n, x( 1 ), x( 1+incx ), incx, tau ) + call stdlib_${ci}$larfg( n, x( 1 ), x( 1+incx ), incx, tau ) a11 = x( 1 ) x( 1 ) = cone - c = -conjg( tau )*stdlib_wdotc( n, x, incx, y, incy ) - call stdlib_waxpy( n, c, x, incx, y, incy ) - call stdlib_wlarfg( n-1, y( 1+incy ), y( 1+2*incy ), incy, tau ) + c = -conjg( tau )*stdlib_${ci}$dotc( n, x, incx, y, incy ) + call stdlib_${ci}$axpy( n, c, x, incx, y, incy ) + call stdlib_${ci}$larfg( n-1, y( 1+incy ), y( 1+2*incy ), incy, tau ) a12 = y( 1 ) a22 = y( 1+incy ) ! compute the svd of 2-by-2 upper triangular matrix. - call stdlib_qlas2( abs( a11 ), abs( a12 ), abs( a22 ), ssmin, ssmax ) + call stdlib_${c2ri(ci)}$las2( abs( a11 ), abs( a12 ), abs( a22 ), ssmin, ssmax ) return - end subroutine stdlib_wlapll + end subroutine stdlib_${ci}$lapll - pure subroutine stdlib_wlapmr( forwrd, m, n, x, ldx, k ) + pure subroutine stdlib_${ci}$lapmr( forwrd, m, n, x, ldx, k ) !! ZLAPMR: rearranges the rows of the M by N matrix X as specified !! by the permutation K(1),K(2),...,K(M) of the integers 1,...,M. !! If FORWRD = .TRUE., forward permutation: @@ -45193,11 +45195,11 @@ module stdlib_linalg_lapack_w integer(ilp), intent(in) :: ldx, m, n ! Array Arguments integer(ilp), intent(inout) :: k(*) - complex(qp), intent(inout) :: x(ldx,*) + complex(${ck}$), intent(inout) :: x(ldx,*) ! ===================================================================== ! Local Scalars integer(ilp) :: i, in, j, jj - complex(qp) :: temp + complex(${ck}$) :: temp ! Executable Statements if( m<=1 )return do i = 1, m @@ -45243,10 +45245,10 @@ module stdlib_linalg_lapack_w end do end if return - end subroutine stdlib_wlapmr + end subroutine stdlib_${ci}$lapmr - pure subroutine stdlib_wlapmt( forwrd, m, n, x, ldx, k ) + pure subroutine stdlib_${ci}$lapmt( forwrd, m, n, x, ldx, k ) !! ZLAPMT: rearranges the columns of the M by N matrix X as specified !! by the permutation K(1),K(2),...,K(N) of the integers 1,...,N. !! If FORWRD = .TRUE., forward permutation: @@ -45261,11 +45263,11 @@ module stdlib_linalg_lapack_w integer(ilp), intent(in) :: ldx, m, n ! Array Arguments integer(ilp), intent(inout) :: k(*) - complex(qp), intent(inout) :: x(ldx,*) + complex(${ck}$), intent(inout) :: x(ldx,*) ! ===================================================================== ! Local Scalars integer(ilp) :: i, ii, in, j - complex(qp) :: temp + complex(${ck}$) :: temp ! Executable Statements if( n<=1 )return do i = 1, n @@ -45311,10 +45313,10 @@ module stdlib_linalg_lapack_w end do end if return - end subroutine stdlib_wlapmt + end subroutine stdlib_${ci}$lapmt - pure subroutine stdlib_wlaqgb( m, n, kl, ku, ab, ldab, r, c, rowcnd, colcnd,amax, equed ) + pure subroutine stdlib_${ci}$laqgb( m, n, kl, ku, ab, ldab, r, c, rowcnd, colcnd,amax, equed ) !! ZLAQGB: equilibrates a general M by N band matrix A with KL !! subdiagonals and KU superdiagonals using the row and scaling factors !! in the vectors R and C. @@ -45325,17 +45327,17 @@ module stdlib_linalg_lapack_w ! Scalar Arguments character, intent(out) :: equed integer(ilp), intent(in) :: kl, ku, ldab, m, n - real(qp), intent(in) :: amax, colcnd, rowcnd + real(${ck}$), intent(in) :: amax, colcnd, rowcnd ! Array Arguments - real(qp), intent(in) :: c(*), r(*) - complex(qp), intent(inout) :: ab(ldab,*) + real(${ck}$), intent(in) :: c(*), r(*) + complex(${ck}$), intent(inout) :: ab(ldab,*) ! ===================================================================== ! Parameters - real(qp), parameter :: thresh = 0.1e+0_qp + real(${ck}$), parameter :: thresh = 0.1e+0_${ck}$ ! Local Scalars integer(ilp) :: i, j - real(qp) :: cj, large, small + real(${ck}$) :: cj, large, small ! Intrinsic Functions intrinsic :: max,min ! Executable Statements @@ -45345,7 +45347,7 @@ module stdlib_linalg_lapack_w return end if ! initialize large and small. - small = stdlib_qlamch( 'SAFE MINIMUM' ) / stdlib_qlamch( 'PRECISION' ) + small = stdlib_${c2ri(ci)}$lamch( 'SAFE MINIMUM' ) / stdlib_${c2ri(ci)}$lamch( 'PRECISION' ) large = one / small if( rowcnd>=thresh .and. amax>=small .and. amax<=large )then ! no row scaling @@ -45381,10 +45383,10 @@ module stdlib_linalg_lapack_w equed = 'B' end if return - end subroutine stdlib_wlaqgb + end subroutine stdlib_${ci}$laqgb - pure subroutine stdlib_wlaqge( m, n, a, lda, r, c, rowcnd, colcnd, amax,equed ) + pure subroutine stdlib_${ci}$laqge( m, n, a, lda, r, c, rowcnd, colcnd, amax,equed ) !! ZLAQGE: equilibrates a general M by N matrix A using the row and !! column scaling factors in the vectors R and C. ! -- lapack auxiliary routine -- @@ -45393,17 +45395,17 @@ module stdlib_linalg_lapack_w ! Scalar Arguments character, intent(out) :: equed integer(ilp), intent(in) :: lda, m, n - real(qp), intent(in) :: amax, colcnd, rowcnd + real(${ck}$), intent(in) :: amax, colcnd, rowcnd ! Array Arguments - real(qp), intent(in) :: c(*), r(*) - complex(qp), intent(inout) :: a(lda,*) + real(${ck}$), intent(in) :: c(*), r(*) + complex(${ck}$), intent(inout) :: a(lda,*) ! ===================================================================== ! Parameters - real(qp), parameter :: thresh = 0.1e+0_qp + real(${ck}$), parameter :: thresh = 0.1e+0_${ck}$ ! Local Scalars integer(ilp) :: i, j - real(qp) :: cj, large, small + real(${ck}$) :: cj, large, small ! Executable Statements ! quick return if possible if( m<=0 .or. n<=0 ) then @@ -45411,7 +45413,7 @@ module stdlib_linalg_lapack_w return end if ! initialize large and small. - small = stdlib_qlamch( 'SAFE MINIMUM' ) / stdlib_qlamch( 'PRECISION' ) + small = stdlib_${c2ri(ci)}$lamch( 'SAFE MINIMUM' ) / stdlib_${c2ri(ci)}$lamch( 'PRECISION' ) large = one / small if( rowcnd>=thresh .and. amax>=small .and. amax<=large )then ! no row scaling @@ -45447,10 +45449,10 @@ module stdlib_linalg_lapack_w equed = 'B' end if return - end subroutine stdlib_wlaqge + end subroutine stdlib_${ci}$laqge - pure subroutine stdlib_wlaqhb( uplo, n, kd, ab, ldab, s, scond, amax, equed ) + pure subroutine stdlib_${ci}$laqhb( uplo, n, kd, ab, ldab, s, scond, amax, equed ) !! ZLAQHB: equilibrates a Hermitian band matrix A !! using the scaling factors in the vector S. ! -- lapack auxiliary routine -- @@ -45460,17 +45462,17 @@ module stdlib_linalg_lapack_w character, intent(out) :: equed character, intent(in) :: uplo integer(ilp), intent(in) :: kd, ldab, n - real(qp), intent(in) :: amax, scond + real(${ck}$), intent(in) :: amax, scond ! Array Arguments - real(qp), intent(out) :: s(*) - complex(qp), intent(inout) :: ab(ldab,*) + real(${ck}$), intent(out) :: s(*) + complex(${ck}$), intent(inout) :: ab(ldab,*) ! ===================================================================== ! Parameters - real(qp), parameter :: thresh = 0.1e+0_qp + real(${ck}$), parameter :: thresh = 0.1e+0_${ck}$ ! Local Scalars integer(ilp) :: i, j - real(qp) :: cj, large, small + real(${ck}$) :: cj, large, small ! Intrinsic Functions intrinsic :: real,max,min ! Executable Statements @@ -45480,7 +45482,7 @@ module stdlib_linalg_lapack_w return end if ! initialize large and small. - small = stdlib_qlamch( 'SAFE MINIMUM' ) / stdlib_qlamch( 'PRECISION' ) + small = stdlib_${c2ri(ci)}$lamch( 'SAFE MINIMUM' ) / stdlib_${c2ri(ci)}$lamch( 'PRECISION' ) large = one / small if( scond>=thresh .and. amax>=small .and. amax<=large ) then ! no equilibration @@ -45494,13 +45496,13 @@ module stdlib_linalg_lapack_w do i = max( 1, j-kd ), j - 1 ab( kd+1+i-j, j ) = cj*s( i )*ab( kd+1+i-j, j ) end do - ab( kd+1, j ) = cj*cj*real( ab( kd+1, j ),KIND=qp) + ab( kd+1, j ) = cj*cj*real( ab( kd+1, j ),KIND=${ck}$) end do else ! lower triangle of a is stored. do j = 1, n cj = s( j ) - ab( 1, j ) = cj*cj*real( ab( 1, j ),KIND=qp) + ab( 1, j ) = cj*cj*real( ab( 1, j ),KIND=${ck}$) do i = j + 1, min( n, j+kd ) ab( 1+i-j, j ) = cj*s( i )*ab( 1+i-j, j ) end do @@ -45509,10 +45511,10 @@ module stdlib_linalg_lapack_w equed = 'Y' end if return - end subroutine stdlib_wlaqhb + end subroutine stdlib_${ci}$laqhb - pure subroutine stdlib_wlaqhe( uplo, n, a, lda, s, scond, amax, equed ) + pure subroutine stdlib_${ci}$laqhe( uplo, n, a, lda, s, scond, amax, equed ) !! ZLAQHE: equilibrates a Hermitian matrix A using the scaling factors !! in the vector S. ! -- lapack auxiliary routine -- @@ -45522,17 +45524,17 @@ module stdlib_linalg_lapack_w character, intent(out) :: equed character, intent(in) :: uplo integer(ilp), intent(in) :: lda, n - real(qp), intent(in) :: amax, scond + real(${ck}$), intent(in) :: amax, scond ! Array Arguments - real(qp), intent(in) :: s(*) - complex(qp), intent(inout) :: a(lda,*) + real(${ck}$), intent(in) :: s(*) + complex(${ck}$), intent(inout) :: a(lda,*) ! ===================================================================== ! Parameters - real(qp), parameter :: thresh = 0.1e+0_qp + real(${ck}$), parameter :: thresh = 0.1e+0_${ck}$ ! Local Scalars integer(ilp) :: i, j - real(qp) :: cj, large, small + real(${ck}$) :: cj, large, small ! Intrinsic Functions intrinsic :: real ! Executable Statements @@ -45542,7 +45544,7 @@ module stdlib_linalg_lapack_w return end if ! initialize large and small. - small = stdlib_qlamch( 'SAFE MINIMUM' ) / stdlib_qlamch( 'PRECISION' ) + small = stdlib_${c2ri(ci)}$lamch( 'SAFE MINIMUM' ) / stdlib_${c2ri(ci)}$lamch( 'PRECISION' ) large = one / small if( scond>=thresh .and. amax>=small .and. amax<=large ) then ! no equilibration @@ -45556,13 +45558,13 @@ module stdlib_linalg_lapack_w do i = 1, j - 1 a( i, j ) = cj*s( i )*a( i, j ) end do - a( j, j ) = cj*cj*real( a( j, j ),KIND=qp) + a( j, j ) = cj*cj*real( a( j, j ),KIND=${ck}$) end do else ! lower triangle of a is stored. do j = 1, n cj = s( j ) - a( j, j ) = cj*cj*real( a( j, j ),KIND=qp) + a( j, j ) = cj*cj*real( a( j, j ),KIND=${ck}$) do i = j + 1, n a( i, j ) = cj*s( i )*a( i, j ) end do @@ -45571,10 +45573,10 @@ module stdlib_linalg_lapack_w equed = 'Y' end if return - end subroutine stdlib_wlaqhe + end subroutine stdlib_${ci}$laqhe - pure subroutine stdlib_wlaqhp( uplo, n, ap, s, scond, amax, equed ) + pure subroutine stdlib_${ci}$laqhp( uplo, n, ap, s, scond, amax, equed ) !! ZLAQHP: equilibrates a Hermitian matrix A using the scaling factors !! in the vector S. ! -- lapack auxiliary routine -- @@ -45584,17 +45586,17 @@ module stdlib_linalg_lapack_w character, intent(out) :: equed character, intent(in) :: uplo integer(ilp), intent(in) :: n - real(qp), intent(in) :: amax, scond + real(${ck}$), intent(in) :: amax, scond ! Array Arguments - real(qp), intent(in) :: s(*) - complex(qp), intent(inout) :: ap(*) + real(${ck}$), intent(in) :: s(*) + complex(${ck}$), intent(inout) :: ap(*) ! ===================================================================== ! Parameters - real(qp), parameter :: thresh = 0.1e+0_qp + real(${ck}$), parameter :: thresh = 0.1e+0_${ck}$ ! Local Scalars integer(ilp) :: i, j, jc - real(qp) :: cj, large, small + real(${ck}$) :: cj, large, small ! Intrinsic Functions intrinsic :: real ! Executable Statements @@ -45604,7 +45606,7 @@ module stdlib_linalg_lapack_w return end if ! initialize large and small. - small = stdlib_qlamch( 'SAFE MINIMUM' ) / stdlib_qlamch( 'PRECISION' ) + small = stdlib_${c2ri(ci)}$lamch( 'SAFE MINIMUM' ) / stdlib_${c2ri(ci)}$lamch( 'PRECISION' ) large = one / small if( scond>=thresh .and. amax>=small .and. amax<=large ) then ! no equilibration @@ -45619,7 +45621,7 @@ module stdlib_linalg_lapack_w do i = 1, j - 1 ap( jc+i-1 ) = cj*s( i )*ap( jc+i-1 ) end do - ap( jc+j-1 ) = cj*cj*real( ap( jc+j-1 ),KIND=qp) + ap( jc+j-1 ) = cj*cj*real( ap( jc+j-1 ),KIND=${ck}$) jc = jc + j end do else @@ -45627,7 +45629,7 @@ module stdlib_linalg_lapack_w jc = 1 do j = 1, n cj = s( j ) - ap( jc ) = cj*cj*real( ap( jc ),KIND=qp) + ap( jc ) = cj*cj*real( ap( jc ),KIND=${ck}$) do i = j + 1, n ap( jc+i-j ) = cj*s( i )*ap( jc+i-j ) end do @@ -45637,10 +45639,10 @@ module stdlib_linalg_lapack_w equed = 'Y' end if return - end subroutine stdlib_wlaqhp + end subroutine stdlib_${ci}$laqhp - pure subroutine stdlib_wlaqp2( m, n, offset, a, lda, jpvt, tau, vn1, vn2,work ) + pure subroutine stdlib_${ci}$laqp2( m, n, offset, a, lda, jpvt, tau, vn1, vn2,work ) !! ZLAQP2: computes a QR factorization with column pivoting of !! the block A(OFFSET+1:M,1:N). !! The block A(1:OFFSET,1:N) is accordingly pivoted, but not factorized. @@ -45651,28 +45653,28 @@ module stdlib_linalg_lapack_w integer(ilp), intent(in) :: lda, m, n, offset ! Array Arguments integer(ilp), intent(inout) :: jpvt(*) - real(qp), intent(inout) :: vn1(*), vn2(*) - complex(qp), intent(inout) :: a(lda,*) - complex(qp), intent(out) :: tau(*), work(*) + real(${ck}$), intent(inout) :: vn1(*), vn2(*) + complex(${ck}$), intent(inout) :: a(lda,*) + complex(${ck}$), intent(out) :: tau(*), work(*) ! ===================================================================== ! Local Scalars integer(ilp) :: i, itemp, j, mn, offpi, pvt - real(qp) :: temp, temp2, tol3z - complex(qp) :: aii + real(${ck}$) :: temp, temp2, tol3z + complex(${ck}$) :: aii ! Intrinsic Functions intrinsic :: abs,conjg,max,min,sqrt ! Executable Statements mn = min( m-offset, n ) - tol3z = sqrt(stdlib_qlamch('EPSILON')) + tol3z = sqrt(stdlib_${c2ri(ci)}$lamch('EPSILON')) ! compute factorization. loop_20: do i = 1, mn offpi = offset + i ! determine ith pivot column and swap if necessary. - pvt = ( i-1 ) + stdlib_iqamax( n-i+1, vn1( i ), 1 ) + pvt = ( i-1 ) + stdlib_i${c2ri(ci)}$amax( n-i+1, vn1( i ), 1 ) if( pvt/=i ) then - call stdlib_wswap( m, a( 1, pvt ), 1, a( 1, i ), 1 ) + call stdlib_${ci}$swap( m, a( 1, pvt ), 1, a( 1, i ), 1 ) itemp = jpvt( pvt ) jpvt( pvt ) = jpvt( i ) jpvt( i ) = itemp @@ -45681,16 +45683,16 @@ module stdlib_linalg_lapack_w end if ! generate elementary reflector h(i). if( offpi1 ) then - call stdlib_wgemv( 'CONJUGATE TRANSPOSE', m-rk+1, k-1, -tau( k ),a( rk, 1 ), lda,& + call stdlib_${ci}$gemv( 'CONJUGATE TRANSPOSE', m-rk+1, k-1, -tau( k ),a( rk, 1 ), lda,& a( rk, k ), 1, czero,auxv( 1 ), 1 ) - call stdlib_wgemv( 'NO TRANSPOSE', n, k-1, cone, f( 1, 1 ), ldf,auxv( 1 ), 1, & + call stdlib_${ci}$gemv( 'NO TRANSPOSE', n, k-1, cone, f( 1, 1 ), ldf,auxv( 1 ), 1, & cone, f( 1, k ), 1 ) end if ! update the current row of a: ! a(rk,k+1:n) := a(rk,k+1:n) - a(rk,1:k)*f(k+1:n,1:k)**h. if( k0 ) then itemp = nint( vn2( lsticc ),KIND=ilp) - vn1( lsticc ) = stdlib_qznrm2( m-rk, a( rk+1, lsticc ), 1 ) + vn1( lsticc ) = stdlib_${c2ri(ci)}$znrm2( m-rk, a( rk+1, lsticc ), 1 ) ! note: the computation of vn1( lsticc ) relies on the fact that ! stdlib_dnrm2 does not fail on vectors with norm below the value of - ! sqrt(stdlib_qlamch('s')) + ! sqrt(stdlib_${c2ri(ci)}$lamch('s')) vn2( lsticc ) = vn1( lsticc ) lsticc = itemp go to 60 end if return - end subroutine stdlib_wlaqps + end subroutine stdlib_${ci}$laqps - pure subroutine stdlib_wlaqr0( wantt, wantz, n, ilo, ihi, h, ldh, w, iloz,ihiz, z, ldz, work,& + pure subroutine stdlib_${ci}$laqr0( wantt, wantz, n, ilo, ihi, h, ldh, w, iloz,ihiz, z, ldz, work,& !! ZLAQR0: computes the eigenvalues of a Hessenberg matrix H !! and, optionally, the matrices T and Z from the Schur decomposition !! H = Z T Z**H, where T is an upper triangular matrix (the @@ -45881,16 +45883,16 @@ module stdlib_linalg_lapack_w integer(ilp), intent(out) :: info logical(lk), intent(in) :: wantt, wantz ! Array Arguments - complex(qp), intent(inout) :: h(ldh,*), z(ldz,*) - complex(qp), intent(out) :: w(*), work(*) + complex(${ck}$), intent(inout) :: h(ldh,*), z(ldz,*) + complex(${ck}$), intent(out) :: w(*), work(*) ! ================================================================ ! Parameters integer(ilp), parameter :: ntiny = 15 integer(ilp), parameter :: kexnw = 5 integer(ilp), parameter :: kexsh = 6 - real(qp), parameter :: wilk1 = 0.75_qp + real(${ck}$), parameter :: wilk1 = 0.75_${ck}$ ! ==== matrices of order ntiny or smaller must be processed by - ! . stdlib_wlahqr because of insufficient subdiagonal scratch space. + ! . stdlib_${ci}$lahqr because of insufficient subdiagonal scratch space. ! . (this is a hard limit.) ==== ! ==== exceptional deflation windows: try to cure rare @@ -45907,21 +45909,21 @@ module stdlib_linalg_lapack_w ! Local Scalars - complex(qp) :: aa, bb, cc, cdum, dd, det, rtdisc, swap, tr2 - real(qp) :: s + complex(${ck}$) :: aa, bb, cc, cdum, dd, det, rtdisc, swap, tr2 + real(${ck}$) :: s integer(ilp) :: i, inf, it, itmax, k, kacc22, kbot, kdu, ks, kt, ktop, ku, kv, kwh, & kwtop, kwv, ld, ls, lwkopt, ndec, ndfl, nh, nho, nibble, nmin, ns, nsmax, nsr, nve, nw,& nwmax, nwr, nwupbd logical(lk) :: sorted character :: jbcmpz*2 ! Local Arrays - complex(qp) :: zdum(1,1) + complex(${ck}$) :: zdum(1,1) ! Intrinsic Functions intrinsic :: abs,real,cmplx,aimag,int,max,min,mod,sqrt ! Statement Functions - real(qp) :: cabs1 + real(${ck}$) :: cabs1 ! Statement Function Definitions - cabs1( cdum ) = abs( real( cdum,KIND=qp) ) + abs( aimag( cdum ) ) + cabs1( cdum ) = abs( real( cdum,KIND=${ck}$) ) + abs( aimag( cdum ) ) ! Executable Statements info = 0 ! ==== quick return for n = 0: nothing to do. ==== @@ -45930,9 +45932,9 @@ module stdlib_linalg_lapack_w return end if if( n<=ntiny ) then - ! ==== tiny matrices must use stdlib_wlahqr. ==== + ! ==== tiny matrices must use stdlib_${ci}$lahqr. ==== lwkopt = 1 - if( lwork/=-1 )call stdlib_wlahqr( wantt, wantz, n, ilo, ihi, h, ldh, w, iloz,ihiz, & + if( lwork/=-1 )call stdlib_${ci}$lahqr( wantt, wantz, n, ilo, ihi, h, ldh, w, iloz,ihiz, & z, ldz, info ) else ! ==== use small bulge multi-shift qr with aggressive early @@ -45966,17 +45968,17 @@ module stdlib_linalg_lapack_w nsr = min( nsr, ( n-3 ) / 6, ihi-ilo ) nsr = max( 2, nsr-mod( nsr, 2 ) ) ! ==== estimate optimal workspace ==== - ! ==== workspace query call to stdlib_wlaqr3 ==== - call stdlib_wlaqr3( wantt, wantz, n, ilo, ihi, nwr+1, h, ldh, iloz,ihiz, z, ldz, ls,& + ! ==== workspace query call to stdlib_${ci}$laqr3 ==== + call stdlib_${ci}$laqr3( wantt, wantz, n, ilo, ihi, nwr+1, h, ldh, iloz,ihiz, z, ldz, ls,& ld, w, h, ldh, n, h, ldh, n, h,ldh, work, -1 ) - ! ==== optimal workspace = max(stdlib_wlaqr5, stdlib_wlaqr3) ==== + ! ==== optimal workspace = max(stdlib_${ci}$laqr5, stdlib_${ci}$laqr3) ==== lwkopt = max( 3*nsr / 2, int( work( 1 ),KIND=ilp) ) ! ==== quick return in case of workspace query. ==== if( lwork==-1 ) then - work( 1 ) = cmplx( lwkopt, 0,KIND=qp) + work( 1 ) = cmplx( lwkopt, 0,KIND=${ck}$) return end if - ! ==== stdlib_wlahqr/stdlib_wlaqr0 crossover point ==== + ! ==== stdlib_${ci}$lahqr/stdlib_${ci}$laqr0 crossover point ==== nmin = stdlib_ilaenv( 12, 'ZLAQR0', jbcmpz, n, ilo, ihi, lwork ) nmin = max( ntiny, nmin ) ! ==== nibble crossover point ==== @@ -46065,7 +46067,7 @@ module stdlib_linalg_lapack_w kwv = nw + 2 nve = ( n-nw ) - kwv + 1 ! ==== aggressive early deflation ==== - call stdlib_wlaqr3( wantt, wantz, n, ktop, kbot, nw, h, ldh, iloz,ihiz, z, ldz, & + call stdlib_${ci}$laqr3( wantt, wantz, n, ktop, kbot, nw, h, ldh, iloz,ihiz, z, ldz, & ls, ld, w, h( kv, 1 ), ldh, nho,h( kv, kt ), ldh, nve, h( kwv, 1 ), ldh, work,& lwork ) ! ==== adjust kbot accounting for new deflations. ==== @@ -46080,7 +46082,7 @@ module stdlib_linalg_lapack_w if( ( ld==0 ) .or. ( ( 100*ld<=nw*nibble ) .and. ( kbot-ktop+1>min( nmin, nwmax )& ) ) ) then ! ==== ns = nominal number of simultaneous shifts. - ! . this may be lowered (slightly) if stdlib_wlaqr3 + ! . this may be lowered (slightly) if stdlib_${ci}$laqr3 ! . did not provide that many shifts. ==== ns = min( nsmax, nsr, max( 2, kbot-ktop ) ) ns = ns - mod( ns, 2 ) @@ -46088,7 +46090,7 @@ module stdlib_linalg_lapack_w ! . in a multiple of kexsh iterations, ! . then try exceptional shifts. ! . otherwise use shifts provided by - ! . stdlib_wlaqr3 above or from the eigenvalues + ! . stdlib_${ci}$laqr3 above or from the eigenvalues ! . of a trailing principal submatrix. ==== if( mod( ndfl, kexsh )==0 ) then ks = kbot - ns + 1 @@ -46097,21 +46099,21 @@ module stdlib_linalg_lapack_w w( i-1 ) = w( i ) end do else - ! ==== got ns/2 or fewer shifts? use stdlib_wlaqr4 or - ! . stdlib_wlahqr on a trailing principal submatrix to + ! ==== got ns/2 or fewer shifts? use stdlib_${ci}$laqr4 or + ! . stdlib_${ci}$lahqr on a trailing principal submatrix to ! . get more. (since ns<=nsmax<=(n-3)/6, ! . there is enough space below the subdiagonal ! . to fit an ns-by-ns scratch array.) ==== if( kbot-ks+1<=ns / 2 ) then ks = kbot - ns + 1 kt = n - ns + 1 - call stdlib_wlacpy( 'A', ns, ns, h( ks, ks ), ldh,h( kt, 1 ), ldh ) + call stdlib_${ci}$lacpy( 'A', ns, ns, h( ks, ks ), ldh,h( kt, 1 ), ldh ) if( ns>nmin ) then - call stdlib_wlaqr4( .false., .false., ns, 1, ns,h( kt, 1 ), ldh, w( & + call stdlib_${ci}$laqr4( .false., .false., ns, 1, ns,h( kt, 1 ), ldh, w( & ks ), 1, 1,zdum, 1, work, lwork, inf ) else - call stdlib_wlahqr( .false., .false., ns, 1, ns,h( kt, 1 ), ldh, w( & + call stdlib_${ci}$lahqr( .false., .false., ns, 1, ns,h( kt, 1 ), ldh, w( & ks ), 1, 1,zdum, 1, inf ) end if ks = ks + inf @@ -46188,7 +46190,7 @@ module stdlib_linalg_lapack_w kwv = kdu + 4 nve = n - kdu - kwv + 1 ! ==== small-bulge multi-shift qr sweep ==== - call stdlib_wlaqr5( wantt, wantz, kacc22, n, ktop, kbot, ns,w( ks ), h, ldh, & + call stdlib_${ci}$laqr5( wantt, wantz, kacc22, n, ktop, kbot, ns,w( ks ), h, ldh, & iloz, ihiz, z, ldz, work,3, h( ku, 1 ), ldh, nve, h( kwv, 1 ), ldh,nho, h( ku,& kwh ), ldh ) end if @@ -46206,11 +46208,11 @@ module stdlib_linalg_lapack_w 80 continue end if ! ==== return the optimal value of lwork. ==== - work( 1 ) = cmplx( lwkopt, 0,KIND=qp) - end subroutine stdlib_wlaqr0 + work( 1 ) = cmplx( lwkopt, 0,KIND=${ck}$) + end subroutine stdlib_${ci}$laqr0 - pure subroutine stdlib_wlaqr1( n, h, ldh, s1, s2, v ) + pure subroutine stdlib_${ci}$laqr1( n, h, ldh, s1, s2, v ) !! Given a 2-by-2 or 3-by-3 matrix H, ZLAQR1: sets v to a !! scalar multiple of the first column of the product !! (*) K = (H - s1*I)*(H - s2*I) @@ -46221,25 +46223,25 @@ module stdlib_linalg_lapack_w ! -- lapack is a software package provided by univ. of tennessee, -- ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments - complex(qp), intent(in) :: s1, s2 + complex(${ck}$), intent(in) :: s1, s2 integer(ilp), intent(in) :: ldh, n ! Array Arguments - complex(qp), intent(in) :: h(ldh,*) - complex(qp), intent(out) :: v(*) + complex(${ck}$), intent(in) :: h(ldh,*) + complex(${ck}$), intent(out) :: v(*) ! ================================================================ ! Parameters - real(qp), parameter :: rzero = 0.0_qp + real(${ck}$), parameter :: rzero = 0.0_${ck}$ ! Local Scalars - complex(qp) :: cdum, h21s, h31s - real(qp) :: s + complex(${ck}$) :: cdum, h21s, h31s + real(${ck}$) :: s ! Intrinsic Functions intrinsic :: abs,real,aimag ! Statement Functions - real(qp) :: cabs1 + real(${ck}$) :: cabs1 ! Statement Function Definitions - cabs1( cdum ) = abs( real( cdum,KIND=qp) ) + abs( aimag( cdum ) ) + cabs1( cdum ) = abs( real( cdum,KIND=${ck}$) ) + abs( aimag( cdum ) ) ! Executable Statements ! quick return if possible if( n/=2 .and. n/=3 ) then @@ -46270,10 +46272,10 @@ module stdlib_linalg_lapack_w v( 3 ) = h31s*( h( 1, 1 )+h( 3, 3 )-s1-s2 ) + h21s*h( 3, 2 ) end if end if - end subroutine stdlib_wlaqr1 + end subroutine stdlib_${ci}$laqr1 - pure subroutine stdlib_wlaqr2( wantt, wantz, n, ktop, kbot, nw, h, ldh, iloz,ihiz, z, ldz, & + pure subroutine stdlib_${ci}$laqr2( wantt, wantz, n, ktop, kbot, nw, h, ldh, iloz,ihiz, z, ldz, & !! ZLAQR2: is identical to ZLAQR3 except that it avoids !! recursion by calling ZLAHQR instead of ZLAQR4. !! Aggressive early deflation: @@ -46295,36 +46297,36 @@ module stdlib_linalg_lapack_w integer(ilp), intent(out) :: nd, ns logical(lk), intent(in) :: wantt, wantz ! Array Arguments - complex(qp), intent(inout) :: h(ldh,*), z(ldz,*) - complex(qp), intent(out) :: sh(*), t(ldt,*), v(ldv,*), work(*), wv(ldwv,*) + complex(${ck}$), intent(inout) :: h(ldh,*), z(ldz,*) + complex(${ck}$), intent(out) :: sh(*), t(ldt,*), v(ldv,*), work(*), wv(ldwv,*) ! ================================================================ ! Parameters - real(qp), parameter :: rzero = 0.0_qp - real(qp), parameter :: rone = 1.0_qp + real(${ck}$), parameter :: rzero = 0.0_${ck}$ + real(${ck}$), parameter :: rone = 1.0_${ck}$ ! Local Scalars - complex(qp) :: beta, cdum, s, tau - real(qp) :: foo, safmax, safmin, smlnum, ulp + complex(${ck}$) :: beta, cdum, s, tau + real(${ck}$) :: foo, safmax, safmin, smlnum, ulp integer(ilp) :: i, ifst, ilst, info, infqr, j, jw, kcol, kln, knt, krow, kwtop, ltop, & lwk1, lwk2, lwkopt ! Intrinsic Functions intrinsic :: abs,real,cmplx,conjg,aimag,int,max,min ! Statement Functions - real(qp) :: cabs1 + real(${ck}$) :: cabs1 ! Statement Function Definitions - cabs1( cdum ) = abs( real( cdum,KIND=qp) ) + abs( aimag( cdum ) ) + cabs1( cdum ) = abs( real( cdum,KIND=${ck}$) ) + abs( aimag( cdum ) ) ! Executable Statements ! ==== estimate optimal workspace. ==== jw = min( nw, kbot-ktop+1 ) if( jw<=2 ) then lwkopt = 1 else - ! ==== workspace query call to stdlib_wgehrd ==== - call stdlib_wgehrd( jw, 1, jw-1, t, ldt, work, work, -1, info ) + ! ==== workspace query call to stdlib_${ci}$gehrd ==== + call stdlib_${ci}$gehrd( jw, 1, jw-1, t, ldt, work, work, -1, info ) lwk1 = int( work( 1 ),KIND=ilp) - ! ==== workspace query call to stdlib_wunmhr ==== - call stdlib_wunmhr( 'R', 'N', jw, jw, 1, jw-1, t, ldt, work, v, ldv,work, -1, info ) + ! ==== workspace query call to stdlib_${ci}$unmhr ==== + call stdlib_${ci}$unmhr( 'R', 'N', jw, jw, 1, jw-1, t, ldt, work, v, ldv,work, -1, info ) lwk2 = int( work( 1 ),KIND=ilp) ! ==== optimal workspace ==== @@ -46332,7 +46334,7 @@ module stdlib_linalg_lapack_w end if ! ==== quick return in case of workspace query. ==== if( lwork==-1 ) then - work( 1 ) = cmplx( lwkopt, 0,KIND=qp) + work( 1 ) = cmplx( lwkopt, 0,KIND=${ck}$) return end if ! ==== nothing to do ... @@ -46344,11 +46346,11 @@ module stdlib_linalg_lapack_w ! ... nor for an empty deflation window. ==== if( nw<1 )return ! ==== machine constants ==== - safmin = stdlib_qlamch( 'SAFE MINIMUM' ) + safmin = stdlib_${c2ri(ci)}$lamch( 'SAFE MINIMUM' ) safmax = rone / safmin - call stdlib_qlabad( safmin, safmax ) - ulp = stdlib_qlamch( 'PRECISION' ) - smlnum = safmin*( real( n,KIND=qp) / ulp ) + call stdlib_${c2ri(ci)}$labad( safmin, safmax ) + ulp = stdlib_${c2ri(ci)}$lamch( 'PRECISION' ) + smlnum = safmin*( real( n,KIND=${ck}$) / ulp ) ! ==== setup deflation window ==== jw = min( nw, kbot-ktop+1 ) kwtop = kbot - jw + 1 @@ -46375,10 +46377,10 @@ module stdlib_linalg_lapack_w ! . aggressive early deflation using that part of ! . the deflation window that converged using infqr ! . here and there to keep track.) ==== - call stdlib_wlacpy( 'U', jw, jw, h( kwtop, kwtop ), ldh, t, ldt ) - call stdlib_wcopy( jw-1, h( kwtop+1, kwtop ), ldh+1, t( 2, 1 ), ldt+1 ) - call stdlib_wlaset( 'A', jw, jw, czero, cone, v, ldv ) - call stdlib_wlahqr( .true., .true., jw, 1, jw, t, ldt, sh( kwtop ), 1,jw, v, ldv, & + call stdlib_${ci}$lacpy( 'U', jw, jw, h( kwtop, kwtop ), ldh, t, ldt ) + call stdlib_${ci}$copy( jw-1, h( kwtop+1, kwtop ), ldh+1, t( 2, 1 ), ldt+1 ) + call stdlib_${ci}$laset( 'A', jw, jw, czero, cone, v, ldv ) + call stdlib_${ci}$lahqr( .true., .true., jw, 1, jw, t, ldt, sh( kwtop ), 1,jw, v, ldv, & infqr ) ! ==== deflation detection loop ==== ns = jw @@ -46392,9 +46394,9 @@ module stdlib_linalg_lapack_w ns = ns - 1 else ! ==== cone undeflatable eigenvalue. move it up out of the - ! . way. (stdlib_wtrexc can not fail in this case.) ==== + ! . way. (stdlib_${ci}$trexc can not fail in this case.) ==== ifst = ns - call stdlib_wtrexc( 'V', jw, t, ldt, v, ldv, ifst, ilst, info ) + call stdlib_${ci}$trexc( 'V', jw, t, ldt, v, ldv, ifst, ilst, info ) ilst = ilst + 1 end if end do @@ -46409,7 +46411,7 @@ module stdlib_linalg_lapack_w if( cabs1( t( j, j ) )>cabs1( t( ifst, ifst ) ) )ifst = j end do ilst = i - if( ifst/=ilst )call stdlib_wtrexc( 'V', jw, t, ldt, v, ldv, ifst, ilst, info ) + if( ifst/=ilst )call stdlib_${ci}$trexc( 'V', jw, t, ldt, v, ldv, ifst, ilst, info ) end do end if @@ -46420,28 +46422,28 @@ module stdlib_linalg_lapack_w if( ns1 .and. s/=czero ) then ! ==== reflect spike back into lower triangle ==== - call stdlib_wcopy( ns, v, ldv, work, 1 ) + call stdlib_${ci}$copy( ns, v, ldv, work, 1 ) do i = 1, ns work( i ) = conjg( work( i ) ) end do beta = work( 1 ) - call stdlib_wlarfg( ns, beta, work( 2 ), 1, tau ) + call stdlib_${ci}$larfg( ns, beta, work( 2 ), 1, tau ) work( 1 ) = cone - call stdlib_wlaset( 'L', jw-2, jw-2, czero, czero, t( 3, 1 ), ldt ) - call stdlib_wlarf( 'L', ns, jw, work, 1, conjg( tau ), t, ldt,work( jw+1 ) ) + call stdlib_${ci}$laset( 'L', jw-2, jw-2, czero, czero, t( 3, 1 ), ldt ) + call stdlib_${ci}$larf( 'L', ns, jw, work, 1, conjg( tau ), t, ldt,work( jw+1 ) ) - call stdlib_wlarf( 'R', ns, ns, work, 1, tau, t, ldt,work( jw+1 ) ) - call stdlib_wlarf( 'R', jw, ns, work, 1, tau, v, ldv,work( jw+1 ) ) - call stdlib_wgehrd( jw, 1, ns, t, ldt, work, work( jw+1 ),lwork-jw, info ) + call stdlib_${ci}$larf( 'R', ns, ns, work, 1, tau, t, ldt,work( jw+1 ) ) + call stdlib_${ci}$larf( 'R', jw, ns, work, 1, tau, v, ldv,work( jw+1 ) ) + call stdlib_${ci}$gehrd( jw, 1, ns, t, ldt, work, work( jw+1 ),lwork-jw, info ) end if ! ==== copy updated reduced window into place ==== if( kwtop>1 )h( kwtop, kwtop-1 ) = s*conjg( v( 1, 1 ) ) - call stdlib_wlacpy( 'U', jw, jw, t, ldt, h( kwtop, kwtop ), ldh ) - call stdlib_wcopy( jw-1, t( 2, 1 ), ldt+1, h( kwtop+1, kwtop ),ldh+1 ) + call stdlib_${ci}$lacpy( 'U', jw, jw, t, ldt, h( kwtop, kwtop ), ldh ) + call stdlib_${ci}$copy( jw-1, t( 2, 1 ), ldt+1, h( kwtop+1, kwtop ),ldh+1 ) ! ==== accumulate orthogonal matrix in order update ! . h and z, if requested. ==== - if( ns>1 .and. s/=czero )call stdlib_wunmhr( 'R', 'N', jw, ns, 1, ns, t, ldt, work, & + if( ns>1 .and. s/=czero )call stdlib_${ci}$unmhr( 'R', 'N', jw, ns, 1, ns, t, ldt, work, & v, ldv,work( jw+1 ), lwork-jw, info ) ! ==== update vertical slab in h ==== if( wantt ) then @@ -46451,26 +46453,26 @@ module stdlib_linalg_lapack_w end if do krow = ltop, kwtop - 1, nv kln = min( nv, kwtop-krow ) - call stdlib_wgemm( 'N', 'N', kln, jw, jw, cone, h( krow, kwtop ),ldh, v, ldv, & + call stdlib_${ci}$gemm( 'N', 'N', kln, jw, jw, cone, h( krow, kwtop ),ldh, v, ldv, & czero, wv, ldwv ) - call stdlib_wlacpy( 'A', kln, jw, wv, ldwv, h( krow, kwtop ), ldh ) + call stdlib_${ci}$lacpy( 'A', kln, jw, wv, ldwv, h( krow, kwtop ), ldh ) end do ! ==== update horizontal slab in h ==== if( wantt ) then do kcol = kbot + 1, n, nh kln = min( nh, n-kcol+1 ) - call stdlib_wgemm( 'C', 'N', jw, kln, jw, cone, v, ldv,h( kwtop, kcol ), ldh, & + call stdlib_${ci}$gemm( 'C', 'N', jw, kln, jw, cone, v, ldv,h( kwtop, kcol ), ldh, & czero, t, ldt ) - call stdlib_wlacpy( 'A', jw, kln, t, ldt, h( kwtop, kcol ),ldh ) + call stdlib_${ci}$lacpy( 'A', jw, kln, t, ldt, h( kwtop, kcol ),ldh ) end do end if ! ==== update vertical slab in z ==== if( wantz ) then do krow = iloz, ihiz, nv kln = min( nv, ihiz-krow+1 ) - call stdlib_wgemm( 'N', 'N', kln, jw, jw, cone, z( krow, kwtop ),ldz, v, ldv, & + call stdlib_${ci}$gemm( 'N', 'N', kln, jw, jw, cone, z( krow, kwtop ),ldz, v, ldv, & czero, wv, ldwv ) - call stdlib_wlacpy( 'A', kln, jw, wv, ldwv, z( krow, kwtop ),ldz ) + call stdlib_${ci}$lacpy( 'A', kln, jw, wv, ldwv, z( krow, kwtop ),ldz ) end do end if end if @@ -46483,11 +46485,11 @@ module stdlib_linalg_lapack_w ! . window.) ==== ns = ns - infqr ! ==== return optimal workspace. ==== - work( 1 ) = cmplx( lwkopt, 0,KIND=qp) - end subroutine stdlib_wlaqr2 + work( 1 ) = cmplx( lwkopt, 0,KIND=${ck}$) + end subroutine stdlib_${ci}$laqr2 - pure subroutine stdlib_wlaqr3( wantt, wantz, n, ktop, kbot, nw, h, ldh, iloz,ihiz, z, ldz, & + pure subroutine stdlib_${ci}$laqr3( wantt, wantz, n, ktop, kbot, nw, h, ldh, iloz,ihiz, z, ldz, & !! Aggressive early deflation: !! ZLAQR3: accepts as input an upper Hessenberg matrix !! H and performs an unitary similarity transformation @@ -46507,40 +46509,40 @@ module stdlib_linalg_lapack_w integer(ilp), intent(out) :: nd, ns logical(lk), intent(in) :: wantt, wantz ! Array Arguments - complex(qp), intent(inout) :: h(ldh,*), z(ldz,*) - complex(qp), intent(out) :: sh(*), t(ldt,*), v(ldv,*), work(*), wv(ldwv,*) + complex(${ck}$), intent(inout) :: h(ldh,*), z(ldz,*) + complex(${ck}$), intent(out) :: sh(*), t(ldt,*), v(ldv,*), work(*), wv(ldwv,*) ! ================================================================ ! Parameters - real(qp), parameter :: rzero = 0.0_qp - real(qp), parameter :: rone = 1.0_qp + real(${ck}$), parameter :: rzero = 0.0_${ck}$ + real(${ck}$), parameter :: rone = 1.0_${ck}$ ! Local Scalars - complex(qp) :: beta, cdum, s, tau - real(qp) :: foo, safmax, safmin, smlnum, ulp + complex(${ck}$) :: beta, cdum, s, tau + real(${ck}$) :: foo, safmax, safmin, smlnum, ulp integer(ilp) :: i, ifst, ilst, info, infqr, j, jw, kcol, kln, knt, krow, kwtop, ltop, & lwk1, lwk2, lwk3, lwkopt, nmin ! Intrinsic Functions intrinsic :: abs,real,cmplx,conjg,aimag,int,max,min ! Statement Functions - real(qp) :: cabs1 + real(${ck}$) :: cabs1 ! Statement Function Definitions - cabs1( cdum ) = abs( real( cdum,KIND=qp) ) + abs( aimag( cdum ) ) + cabs1( cdum ) = abs( real( cdum,KIND=${ck}$) ) + abs( aimag( cdum ) ) ! Executable Statements ! ==== estimate optimal workspace. ==== jw = min( nw, kbot-ktop+1 ) if( jw<=2 ) then lwkopt = 1 else - ! ==== workspace query call to stdlib_wgehrd ==== - call stdlib_wgehrd( jw, 1, jw-1, t, ldt, work, work, -1, info ) + ! ==== workspace query call to stdlib_${ci}$gehrd ==== + call stdlib_${ci}$gehrd( jw, 1, jw-1, t, ldt, work, work, -1, info ) lwk1 = int( work( 1 ),KIND=ilp) - ! ==== workspace query call to stdlib_wunmhr ==== - call stdlib_wunmhr( 'R', 'N', jw, jw, 1, jw-1, t, ldt, work, v, ldv,work, -1, info ) + ! ==== workspace query call to stdlib_${ci}$unmhr ==== + call stdlib_${ci}$unmhr( 'R', 'N', jw, jw, 1, jw-1, t, ldt, work, v, ldv,work, -1, info ) lwk2 = int( work( 1 ),KIND=ilp) - ! ==== workspace query call to stdlib_wlaqr4 ==== - call stdlib_wlaqr4( .true., .true., jw, 1, jw, t, ldt, sh, 1, jw, v,ldv, work, -1, & + ! ==== workspace query call to stdlib_${ci}$laqr4 ==== + call stdlib_${ci}$laqr4( .true., .true., jw, 1, jw, t, ldt, sh, 1, jw, v,ldv, work, -1, & infqr ) lwk3 = int( work( 1 ),KIND=ilp) ! ==== optimal workspace ==== @@ -46548,7 +46550,7 @@ module stdlib_linalg_lapack_w end if ! ==== quick return in case of workspace query. ==== if( lwork==-1 ) then - work( 1 ) = cmplx( lwkopt, 0,KIND=qp) + work( 1 ) = cmplx( lwkopt, 0,KIND=${ck}$) return end if ! ==== nothing to do ... @@ -46560,11 +46562,11 @@ module stdlib_linalg_lapack_w ! ... nor for an empty deflation window. ==== if( nw<1 )return ! ==== machine constants ==== - safmin = stdlib_qlamch( 'SAFE MINIMUM' ) + safmin = stdlib_${c2ri(ci)}$lamch( 'SAFE MINIMUM' ) safmax = rone / safmin - call stdlib_qlabad( safmin, safmax ) - ulp = stdlib_qlamch( 'PRECISION' ) - smlnum = safmin*( real( n,KIND=qp) / ulp ) + call stdlib_${c2ri(ci)}$labad( safmin, safmax ) + ulp = stdlib_${c2ri(ci)}$lamch( 'PRECISION' ) + smlnum = safmin*( real( n,KIND=${ck}$) / ulp ) ! ==== setup deflation window ==== jw = min( nw, kbot-ktop+1 ) kwtop = kbot - jw + 1 @@ -46591,15 +46593,15 @@ module stdlib_linalg_lapack_w ! . aggressive early deflation using that part of ! . the deflation window that converged using infqr ! . here and there to keep track.) ==== - call stdlib_wlacpy( 'U', jw, jw, h( kwtop, kwtop ), ldh, t, ldt ) - call stdlib_wcopy( jw-1, h( kwtop+1, kwtop ), ldh+1, t( 2, 1 ), ldt+1 ) - call stdlib_wlaset( 'A', jw, jw, czero, cone, v, ldv ) + call stdlib_${ci}$lacpy( 'U', jw, jw, h( kwtop, kwtop ), ldh, t, ldt ) + call stdlib_${ci}$copy( jw-1, h( kwtop+1, kwtop ), ldh+1, t( 2, 1 ), ldt+1 ) + call stdlib_${ci}$laset( 'A', jw, jw, czero, cone, v, ldv ) nmin = stdlib_ilaenv( 12, 'ZLAQR3', 'SV', jw, 1, jw, lwork ) if( jw>nmin ) then - call stdlib_wlaqr4( .true., .true., jw, 1, jw, t, ldt, sh( kwtop ), 1,jw, v, ldv, & + call stdlib_${ci}$laqr4( .true., .true., jw, 1, jw, t, ldt, sh( kwtop ), 1,jw, v, ldv, & work, lwork, infqr ) else - call stdlib_wlahqr( .true., .true., jw, 1, jw, t, ldt, sh( kwtop ), 1,jw, v, ldv, & + call stdlib_${ci}$lahqr( .true., .true., jw, 1, jw, t, ldt, sh( kwtop ), 1,jw, v, ldv, & infqr ) end if ! ==== deflation detection loop ==== @@ -46614,9 +46616,9 @@ module stdlib_linalg_lapack_w ns = ns - 1 else ! ==== cone undeflatable eigenvalue. move it up out of the - ! . way. (stdlib_wtrexc can not fail in this case.) ==== + ! . way. (stdlib_${ci}$trexc can not fail in this case.) ==== ifst = ns - call stdlib_wtrexc( 'V', jw, t, ldt, v, ldv, ifst, ilst, info ) + call stdlib_${ci}$trexc( 'V', jw, t, ldt, v, ldv, ifst, ilst, info ) ilst = ilst + 1 end if end do @@ -46631,7 +46633,7 @@ module stdlib_linalg_lapack_w if( cabs1( t( j, j ) )>cabs1( t( ifst, ifst ) ) )ifst = j end do ilst = i - if( ifst/=ilst )call stdlib_wtrexc( 'V', jw, t, ldt, v, ldv, ifst, ilst, info ) + if( ifst/=ilst )call stdlib_${ci}$trexc( 'V', jw, t, ldt, v, ldv, ifst, ilst, info ) end do end if @@ -46642,28 +46644,28 @@ module stdlib_linalg_lapack_w if( ns1 .and. s/=czero ) then ! ==== reflect spike back into lower triangle ==== - call stdlib_wcopy( ns, v, ldv, work, 1 ) + call stdlib_${ci}$copy( ns, v, ldv, work, 1 ) do i = 1, ns work( i ) = conjg( work( i ) ) end do beta = work( 1 ) - call stdlib_wlarfg( ns, beta, work( 2 ), 1, tau ) + call stdlib_${ci}$larfg( ns, beta, work( 2 ), 1, tau ) work( 1 ) = cone - call stdlib_wlaset( 'L', jw-2, jw-2, czero, czero, t( 3, 1 ), ldt ) - call stdlib_wlarf( 'L', ns, jw, work, 1, conjg( tau ), t, ldt,work( jw+1 ) ) + call stdlib_${ci}$laset( 'L', jw-2, jw-2, czero, czero, t( 3, 1 ), ldt ) + call stdlib_${ci}$larf( 'L', ns, jw, work, 1, conjg( tau ), t, ldt,work( jw+1 ) ) - call stdlib_wlarf( 'R', ns, ns, work, 1, tau, t, ldt,work( jw+1 ) ) - call stdlib_wlarf( 'R', jw, ns, work, 1, tau, v, ldv,work( jw+1 ) ) - call stdlib_wgehrd( jw, 1, ns, t, ldt, work, work( jw+1 ),lwork-jw, info ) + call stdlib_${ci}$larf( 'R', ns, ns, work, 1, tau, t, ldt,work( jw+1 ) ) + call stdlib_${ci}$larf( 'R', jw, ns, work, 1, tau, v, ldv,work( jw+1 ) ) + call stdlib_${ci}$gehrd( jw, 1, ns, t, ldt, work, work( jw+1 ),lwork-jw, info ) end if ! ==== copy updated reduced window into place ==== if( kwtop>1 )h( kwtop, kwtop-1 ) = s*conjg( v( 1, 1 ) ) - call stdlib_wlacpy( 'U', jw, jw, t, ldt, h( kwtop, kwtop ), ldh ) - call stdlib_wcopy( jw-1, t( 2, 1 ), ldt+1, h( kwtop+1, kwtop ),ldh+1 ) + call stdlib_${ci}$lacpy( 'U', jw, jw, t, ldt, h( kwtop, kwtop ), ldh ) + call stdlib_${ci}$copy( jw-1, t( 2, 1 ), ldt+1, h( kwtop+1, kwtop ),ldh+1 ) ! ==== accumulate orthogonal matrix in order update ! . h and z, if requested. ==== - if( ns>1 .and. s/=czero )call stdlib_wunmhr( 'R', 'N', jw, ns, 1, ns, t, ldt, work, & + if( ns>1 .and. s/=czero )call stdlib_${ci}$unmhr( 'R', 'N', jw, ns, 1, ns, t, ldt, work, & v, ldv,work( jw+1 ), lwork-jw, info ) ! ==== update vertical slab in h ==== if( wantt ) then @@ -46673,26 +46675,26 @@ module stdlib_linalg_lapack_w end if do krow = ltop, kwtop - 1, nv kln = min( nv, kwtop-krow ) - call stdlib_wgemm( 'N', 'N', kln, jw, jw, cone, h( krow, kwtop ),ldh, v, ldv, & + call stdlib_${ci}$gemm( 'N', 'N', kln, jw, jw, cone, h( krow, kwtop ),ldh, v, ldv, & czero, wv, ldwv ) - call stdlib_wlacpy( 'A', kln, jw, wv, ldwv, h( krow, kwtop ), ldh ) + call stdlib_${ci}$lacpy( 'A', kln, jw, wv, ldwv, h( krow, kwtop ), ldh ) end do ! ==== update horizontal slab in h ==== if( wantt ) then do kcol = kbot + 1, n, nh kln = min( nh, n-kcol+1 ) - call stdlib_wgemm( 'C', 'N', jw, kln, jw, cone, v, ldv,h( kwtop, kcol ), ldh, & + call stdlib_${ci}$gemm( 'C', 'N', jw, kln, jw, cone, v, ldv,h( kwtop, kcol ), ldh, & czero, t, ldt ) - call stdlib_wlacpy( 'A', jw, kln, t, ldt, h( kwtop, kcol ),ldh ) + call stdlib_${ci}$lacpy( 'A', jw, kln, t, ldt, h( kwtop, kcol ),ldh ) end do end if ! ==== update vertical slab in z ==== if( wantz ) then do krow = iloz, ihiz, nv kln = min( nv, ihiz-krow+1 ) - call stdlib_wgemm( 'N', 'N', kln, jw, jw, cone, z( krow, kwtop ),ldz, v, ldv, & + call stdlib_${ci}$gemm( 'N', 'N', kln, jw, jw, cone, z( krow, kwtop ),ldz, v, ldv, & czero, wv, ldwv ) - call stdlib_wlacpy( 'A', kln, jw, wv, ldwv, z( krow, kwtop ),ldz ) + call stdlib_${ci}$lacpy( 'A', kln, jw, wv, ldwv, z( krow, kwtop ),ldz ) end do end if end if @@ -46705,11 +46707,11 @@ module stdlib_linalg_lapack_w ! . window.) ==== ns = ns - infqr ! ==== return optimal workspace. ==== - work( 1 ) = cmplx( lwkopt, 0,KIND=qp) - end subroutine stdlib_wlaqr3 + work( 1 ) = cmplx( lwkopt, 0,KIND=${ck}$) + end subroutine stdlib_${ci}$laqr3 - pure subroutine stdlib_wlaqr4( wantt, wantz, n, ilo, ihi, h, ldh, w, iloz,ihiz, z, ldz, work,& + pure subroutine stdlib_${ci}$laqr4( wantt, wantz, n, ilo, ihi, h, ldh, w, iloz,ihiz, z, ldz, work,& !! ZLAQR4: implements one level of recursion for ZLAQR0. !! It is a complete implementation of the small bulge multi-shift !! QR algorithm. It may be called by ZLAQR0 and, for large enough @@ -46733,16 +46735,16 @@ module stdlib_linalg_lapack_w integer(ilp), intent(out) :: info logical(lk), intent(in) :: wantt, wantz ! Array Arguments - complex(qp), intent(inout) :: h(ldh,*), z(ldz,*) - complex(qp), intent(out) :: w(*), work(*) + complex(${ck}$), intent(inout) :: h(ldh,*), z(ldz,*) + complex(${ck}$), intent(out) :: w(*), work(*) ! ================================================================ ! Parameters integer(ilp), parameter :: ntiny = 15 integer(ilp), parameter :: kexnw = 5 integer(ilp), parameter :: kexsh = 6 - real(qp), parameter :: wilk1 = 0.75_qp + real(${ck}$), parameter :: wilk1 = 0.75_${ck}$ ! ==== matrices of order ntiny or smaller must be processed by - ! . stdlib_wlahqr because of insufficient subdiagonal scratch space. + ! . stdlib_${ci}$lahqr because of insufficient subdiagonal scratch space. ! . (this is a hard limit.) ==== ! ==== exceptional deflation windows: try to cure rare @@ -46759,21 +46761,21 @@ module stdlib_linalg_lapack_w ! Local Scalars - complex(qp) :: aa, bb, cc, cdum, dd, det, rtdisc, swap, tr2 - real(qp) :: s + complex(${ck}$) :: aa, bb, cc, cdum, dd, det, rtdisc, swap, tr2 + real(${ck}$) :: s integer(ilp) :: i, inf, it, itmax, k, kacc22, kbot, kdu, ks, kt, ktop, ku, kv, kwh, & kwtop, kwv, ld, ls, lwkopt, ndec, ndfl, nh, nho, nibble, nmin, ns, nsmax, nsr, nve, nw,& nwmax, nwr, nwupbd logical(lk) :: sorted character :: jbcmpz*2 ! Local Arrays - complex(qp) :: zdum(1,1) + complex(${ck}$) :: zdum(1,1) ! Intrinsic Functions intrinsic :: abs,real,cmplx,aimag,int,max,min,mod,sqrt ! Statement Functions - real(qp) :: cabs1 + real(${ck}$) :: cabs1 ! Statement Function Definitions - cabs1( cdum ) = abs( real( cdum,KIND=qp) ) + abs( aimag( cdum ) ) + cabs1( cdum ) = abs( real( cdum,KIND=${ck}$) ) + abs( aimag( cdum ) ) ! Executable Statements info = 0 ! ==== quick return for n = 0: nothing to do. ==== @@ -46782,9 +46784,9 @@ module stdlib_linalg_lapack_w return end if if( n<=ntiny ) then - ! ==== tiny matrices must use stdlib_wlahqr. ==== + ! ==== tiny matrices must use stdlib_${ci}$lahqr. ==== lwkopt = 1 - if( lwork/=-1 )call stdlib_wlahqr( wantt, wantz, n, ilo, ihi, h, ldh, w, iloz,ihiz, & + if( lwork/=-1 )call stdlib_${ci}$lahqr( wantt, wantz, n, ilo, ihi, h, ldh, w, iloz,ihiz, & z, ldz, info ) else ! ==== use small bulge multi-shift qr with aggressive early @@ -46818,17 +46820,17 @@ module stdlib_linalg_lapack_w nsr = min( nsr, ( n-3 ) / 6, ihi-ilo ) nsr = max( 2, nsr-mod( nsr, 2 ) ) ! ==== estimate optimal workspace ==== - ! ==== workspace query call to stdlib_wlaqr2 ==== - call stdlib_wlaqr2( wantt, wantz, n, ilo, ihi, nwr+1, h, ldh, iloz,ihiz, z, ldz, ls,& + ! ==== workspace query call to stdlib_${ci}$laqr2 ==== + call stdlib_${ci}$laqr2( wantt, wantz, n, ilo, ihi, nwr+1, h, ldh, iloz,ihiz, z, ldz, ls,& ld, w, h, ldh, n, h, ldh, n, h,ldh, work, -1 ) - ! ==== optimal workspace = max(stdlib_wlaqr5, stdlib_wlaqr2) ==== + ! ==== optimal workspace = max(stdlib_${ci}$laqr5, stdlib_${ci}$laqr2) ==== lwkopt = max( 3*nsr / 2, int( work( 1 ),KIND=ilp) ) ! ==== quick return in case of workspace query. ==== if( lwork==-1 ) then - work( 1 ) = cmplx( lwkopt, 0,KIND=qp) + work( 1 ) = cmplx( lwkopt, 0,KIND=${ck}$) return end if - ! ==== stdlib_wlahqr/stdlib_wlaqr0 crossover point ==== + ! ==== stdlib_${ci}$lahqr/stdlib_${ci}$laqr0 crossover point ==== nmin = stdlib_ilaenv( 12, 'ZLAQR4', jbcmpz, n, ilo, ihi, lwork ) nmin = max( ntiny, nmin ) ! ==== nibble crossover point ==== @@ -46917,7 +46919,7 @@ module stdlib_linalg_lapack_w kwv = nw + 2 nve = ( n-nw ) - kwv + 1 ! ==== aggressive early deflation ==== - call stdlib_wlaqr2( wantt, wantz, n, ktop, kbot, nw, h, ldh, iloz,ihiz, z, ldz, & + call stdlib_${ci}$laqr2( wantt, wantz, n, ktop, kbot, nw, h, ldh, iloz,ihiz, z, ldz, & ls, ld, w, h( kv, 1 ), ldh, nho,h( kv, kt ), ldh, nve, h( kwv, 1 ), ldh, work,& lwork ) ! ==== adjust kbot accounting for new deflations. ==== @@ -46932,7 +46934,7 @@ module stdlib_linalg_lapack_w if( ( ld==0 ) .or. ( ( 100*ld<=nw*nibble ) .and. ( kbot-ktop+1>min( nmin, nwmax )& ) ) ) then ! ==== ns = nominal number of simultaneous shifts. - ! . this may be lowered (slightly) if stdlib_wlaqr2 + ! . this may be lowered (slightly) if stdlib_${ci}$laqr2 ! . did not provide that many shifts. ==== ns = min( nsmax, nsr, max( 2, kbot-ktop ) ) ns = ns - mod( ns, 2 ) @@ -46940,7 +46942,7 @@ module stdlib_linalg_lapack_w ! . in a multiple of kexsh iterations, ! . then try exceptional shifts. ! . otherwise use shifts provided by - ! . stdlib_wlaqr2 above or from the eigenvalues + ! . stdlib_${ci}$laqr2 above or from the eigenvalues ! . of a trailing principal submatrix. ==== if( mod( ndfl, kexsh )==0 ) then ks = kbot - ns + 1 @@ -46949,7 +46951,7 @@ module stdlib_linalg_lapack_w w( i-1 ) = w( i ) end do else - ! ==== got ns/2 or fewer shifts? use stdlib_wlahqr + ! ==== got ns/2 or fewer shifts? use stdlib_${ci}$lahqr ! . on a trailing principal submatrix to ! . get more. (since ns<=nsmax<=(n-3)/6, ! . there is enough space below the subdiagonal @@ -46957,9 +46959,9 @@ module stdlib_linalg_lapack_w if( kbot-ks+1<=ns / 2 ) then ks = kbot - ns + 1 kt = n - ns + 1 - call stdlib_wlacpy( 'A', ns, ns, h( ks, ks ), ldh,h( kt, 1 ), ldh ) + call stdlib_${ci}$lacpy( 'A', ns, ns, h( ks, ks ), ldh,h( kt, 1 ), ldh ) - call stdlib_wlahqr( .false., .false., ns, 1, ns,h( kt, 1 ), ldh, w( ks )& + call stdlib_${ci}$lahqr( .false., .false., ns, 1, ns,h( kt, 1 ), ldh, w( ks )& , 1, 1, zdum,1, inf ) ks = ks + inf ! ==== in case of a rare qr failure use @@ -47035,7 +47037,7 @@ module stdlib_linalg_lapack_w kwv = kdu + 4 nve = n - kdu - kwv + 1 ! ==== small-bulge multi-shift qr sweep ==== - call stdlib_wlaqr5( wantt, wantz, kacc22, n, ktop, kbot, ns,w( ks ), h, ldh, & + call stdlib_${ci}$laqr5( wantt, wantz, kacc22, n, ktop, kbot, ns,w( ks ), h, ldh, & iloz, ihiz, z, ldz, work,3, h( ku, 1 ), ldh, nve, h( kwv, 1 ), ldh,nho, h( ku,& kwh ), ldh ) end if @@ -47053,11 +47055,11 @@ module stdlib_linalg_lapack_w 80 continue end if ! ==== return the optimal value of lwork. ==== - work( 1 ) = cmplx( lwkopt, 0,KIND=qp) - end subroutine stdlib_wlaqr4 + work( 1 ) = cmplx( lwkopt, 0,KIND=${ck}$) + end subroutine stdlib_${ci}$laqr4 - pure subroutine stdlib_wlaqr5( wantt, wantz, kacc22, n, ktop, kbot, nshfts, s,h, ldh, iloz, & + pure subroutine stdlib_${ci}$laqr5( wantt, wantz, kacc22, n, ktop, kbot, nshfts, s,h, ldh, iloz, & !! ZLAQR5:, called by ZLAQR0, performs a !! single small-bulge multi-shift QR sweep. ihiz, z, ldz, v, ldv, u, ldu, nv,wv, ldwv, nh, wh, ldwh ) @@ -47069,28 +47071,28 @@ module stdlib_linalg_lapack_w ldz, n, nh, nshfts, nv logical(lk), intent(in) :: wantt, wantz ! Array Arguments - complex(qp), intent(inout) :: h(ldh,*), s(*), z(ldz,*) - complex(qp), intent(out) :: u(ldu,*), v(ldv,*), wh(ldwh,*), wv(ldwv,*) + complex(${ck}$), intent(inout) :: h(ldh,*), s(*), z(ldz,*) + complex(${ck}$), intent(out) :: u(ldu,*), v(ldv,*), wh(ldwh,*), wv(ldwv,*) ! ================================================================ ! Parameters - real(qp), parameter :: rzero = 0.0_qp - real(qp), parameter :: rone = 1.0_qp + real(${ck}$), parameter :: rzero = 0.0_${ck}$ + real(${ck}$), parameter :: rone = 1.0_${ck}$ ! Local Scalars - complex(qp) :: alpha, beta, cdum, refsum - real(qp) :: h11, h12, h21, h22, safmax, safmin, scl, smlnum, tst1, tst2, ulp + complex(${ck}$) :: alpha, beta, cdum, refsum + real(${ck}$) :: h11, h12, h21, h22, safmax, safmin, scl, smlnum, tst1, tst2, ulp integer(ilp) :: i2, i4, incol, j, jbot, jcol, jlen, jrow, jtop, k, k1, kdu, kms, krcol,& m, m22, mbot, mtop, nbmps, ndcol, ns, nu logical(lk) :: accum, bmp22 ! Intrinsic Functions intrinsic :: abs,real,conjg,aimag,max,min,mod ! Local Arrays - complex(qp) :: vt(3) + complex(${ck}$) :: vt(3) ! Statement Functions - real(qp) :: cabs1 + real(${ck}$) :: cabs1 ! Statement Function Definitions - cabs1( cdum ) = abs( real( cdum,KIND=qp) ) + abs( aimag( cdum ) ) + cabs1( cdum ) = abs( real( cdum,KIND=${ck}$) ) + abs( aimag( cdum ) ) ! Executable Statements ! ==== if there are no shifts, then there is nothing to do. ==== if( nshfts<2 )return @@ -47101,11 +47103,11 @@ module stdlib_linalg_lapack_w ! . then simply reduce it by cone. ==== ns = nshfts - mod( nshfts, 2 ) ! ==== machine constants for deflation ==== - safmin = stdlib_qlamch( 'SAFE MINIMUM' ) + safmin = stdlib_${c2ri(ci)}$lamch( 'SAFE MINIMUM' ) safmax = rone / safmin - call stdlib_qlabad( safmin, safmax ) - ulp = stdlib_qlamch( 'PRECISION' ) - smlnum = safmin*( real( n,KIND=qp) / ulp ) + call stdlib_${c2ri(ci)}$labad( safmin, safmax ) + ulp = stdlib_${c2ri(ci)}$lamch( 'PRECISION' ) + smlnum = safmin*( real( n,KIND=${ck}$) / ulp ) ! ==== use accumulated reflections to update far-from-diagonal ! . entries ? ==== accum = ( kacc22==1 ) .or. ( kacc22==2 ) @@ -47126,7 +47128,7 @@ module stdlib_linalg_lapack_w jtop = ktop end if ndcol = incol + kdu - if( accum )call stdlib_wlaset( 'ALL', kdu, kdu, czero, cone, u, ldu ) + if( accum )call stdlib_${ci}$laset( 'ALL', kdu, kdu, czero, cone, u, ldu ) ! ==== near-the-diagonal bulge chase. the following loop ! . performs the near-the-diagonal part of a small bulge ! . multi-shift qr sweep. each 4*nbmps column diagonal @@ -47156,14 +47158,14 @@ module stdlib_linalg_lapack_w ! . separately ==== k = krcol + 2*( m22-1 ) if( k==ktop-1 ) then - call stdlib_wlaqr1( 2, h( k+1, k+1 ), ldh, s( 2*m22-1 ),s( 2*m22 ), v( 1, & + call stdlib_${ci}$laqr1( 2, h( k+1, k+1 ), ldh, s( 2*m22-1 ),s( 2*m22 ), v( 1, & m22 ) ) beta = v( 1, m22 ) - call stdlib_wlarfg( 2, beta, v( 2, m22 ), 1, v( 1, m22 ) ) + call stdlib_${ci}$larfg( 2, beta, v( 2, m22 ), 1, v( 1, m22 ) ) else beta = h( k+1, k ) v( 2, m22 ) = h( k+2, k ) - call stdlib_wlarfg( 2, beta, v( 2, m22 ), 1, v( 1, m22 ) ) + call stdlib_${ci}$larfg( 2, beta, v( 2, m22 ), 1, v( 1, m22 ) ) h( k+1, k ) = beta h( k+2, k ) = czero end if @@ -47242,10 +47244,10 @@ module stdlib_linalg_lapack_w loop_80: do m = mbot, mtop, -1 k = krcol + 2*( m-1 ) if( k==ktop-1 ) then - call stdlib_wlaqr1( 3, h( ktop, ktop ), ldh, s( 2*m-1 ),s( 2*m ), v( 1, m )& + call stdlib_${ci}$laqr1( 3, h( ktop, ktop ), ldh, s( 2*m-1 ),s( 2*m ), v( 1, m )& ) alpha = v( 1, m ) - call stdlib_wlarfg( 3, alpha, v( 2, m ), 1, v( 1, m ) ) + call stdlib_${ci}$larfg( 3, alpha, v( 2, m ), 1, v( 1, m ) ) else ! ==== perform delayed transformation of row below ! . mth bulge. exploit fact that first two elements @@ -47259,7 +47261,7 @@ module stdlib_linalg_lapack_w beta = h( k+1, k ) v( 2, m ) = h( k+2, k ) v( 3, m ) = h( k+3, k ) - call stdlib_wlarfg( 3, beta, v( 2, m ), 1, v( 1, m ) ) + call stdlib_${ci}$larfg( 3, beta, v( 2, m ), 1, v( 1, m ) ) ! ==== a bulge may collapse because of vigilant ! . deflation or destructive underflow. in the ! . underflow case, try the two-small-subdiagonals @@ -47276,10 +47278,10 @@ module stdlib_linalg_lapack_w ! . if the fill resulting from the new ! . reflector is too large, then abandon it. ! . otherwise, use the new cone. ==== - call stdlib_wlaqr1( 3, h( k+1, k+1 ), ldh, s( 2*m-1 ),s( 2*m ), vt ) + call stdlib_${ci}$laqr1( 3, h( k+1, k+1 ), ldh, s( 2*m-1 ),s( 2*m ), vt ) alpha = vt( 1 ) - call stdlib_wlarfg( 3, alpha, vt( 2 ), 1, vt( 1 ) ) + call stdlib_${ci}$larfg( 3, alpha, vt( 2 ), 1, vt( 1 ) ) refsum = conjg( vt( 1 ) )*( h( k+1, k )+conjg( vt( 2 ) )*h( k+2, k ) ) if( cabs1( h( k+2, k )-refsum*vt( 2 ) )+cabs1( refsum*vt( 3 ) )>ulp*( & @@ -47427,35 +47429,35 @@ module stdlib_linalg_lapack_w ! ==== horizontal multiply ==== do jcol = min( ndcol, kbot ) + 1, jbot, nh jlen = min( nh, jbot-jcol+1 ) - call stdlib_wgemm( 'C', 'N', nu, jlen, nu, cone, u( k1, k1 ),ldu, h( incol+k1,& + call stdlib_${ci}$gemm( 'C', 'N', nu, jlen, nu, cone, u( k1, k1 ),ldu, h( incol+k1,& jcol ), ldh, czero, wh,ldwh ) - call stdlib_wlacpy( 'ALL', nu, jlen, wh, ldwh,h( incol+k1, jcol ), ldh ) + call stdlib_${ci}$lacpy( 'ALL', nu, jlen, wh, ldwh,h( incol+k1, jcol ), ldh ) end do ! ==== vertical multiply ==== do jrow = jtop, max( ktop, incol ) - 1, nv jlen = min( nv, max( ktop, incol )-jrow ) - call stdlib_wgemm( 'N', 'N', jlen, nu, nu, cone,h( jrow, incol+k1 ), ldh, u( & + call stdlib_${ci}$gemm( 'N', 'N', jlen, nu, nu, cone,h( jrow, incol+k1 ), ldh, u( & k1, k1 ),ldu, czero, wv, ldwv ) - call stdlib_wlacpy( 'ALL', jlen, nu, wv, ldwv,h( jrow, incol+k1 ), ldh ) + call stdlib_${ci}$lacpy( 'ALL', jlen, nu, wv, ldwv,h( jrow, incol+k1 ), ldh ) end do ! ==== z multiply (also vertical) ==== if( wantz ) then do jrow = iloz, ihiz, nv jlen = min( nv, ihiz-jrow+1 ) - call stdlib_wgemm( 'N', 'N', jlen, nu, nu, cone,z( jrow, incol+k1 ), ldz, & + call stdlib_${ci}$gemm( 'N', 'N', jlen, nu, nu, cone,z( jrow, incol+k1 ), ldz, & u( k1, k1 ),ldu, czero, wv, ldwv ) - call stdlib_wlacpy( 'ALL', jlen, nu, wv, ldwv,z( jrow, incol+k1 ), ldz ) + call stdlib_${ci}$lacpy( 'ALL', jlen, nu, wv, ldwv,z( jrow, incol+k1 ), ldz ) end do end if end if end do loop_180 - end subroutine stdlib_wlaqr5 + end subroutine stdlib_${ci}$laqr5 - pure subroutine stdlib_wlaqsb( uplo, n, kd, ab, ldab, s, scond, amax, equed ) + pure subroutine stdlib_${ci}$laqsb( uplo, n, kd, ab, ldab, s, scond, amax, equed ) !! ZLAQSB: equilibrates a symmetric band matrix A using the scaling !! factors in the vector S. ! -- lapack auxiliary routine -- @@ -47465,17 +47467,17 @@ module stdlib_linalg_lapack_w character, intent(out) :: equed character, intent(in) :: uplo integer(ilp), intent(in) :: kd, ldab, n - real(qp), intent(in) :: amax, scond + real(${ck}$), intent(in) :: amax, scond ! Array Arguments - real(qp), intent(in) :: s(*) - complex(qp), intent(inout) :: ab(ldab,*) + real(${ck}$), intent(in) :: s(*) + complex(${ck}$), intent(inout) :: ab(ldab,*) ! ===================================================================== ! Parameters - real(qp), parameter :: thresh = 0.1e+0_qp + real(${ck}$), parameter :: thresh = 0.1e+0_${ck}$ ! Local Scalars integer(ilp) :: i, j - real(qp) :: cj, large, small + real(${ck}$) :: cj, large, small ! Intrinsic Functions intrinsic :: max,min ! Executable Statements @@ -47485,7 +47487,7 @@ module stdlib_linalg_lapack_w return end if ! initialize large and small. - small = stdlib_qlamch( 'SAFE MINIMUM' ) / stdlib_qlamch( 'PRECISION' ) + small = stdlib_${c2ri(ci)}$lamch( 'SAFE MINIMUM' ) / stdlib_${c2ri(ci)}$lamch( 'PRECISION' ) large = one / small if( scond>=thresh .and. amax>=small .and. amax<=large ) then ! no equilibration @@ -47512,10 +47514,10 @@ module stdlib_linalg_lapack_w equed = 'Y' end if return - end subroutine stdlib_wlaqsb + end subroutine stdlib_${ci}$laqsb - pure subroutine stdlib_wlaqsp( uplo, n, ap, s, scond, amax, equed ) + pure subroutine stdlib_${ci}$laqsp( uplo, n, ap, s, scond, amax, equed ) !! ZLAQSP: equilibrates a symmetric matrix A using the scaling factors !! in the vector S. ! -- lapack auxiliary routine -- @@ -47525,17 +47527,17 @@ module stdlib_linalg_lapack_w character, intent(out) :: equed character, intent(in) :: uplo integer(ilp), intent(in) :: n - real(qp), intent(in) :: amax, scond + real(${ck}$), intent(in) :: amax, scond ! Array Arguments - real(qp), intent(in) :: s(*) - complex(qp), intent(inout) :: ap(*) + real(${ck}$), intent(in) :: s(*) + complex(${ck}$), intent(inout) :: ap(*) ! ===================================================================== ! Parameters - real(qp), parameter :: thresh = 0.1e+0_qp + real(${ck}$), parameter :: thresh = 0.1e+0_${ck}$ ! Local Scalars integer(ilp) :: i, j, jc - real(qp) :: cj, large, small + real(${ck}$) :: cj, large, small ! Executable Statements ! quick return if possible if( n<=0 ) then @@ -47543,7 +47545,7 @@ module stdlib_linalg_lapack_w return end if ! initialize large and small. - small = stdlib_qlamch( 'SAFE MINIMUM' ) / stdlib_qlamch( 'PRECISION' ) + small = stdlib_${c2ri(ci)}$lamch( 'SAFE MINIMUM' ) / stdlib_${c2ri(ci)}$lamch( 'PRECISION' ) large = one / small if( scond>=thresh .and. amax>=small .and. amax<=large ) then ! no equilibration @@ -47574,10 +47576,10 @@ module stdlib_linalg_lapack_w equed = 'Y' end if return - end subroutine stdlib_wlaqsp + end subroutine stdlib_${ci}$laqsp - pure subroutine stdlib_wlaqsy( uplo, n, a, lda, s, scond, amax, equed ) + pure subroutine stdlib_${ci}$laqsy( uplo, n, a, lda, s, scond, amax, equed ) !! ZLAQSY: equilibrates a symmetric matrix A using the scaling factors !! in the vector S. ! -- lapack auxiliary routine -- @@ -47587,17 +47589,17 @@ module stdlib_linalg_lapack_w character, intent(out) :: equed character, intent(in) :: uplo integer(ilp), intent(in) :: lda, n - real(qp), intent(in) :: amax, scond + real(${ck}$), intent(in) :: amax, scond ! Array Arguments - real(qp), intent(in) :: s(*) - complex(qp), intent(inout) :: a(lda,*) + real(${ck}$), intent(in) :: s(*) + complex(${ck}$), intent(inout) :: a(lda,*) ! ===================================================================== ! Parameters - real(qp), parameter :: thresh = 0.1e+0_qp + real(${ck}$), parameter :: thresh = 0.1e+0_${ck}$ ! Local Scalars integer(ilp) :: i, j - real(qp) :: cj, large, small + real(${ck}$) :: cj, large, small ! Executable Statements ! quick return if possible if( n<=0 ) then @@ -47605,7 +47607,7 @@ module stdlib_linalg_lapack_w return end if ! initialize large and small. - small = stdlib_qlamch( 'SAFE MINIMUM' ) / stdlib_qlamch( 'PRECISION' ) + small = stdlib_${c2ri(ci)}$lamch( 'SAFE MINIMUM' ) / stdlib_${c2ri(ci)}$lamch( 'PRECISION' ) large = one / small if( scond>=thresh .and. amax>=small .and. amax<=large ) then ! no equilibration @@ -47632,10 +47634,10 @@ module stdlib_linalg_lapack_w equed = 'Y' end if return - end subroutine stdlib_wlaqsy + end subroutine stdlib_${ci}$laqsy - recursive subroutine stdlib_wlaqz0( wants, wantq, wantz, n, ilo, ihi, a,lda, b, ldb, alpha, & + recursive subroutine stdlib_${ci}$laqz0( wants, wantq, wantz, n, ilo, ihi, a,lda, b, ldb, alpha, & !! ZLAQZ0: computes the eigenvalues of a real matrix pair (H,T), !! where H is an upper Hessenberg matrix and T is upper triangular, !! using the double-shift QZ method. @@ -47681,14 +47683,14 @@ module stdlib_linalg_lapack_w character, intent( in ) :: wants, wantq, wantz integer(ilp), intent( in ) :: n, ilo, ihi, lda, ldb, ldq, ldz, lwork,rec integer(ilp), intent( out ) :: info - complex(qp), intent( inout ) :: a( lda, * ), b( ldb, * ), q( ldq,* ), z( ldz, * ), & + complex(${ck}$), intent( inout ) :: a( lda, * ), b( ldb, * ), q( ldq,* ), z( ldz, * ), & alpha( * ), beta( * ), work( * ) - real(qp), intent( out ) :: rwork( * ) + real(${ck}$), intent( out ) :: rwork( * ) ! local scalars - real(qp) :: smlnum, ulp, safmin, safmax, c1, tempr - complex(qp) :: eshift, s1, temp + real(${ck}$) :: smlnum, ulp, safmin, safmax, c1, tempr + complex(${ck}$) :: eshift, s1, temp integer(ilp) :: istart, istop, iiter, maxit, istart2, k, ld, nshifts, nblock, nw, nmin,& nibble, n_undeflated, n_qeflated, ns, sweep_info, shiftpos, lworkreq, k2, istartm, & istopm, iwants, iwantq, iwantz, norm_info, aed_info, nwr, nbr, nsr, itemp1, itemp2, & @@ -47757,7 +47759,7 @@ module stdlib_linalg_lapack_w end if ! quick return if possible if( n<=0 ) then - work( 1 ) = real( 1,KIND=qp) + work( 1 ) = real( 1,KIND=${ck}$) return end if ! get the parameters @@ -47773,28 +47775,28 @@ module stdlib_linalg_lapack_w nsr = min( nsr, ( n+6 ) / 9, ihi-ilo ) nsr = max( 2, nsr-mod( nsr, 2 ) ) rcost = stdlib_ilaenv( 17, 'ZLAQZ0', jbcmpz, n, ilo, ihi, lwork ) - itemp1 = int( nsr/sqrt( 1+2*nsr/( real( rcost,KIND=qp)/100*n ) ),KIND=ilp) + itemp1 = int( nsr/sqrt( 1+2*nsr/( real( rcost,KIND=${ck}$)/100*n ) ),KIND=ilp) itemp1 = ( ( itemp1-1 )/4 )*4+4 nbr = nsr+itemp1 if( n < nmin .or. rec >= 2 ) then - call stdlib_whgeqz( wants, wantq, wantz, n, ilo, ihi, a, lda, b, ldb,alpha, beta, q,& + call stdlib_${ci}$hgeqz( wants, wantq, wantz, n, ilo, ihi, a, lda, b, ldb,alpha, beta, q,& ldq, z, ldz, work, lwork, rwork,info ) return end if ! find out required workspace - ! workspace query to stdlib_wlaqz2 + ! workspace query to stdlib_${ci}$laqz2 nw = max( nwr, nmin ) - call stdlib_wlaqz2( ilschur, ilq, ilz, n, ilo, ihi, nw, a, lda, b, ldb,q, ldq, z, ldz, & + call stdlib_${ci}$laqz2( ilschur, ilq, ilz, n, ilo, ihi, nw, a, lda, b, ldb,q, ldq, z, ldz, & n_undeflated, n_qeflated, alpha,beta, work, nw, work, nw, work, -1, rwork, rec,& aed_info ) itemp1 = int( work( 1 ),KIND=ilp) - ! workspace query to stdlib_wlaqz3 - call stdlib_wlaqz3( ilschur, ilq, ilz, n, ilo, ihi, nsr, nbr, alpha,beta, a, lda, b, & + ! workspace query to stdlib_${ci}$laqz3 + call stdlib_${ci}$laqz3( ilschur, ilq, ilz, n, ilo, ihi, nsr, nbr, alpha,beta, a, lda, b, & ldb, q, ldq, z, ldz, work, nbr,work, nbr, work, -1, sweep_info ) itemp2 = int( work( 1 ),KIND=ilp) lworkreq = max( itemp1+2*nw**2, itemp2+2*nbr**2 ) if ( lwork ==-1 ) then - work( 1 ) = real( lworkreq,KIND=qp) + work( 1 ) = real( lworkreq,KIND=${ck}$) return else if ( lwork < lworkreq ) then info = -19 @@ -47804,14 +47806,14 @@ module stdlib_linalg_lapack_w return end if ! initialize q and z - if( iwantq==3 ) call stdlib_wlaset( 'FULL', n, n, czero, cone, q,ldq ) - if( iwantz==3 ) call stdlib_wlaset( 'FULL', n, n, czero, cone, z,ldz ) + if( iwantq==3 ) call stdlib_${ci}$laset( 'FULL', n, n, czero, cone, q,ldq ) + if( iwantz==3 ) call stdlib_${ci}$laset( 'FULL', n, n, czero, cone, z,ldz ) ! get machine constants - safmin = stdlib_qlamch( 'SAFE MINIMUM' ) + safmin = stdlib_${c2ri(ci)}$lamch( 'SAFE MINIMUM' ) safmax = one/safmin - call stdlib_qlabad( safmin, safmax ) - ulp = stdlib_qlamch( 'PRECISION' ) - smlnum = safmin*( real( n,KIND=qp)/ulp ) + call stdlib_${c2ri(ci)}$labad( safmin, safmax ) + ulp = stdlib_${c2ri(ci)}$lamch( 'PRECISION' ) + smlnum = safmin*( real( n,KIND=${ck}$)/ulp ) istart = ilo istop = ihi maxit = 30*( ihi-ilo+1 ) @@ -47877,42 +47879,42 @@ module stdlib_linalg_lapack_w ! a diagonal element of b is negligable, move it ! to the top and deflate it do k2 = k, istart2+1, -1 - call stdlib_wlartg( b( k2-1, k2 ), b( k2-1, k2-1 ), c1, s1,temp ) + call stdlib_${ci}$lartg( b( k2-1, k2 ), b( k2-1, k2-1 ), c1, s1,temp ) b( k2-1, k2 ) = temp b( k2-1, k2-1 ) = czero - call stdlib_wrot( k2-2-istartm+1, b( istartm, k2 ), 1,b( istartm, k2-1 ), & + call stdlib_${ci}$rot( k2-2-istartm+1, b( istartm, k2 ), 1,b( istartm, k2-1 ), & 1, c1, s1 ) - call stdlib_wrot( min( k2+1, istop )-istartm+1, a( istartm,k2 ), 1, a( & + call stdlib_${ci}$rot( min( k2+1, istop )-istartm+1, a( istartm,k2 ), 1, a( & istartm, k2-1 ), 1, c1, s1 ) if ( ilz ) then - call stdlib_wrot( n, z( 1, k2 ), 1, z( 1, k2-1 ), 1, c1,s1 ) + call stdlib_${ci}$rot( n, z( 1, k2 ), 1, z( 1, k2-1 ), 1, c1,s1 ) end if if( k2 0 ) then @@ -47963,105 +47965,105 @@ module stdlib_linalg_lapack_w shiftpos = istop-n_qeflated-n_undeflated+1 if ( mod( ld, 6 ) == 0 ) then ! exceptional shift. chosen for no particularly good reason. - if( ( real( maxit,KIND=qp)*safmin )*abs( a( istop,istop-1 ) )= kwtop ) ! move bulge down and remove it do k2 = k, kwbot-1 - call stdlib_wlaqz1( .true., .true., k2, kwtop, kwtop+jw-1,kwbot, a, lda, b, & + call stdlib_${ci}$laqz1( .true., .true., k2, kwtop, kwtop+jw-1,kwbot, a, lda, b, & ldb, jw, kwtop, qc, ldqc,jw, kwtop, zc, ldzc ) end do k = k-1 @@ -48201,44 +48203,44 @@ module stdlib_linalg_lapack_w istopm = ihi end if if ( istopm-ihi > 0 ) then - call stdlib_wgemm( 'C', 'N', jw, istopm-ihi, jw, cone, qc, ldqc,a( kwtop, ihi+1 ), & + call stdlib_${ci}$gemm( 'C', 'N', jw, istopm-ihi, jw, cone, qc, ldqc,a( kwtop, ihi+1 ), & lda, czero, work, jw ) - call stdlib_wlacpy( 'ALL', jw, istopm-ihi, work, jw, a( kwtop,ihi+1 ), lda ) - call stdlib_wgemm( 'C', 'N', jw, istopm-ihi, jw, cone, qc, ldqc,b( kwtop, ihi+1 ), & + call stdlib_${ci}$lacpy( 'ALL', jw, istopm-ihi, work, jw, a( kwtop,ihi+1 ), lda ) + call stdlib_${ci}$gemm( 'C', 'N', jw, istopm-ihi, jw, cone, qc, ldqc,b( kwtop, ihi+1 ), & ldb, czero, work, jw ) - call stdlib_wlacpy( 'ALL', jw, istopm-ihi, work, jw, b( kwtop,ihi+1 ), ldb ) + call stdlib_${ci}$lacpy( 'ALL', jw, istopm-ihi, work, jw, b( kwtop,ihi+1 ), ldb ) end if if ( ilq ) then - call stdlib_wgemm( 'N', 'N', n, jw, jw, cone, q( 1, kwtop ), ldq, qc,ldqc, czero, & + call stdlib_${ci}$gemm( 'N', 'N', n, jw, jw, cone, q( 1, kwtop ), ldq, qc,ldqc, czero, & work, n ) - call stdlib_wlacpy( 'ALL', n, jw, work, n, q( 1, kwtop ), ldq ) + call stdlib_${ci}$lacpy( 'ALL', n, jw, work, n, q( 1, kwtop ), ldq ) end if if ( kwtop-1-istartm+1 > 0 ) then - call stdlib_wgemm( 'N', 'N', kwtop-istartm, jw, jw, cone, a( istartm,kwtop ), lda, & + call stdlib_${ci}$gemm( 'N', 'N', kwtop-istartm, jw, jw, cone, a( istartm,kwtop ), lda, & zc, ldzc, czero, work,kwtop-istartm ) - call stdlib_wlacpy( 'ALL', kwtop-istartm, jw, work, kwtop-istartm,a( istartm, kwtop )& + call stdlib_${ci}$lacpy( 'ALL', kwtop-istartm, jw, work, kwtop-istartm,a( istartm, kwtop )& , lda ) - call stdlib_wgemm( 'N', 'N', kwtop-istartm, jw, jw, cone, b( istartm,kwtop ), ldb, & + call stdlib_${ci}$gemm( 'N', 'N', kwtop-istartm, jw, jw, cone, b( istartm,kwtop ), ldb, & zc, ldzc, czero, work,kwtop-istartm ) - call stdlib_wlacpy( 'ALL', kwtop-istartm, jw, work, kwtop-istartm,b( istartm, kwtop )& + call stdlib_${ci}$lacpy( 'ALL', kwtop-istartm, jw, work, kwtop-istartm,b( istartm, kwtop )& , ldb ) end if if ( ilz ) then - call stdlib_wgemm( 'N', 'N', n, jw, jw, cone, z( 1, kwtop ), ldz, zc,ldzc, czero, & + call stdlib_${ci}$gemm( 'N', 'N', n, jw, jw, cone, z( 1, kwtop ), ldz, zc,ldzc, czero, & work, n ) - call stdlib_wlacpy( 'ALL', n, jw, work, n, z( 1, kwtop ), ldz ) + call stdlib_${ci}$lacpy( 'ALL', n, jw, work, n, z( 1, kwtop ), ldz ) end if - end subroutine stdlib_wlaqz2 + end subroutine stdlib_${ci}$laqz2 - pure subroutine stdlib_wlaqz3( ilschur, ilq, ilz, n, ilo, ihi, nshifts,nblock_qesired, alpha,& + pure subroutine stdlib_${ci}$laqz3( ilschur, ilq, ilz, n, ilo, ihi, nshifts,nblock_qesired, alpha,& !! ZLAQZ3: Executes a single multishift QZ sweep beta, a, lda, b, ldb,q, ldq, z, ldz, qc, ldqc, zc, ldzc, work,lwork, info ) ! function arguments logical(lk), intent( in ) :: ilschur, ilq, ilz integer(ilp), intent( in ) :: n, ilo, ihi, lda, ldb, ldq, ldz, lwork,nshifts, & nblock_qesired, ldqc, ldzc - complex(qp), intent( inout ) :: a( lda, * ), b( ldb, * ), q( ldq,* ), z( ldz, * ), qc( & + complex(${ck}$), intent( inout ) :: a( lda, * ), b( ldb, * ), q( ldq,* ), z( ldz, * ), qc( & ldqc, * ), zc( ldzc, * ), work( * ),alpha( * ), beta( * ) integer(ilp), intent( out ) :: info @@ -48246,8 +48248,8 @@ module stdlib_linalg_lapack_w ! local scalars integer(ilp) :: i, j, ns, istartm, istopm, sheight, swidth, k, np, istartb, istopb, & ishift, nblock, npos - real(qp) :: safmin, safmax, c, scale - complex(qp) :: temp, temp2, temp3, s + real(${ck}$) :: safmin, safmax, c, scale + complex(${ck}$) :: temp, temp2, temp3, s info = 0 if ( nblock_qesired < nshifts+1 ) then info = -8 @@ -48265,9 +48267,9 @@ module stdlib_linalg_lapack_w end if ! executable statements ! get machine constants - safmin = stdlib_qlamch( 'SAFE MINIMUM' ) + safmin = stdlib_${c2ri(ci)}$lamch( 'SAFE MINIMUM' ) safmax = one/safmin - call stdlib_qlabad( safmin, safmax ) + call stdlib_${c2ri(ci)}$labad( safmin, safmax ) if ( ilo >= ihi ) then return end if @@ -48284,8 +48286,8 @@ module stdlib_linalg_lapack_w ! them down one by one just enough to make space for ! the other shifts. the near-the-diagonal block is ! of size (ns+1) x ns. - call stdlib_wlaset( 'FULL', ns+1, ns+1, czero, cone, qc, ldqc ) - call stdlib_wlaset( 'FULL', ns, ns, czero, cone, zc, ldzc ) + call stdlib_${ci}$laset( 'FULL', ns+1, ns+1, czero, cone, qc, ldqc ) + call stdlib_${ci}$laset( 'FULL', ns, ns, czero, cone, zc, ldzc ) do i = 1, ns ! introduce the shift scale = sqrt( abs( alpha( i ) ) ) * sqrt( abs( beta( i ) ) ) @@ -48299,13 +48301,13 @@ module stdlib_linalg_lapack_w temp2 = cone temp3 = czero end if - call stdlib_wlartg( temp2, temp3, c, s, temp ) - call stdlib_wrot( ns, a( ilo, ilo ), lda, a( ilo+1, ilo ), lda, c,s ) - call stdlib_wrot( ns, b( ilo, ilo ), ldb, b( ilo+1, ilo ), ldb, c,s ) - call stdlib_wrot( ns+1, qc( 1, 1 ), 1, qc( 1, 2 ), 1, c,conjg( s ) ) + call stdlib_${ci}$lartg( temp2, temp3, c, s, temp ) + call stdlib_${ci}$rot( ns, a( ilo, ilo ), lda, a( ilo+1, ilo ), lda, c,s ) + call stdlib_${ci}$rot( ns, b( ilo, ilo ), ldb, b( ilo+1, ilo ), ldb, c,s ) + call stdlib_${ci}$rot( ns+1, qc( 1, 1 ), 1, qc( 1, 2 ), 1, c,conjg( s ) ) ! chase the shift down do j = 1, ns-i - call stdlib_wlaqz1( .true., .true., j, 1, ns, ihi-ilo+1, a( ilo,ilo ), lda, b( & + call stdlib_${ci}$laqz1( .true., .true., j, 1, ns, ihi-ilo+1, a( ilo,ilo ), lda, b( & ilo, ilo ), ldb, ns+1, 1, qc,ldqc, ns, 1, zc, ldzc ) end do end do @@ -48315,38 +48317,38 @@ module stdlib_linalg_lapack_w sheight = ns+1 swidth = istopm-( ilo+ns )+1 if ( swidth > 0 ) then - call stdlib_wgemm( 'C', 'N', sheight, swidth, sheight, cone, qc, ldqc,a( ilo, ilo+& + call stdlib_${ci}$gemm( 'C', 'N', sheight, swidth, sheight, cone, qc, ldqc,a( ilo, ilo+& ns ), lda, czero, work, sheight ) - call stdlib_wlacpy( 'ALL', sheight, swidth, work, sheight, a( ilo,ilo+ns ), lda ) + call stdlib_${ci}$lacpy( 'ALL', sheight, swidth, work, sheight, a( ilo,ilo+ns ), lda ) - call stdlib_wgemm( 'C', 'N', sheight, swidth, sheight, cone, qc, ldqc,b( ilo, ilo+& + call stdlib_${ci}$gemm( 'C', 'N', sheight, swidth, sheight, cone, qc, ldqc,b( ilo, ilo+& ns ), ldb, czero, work, sheight ) - call stdlib_wlacpy( 'ALL', sheight, swidth, work, sheight, b( ilo,ilo+ns ), ldb ) + call stdlib_${ci}$lacpy( 'ALL', sheight, swidth, work, sheight, b( ilo,ilo+ns ), ldb ) end if if ( ilq ) then - call stdlib_wgemm( 'N', 'N', n, sheight, sheight, cone, q( 1, ilo ),ldq, qc, ldqc, & + call stdlib_${ci}$gemm( 'N', 'N', n, sheight, sheight, cone, q( 1, ilo ),ldq, qc, ldqc, & czero, work, n ) - call stdlib_wlacpy( 'ALL', n, sheight, work, n, q( 1, ilo ), ldq ) + call stdlib_${ci}$lacpy( 'ALL', n, sheight, work, n, q( 1, ilo ), ldq ) end if ! update a(istartm:ilo-1,ilo:ilo+ns-1) and b(istartm:ilo-1,ilo:ilo+ns-1) ! from the right with zc(1:ns,1:ns) sheight = ilo-1-istartm+1 swidth = ns if ( sheight > 0 ) then - call stdlib_wgemm( 'N', 'N', sheight, swidth, swidth, cone,a( istartm, ilo ), lda, & + call stdlib_${ci}$gemm( 'N', 'N', sheight, swidth, swidth, cone,a( istartm, ilo ), lda, & zc, ldzc, czero, work,sheight ) - call stdlib_wlacpy( 'ALL', sheight, swidth, work, sheight, a( istartm,ilo ), lda ) + call stdlib_${ci}$lacpy( 'ALL', sheight, swidth, work, sheight, a( istartm,ilo ), lda ) - call stdlib_wgemm( 'N', 'N', sheight, swidth, swidth, cone,b( istartm, ilo ), ldb, & + call stdlib_${ci}$gemm( 'N', 'N', sheight, swidth, swidth, cone,b( istartm, ilo ), ldb, & zc, ldzc, czero, work,sheight ) - call stdlib_wlacpy( 'ALL', sheight, swidth, work, sheight, b( istartm,ilo ), ldb ) + call stdlib_${ci}$lacpy( 'ALL', sheight, swidth, work, sheight, b( istartm,ilo ), ldb ) end if if ( ilz ) then - call stdlib_wgemm( 'N', 'N', n, swidth, swidth, cone, z( 1, ilo ),ldz, zc, ldzc, & + call stdlib_${ci}$gemm( 'N', 'N', n, swidth, swidth, cone, z( 1, ilo ),ldz, zc, ldzc, & czero, work, n ) - call stdlib_wlacpy( 'ALL', n, swidth, work, n, z( 1, ilo ), ldz ) + call stdlib_${ci}$lacpy( 'ALL', n, swidth, work, n, z( 1, ilo ), ldz ) end if ! the following block chases the shifts down to the bottom ! right block. if possible, a shift is moved down npos @@ -48360,15 +48362,15 @@ module stdlib_linalg_lapack_w istartb = k+1 ! istopb points to the last column we will be updating istopb = k+nblock-1 - call stdlib_wlaset( 'FULL', ns+np, ns+np, czero, cone, qc, ldqc ) - call stdlib_wlaset( 'FULL', ns+np, ns+np, czero, cone, zc, ldzc ) + call stdlib_${ci}$laset( 'FULL', ns+np, ns+np, czero, cone, qc, ldqc ) + call stdlib_${ci}$laset( 'FULL', ns+np, ns+np, czero, cone, zc, ldzc ) ! near the diagonal shift chase do i = ns-1, 0, -1 do j = 0, np-1 ! move down the block with index k+i+j, updating ! the (ns+np x ns+np) block: ! (k:k+ns+np,k:k+ns+np-1) - call stdlib_wlaqz1( .true., .true., k+i+j, istartb, istopb, ihi,a, lda, b, & + call stdlib_${ci}$laqz1( .true., .true., k+i+j, istartb, istopb, ihi,a, lda, b, & ldb, nblock, k+1, qc, ldqc,nblock, k, zc, ldzc ) end do end do @@ -48379,45 +48381,45 @@ module stdlib_linalg_lapack_w sheight = ns+np swidth = istopm-( k+ns+np )+1 if ( swidth > 0 ) then - call stdlib_wgemm( 'C', 'N', sheight, swidth, sheight, cone, qc,ldqc, a( k+1, k+& + call stdlib_${ci}$gemm( 'C', 'N', sheight, swidth, sheight, cone, qc,ldqc, a( k+1, k+& ns+np ), lda, czero, work,sheight ) - call stdlib_wlacpy( 'ALL', sheight, swidth, work, sheight, a( k+1,k+ns+np ), lda & + call stdlib_${ci}$lacpy( 'ALL', sheight, swidth, work, sheight, a( k+1,k+ns+np ), lda & ) - call stdlib_wgemm( 'C', 'N', sheight, swidth, sheight, cone, qc,ldqc, b( k+1, k+& + call stdlib_${ci}$gemm( 'C', 'N', sheight, swidth, sheight, cone, qc,ldqc, b( k+1, k+& ns+np ), ldb, czero, work,sheight ) - call stdlib_wlacpy( 'ALL', sheight, swidth, work, sheight, b( k+1,k+ns+np ), ldb & + call stdlib_${ci}$lacpy( 'ALL', sheight, swidth, work, sheight, b( k+1,k+ns+np ), ldb & ) end if if ( ilq ) then - call stdlib_wgemm( 'N', 'N', n, nblock, nblock, cone, q( 1, k+1 ),ldq, qc, ldqc, & + call stdlib_${ci}$gemm( 'N', 'N', n, nblock, nblock, cone, q( 1, k+1 ),ldq, qc, ldqc, & czero, work, n ) - call stdlib_wlacpy( 'ALL', n, nblock, work, n, q( 1, k+1 ), ldq ) + call stdlib_${ci}$lacpy( 'ALL', n, nblock, work, n, q( 1, k+1 ), ldq ) end if ! update a(istartm:k,k:k+ns+npos-1) and b(istartm:k,k:k+ns+npos-1) ! from the right with zc(1:ns+np,1:ns+np) sheight = k-istartm+1 swidth = nblock if ( sheight > 0 ) then - call stdlib_wgemm( 'N', 'N', sheight, swidth, swidth, cone,a( istartm, k ), lda, & + call stdlib_${ci}$gemm( 'N', 'N', sheight, swidth, swidth, cone,a( istartm, k ), lda, & zc, ldzc, czero, work,sheight ) - call stdlib_wlacpy( 'ALL', sheight, swidth, work, sheight,a( istartm, k ), lda ) + call stdlib_${ci}$lacpy( 'ALL', sheight, swidth, work, sheight,a( istartm, k ), lda ) - call stdlib_wgemm( 'N', 'N', sheight, swidth, swidth, cone,b( istartm, k ), ldb, & + call stdlib_${ci}$gemm( 'N', 'N', sheight, swidth, swidth, cone,b( istartm, k ), ldb, & zc, ldzc, czero, work,sheight ) - call stdlib_wlacpy( 'ALL', sheight, swidth, work, sheight,b( istartm, k ), ldb ) + call stdlib_${ci}$lacpy( 'ALL', sheight, swidth, work, sheight,b( istartm, k ), ldb ) end if if ( ilz ) then - call stdlib_wgemm( 'N', 'N', n, nblock, nblock, cone, z( 1, k ),ldz, zc, ldzc, & + call stdlib_${ci}$gemm( 'N', 'N', n, nblock, nblock, cone, z( 1, k ),ldz, zc, ldzc, & czero, work, n ) - call stdlib_wlacpy( 'ALL', n, nblock, work, n, z( 1, k ), ldz ) + call stdlib_${ci}$lacpy( 'ALL', n, nblock, work, n, z( 1, k ), ldz ) end if k = k+np end do ! the following block removes the shifts from the bottom right corner ! one by one. updates are initially applied to a(ihi-ns+1:ihi,ihi-ns:ihi). - call stdlib_wlaset( 'FULL', ns, ns, czero, cone, qc, ldqc ) - call stdlib_wlaset( 'FULL', ns+1, ns+1, czero, cone, zc, ldzc ) + call stdlib_${ci}$laset( 'FULL', ns, ns, czero, cone, qc, ldqc ) + call stdlib_${ci}$laset( 'FULL', ns+1, ns+1, czero, cone, zc, ldzc ) ! istartb points to the first row we will be updating istartb = ihi-ns+1 ! istopb points to the last column we will be updating @@ -48425,7 +48427,7 @@ module stdlib_linalg_lapack_w do i = 1, ns ! chase the shift down to the bottom right corner do ishift = ihi-i, ihi-1 - call stdlib_wlaqz1( .true., .true., ishift, istartb, istopb, ihi,a, lda, b, ldb, & + call stdlib_${ci}$laqz1( .true., .true., ishift, istartb, istopb, ihi,a, lda, b, ldb, & ns, ihi-ns+1, qc, ldqc, ns+1,ihi-ns, zc, ldzc ) end do end do @@ -48435,43 +48437,43 @@ module stdlib_linalg_lapack_w sheight = ns swidth = istopm-( ihi+1 )+1 if ( swidth > 0 ) then - call stdlib_wgemm( 'C', 'N', sheight, swidth, sheight, cone, qc, ldqc,a( ihi-ns+1, & + call stdlib_${ci}$gemm( 'C', 'N', sheight, swidth, sheight, cone, qc, ldqc,a( ihi-ns+1, & ihi+1 ), lda, czero, work, sheight ) - call stdlib_wlacpy( 'ALL', sheight, swidth, work, sheight,a( ihi-ns+1, ihi+1 ), lda & + call stdlib_${ci}$lacpy( 'ALL', sheight, swidth, work, sheight,a( ihi-ns+1, ihi+1 ), lda & ) - call stdlib_wgemm( 'C', 'N', sheight, swidth, sheight, cone, qc, ldqc,b( ihi-ns+1, & + call stdlib_${ci}$gemm( 'C', 'N', sheight, swidth, sheight, cone, qc, ldqc,b( ihi-ns+1, & ihi+1 ), ldb, czero, work, sheight ) - call stdlib_wlacpy( 'ALL', sheight, swidth, work, sheight,b( ihi-ns+1, ihi+1 ), ldb & + call stdlib_${ci}$lacpy( 'ALL', sheight, swidth, work, sheight,b( ihi-ns+1, ihi+1 ), ldb & ) end if if ( ilq ) then - call stdlib_wgemm( 'N', 'N', n, ns, ns, cone, q( 1, ihi-ns+1 ), ldq,qc, ldqc, czero,& + call stdlib_${ci}$gemm( 'N', 'N', n, ns, ns, cone, q( 1, ihi-ns+1 ), ldq,qc, ldqc, czero,& work, n ) - call stdlib_wlacpy( 'ALL', n, ns, work, n, q( 1, ihi-ns+1 ), ldq ) + call stdlib_${ci}$lacpy( 'ALL', n, ns, work, n, q( 1, ihi-ns+1 ), ldq ) end if ! update a(istartm:ihi-ns,ihi-ns:ihi) ! from the right with zc(1:ns+1,1:ns+1) sheight = ihi-ns-istartm+1 swidth = ns+1 if ( sheight > 0 ) then - call stdlib_wgemm( 'N', 'N', sheight, swidth, swidth, cone,a( istartm, ihi-ns ), & + call stdlib_${ci}$gemm( 'N', 'N', sheight, swidth, swidth, cone,a( istartm, ihi-ns ), & lda, zc, ldzc, czero, work,sheight ) - call stdlib_wlacpy( 'ALL', sheight, swidth, work, sheight, a( istartm,ihi-ns ), lda & + call stdlib_${ci}$lacpy( 'ALL', sheight, swidth, work, sheight, a( istartm,ihi-ns ), lda & ) - call stdlib_wgemm( 'N', 'N', sheight, swidth, swidth, cone,b( istartm, ihi-ns ), & + call stdlib_${ci}$gemm( 'N', 'N', sheight, swidth, swidth, cone,b( istartm, ihi-ns ), & ldb, zc, ldzc, czero, work,sheight ) - call stdlib_wlacpy( 'ALL', sheight, swidth, work, sheight, b( istartm,ihi-ns ), ldb & + call stdlib_${ci}$lacpy( 'ALL', sheight, swidth, work, sheight, b( istartm,ihi-ns ), ldb & ) end if if ( ilz ) then - call stdlib_wgemm( 'N', 'N', n, ns+1, ns+1, cone, z( 1, ihi-ns ), ldz,zc, ldzc, & + call stdlib_${ci}$gemm( 'N', 'N', n, ns+1, ns+1, cone, z( 1, ihi-ns ), ldz,zc, ldzc, & czero, work, n ) - call stdlib_wlacpy( 'ALL', n, ns+1, work, n, z( 1, ihi-ns ), ldz ) + call stdlib_${ci}$lacpy( 'ALL', n, ns+1, work, n, z( 1, ihi-ns ), ldz ) end if - end subroutine stdlib_wlaqz3 + end subroutine stdlib_${ci}$laqz3 - pure subroutine stdlib_wlar1v( n, b1, bn, lambda, d, l, ld, lld,pivmin, gaptol, z, wantnc, & + pure subroutine stdlib_${ci}$lar1v( n, b1, bn, lambda, d, l, ld, lld,pivmin, gaptol, z, wantnc, & !! ZLAR1V: computes the (scaled) r-th column of the inverse of !! the sumbmatrix in rows B1 through BN of the tridiagonal matrix !! L D L**T - sigma I. When sigma is close to an eigenvalue, the @@ -48496,24 +48498,24 @@ module stdlib_linalg_lapack_w integer(ilp), intent(in) :: b1, bn, n integer(ilp), intent(out) :: negcnt integer(ilp), intent(inout) :: r - real(qp), intent(in) :: gaptol, lambda, pivmin - real(qp), intent(out) :: mingma, nrminv, resid, rqcorr, ztz + real(${ck}$), intent(in) :: gaptol, lambda, pivmin + real(${ck}$), intent(out) :: mingma, nrminv, resid, rqcorr, ztz ! Array Arguments integer(ilp), intent(out) :: isuppz(*) - real(qp), intent(in) :: d(*), l(*), ld(*), lld(*) - real(qp), intent(out) :: work(*) - complex(qp), intent(inout) :: z(*) + real(${ck}$), intent(in) :: d(*), l(*), ld(*), lld(*) + real(${ck}$), intent(out) :: work(*) + complex(${ck}$), intent(inout) :: z(*) ! ===================================================================== ! Local Scalars logical(lk) :: sawnan1, sawnan2 integer(ilp) :: i, indlpl, indp, inds, indumn, neg1, neg2, r1, r2 - real(qp) :: dminus, dplus, eps, s, tmp + real(${ck}$) :: dminus, dplus, eps, s, tmp ! Intrinsic Functions intrinsic :: abs,real ! Executable Statements - eps = stdlib_qlamch( 'PRECISION' ) + eps = stdlib_${c2ri(ci)}$lamch( 'PRECISION' ) if( r==0 ) then r1 = b1 r2 = bn @@ -48544,7 +48546,7 @@ module stdlib_linalg_lapack_w work( inds+i ) = s*work( indlpl+i )*l( i ) s = work( inds+i ) - lambda end do - sawnan1 = stdlib_qisnan( s ) + sawnan1 = stdlib_${c2ri(ci)}$isnan( s ) if( sawnan1 ) goto 60 do i = r1, r2 - 1 dplus = d( i ) + s @@ -48552,7 +48554,7 @@ module stdlib_linalg_lapack_w work( inds+i ) = s*work( indlpl+i )*l( i ) s = work( inds+i ) - lambda end do - sawnan1 = stdlib_qisnan( s ) + sawnan1 = stdlib_${c2ri(ci)}$isnan( s ) 60 continue if( sawnan1 ) then ! runs a slower version of the above loop if a nan is detected @@ -48589,7 +48591,7 @@ module stdlib_linalg_lapack_w work( indp+i-1 ) = work( indp+i )*tmp - lambda end do tmp = work( indp+r1-1 ) - sawnan2 = stdlib_qisnan( tmp ) + sawnan2 = stdlib_${c2ri(ci)}$isnan( tmp ) if( sawnan2 ) then ! runs a slower version of the above loop if a nan is detected neg2 = 0 @@ -48636,7 +48638,7 @@ module stdlib_linalg_lapack_w isuppz( 1 ) = i + 1 goto 220 endif - ztz = ztz + real( z( i )*z( i ),KIND=qp) + ztz = ztz + real( z( i )*z( i ),KIND=${ck}$) end do 220 continue else @@ -48652,7 +48654,7 @@ module stdlib_linalg_lapack_w isuppz( 1 ) = i + 1 go to 240 end if - ztz = ztz + real( z( i )*z( i ),KIND=qp) + ztz = ztz + real( z( i )*z( i ),KIND=${ck}$) end do 240 continue endif @@ -48665,7 +48667,7 @@ module stdlib_linalg_lapack_w isuppz( 2 ) = i go to 260 end if - ztz = ztz + real( z( i+1 )*z( i+1 ),KIND=qp) + ztz = ztz + real( z( i+1 )*z( i+1 ),KIND=${ck}$) end do 260 continue else @@ -48681,7 +48683,7 @@ module stdlib_linalg_lapack_w isuppz( 2 ) = i go to 280 end if - ztz = ztz + real( z( i+1 )*z( i+1 ),KIND=qp) + ztz = ztz + real( z( i+1 )*z( i+1 ),KIND=${ck}$) end do 280 continue end if @@ -48691,10 +48693,10 @@ module stdlib_linalg_lapack_w resid = abs( mingma )*nrminv rqcorr = mingma*tmp return - end subroutine stdlib_wlar1v + end subroutine stdlib_${ci}$lar1v - pure subroutine stdlib_wlar2v( n, x, y, z, incx, c, s, incc ) + pure subroutine stdlib_${ci}$lar2v( n, x, y, z, incx, c, s, incc ) !! ZLAR2V: applies a vector of complex plane rotations with real cosines !! from both sides to a sequence of 2-by-2 complex Hermitian matrices, !! defined by the elements of the vectors x, y and z. For i = 1,2,...,n @@ -48708,28 +48710,28 @@ module stdlib_linalg_lapack_w ! Scalar Arguments integer(ilp), intent(in) :: incc, incx, n ! Array Arguments - real(qp), intent(in) :: c(*) - complex(qp), intent(in) :: s(*) - complex(qp), intent(inout) :: x(*), y(*), z(*) + real(${ck}$), intent(in) :: c(*) + complex(${ck}$), intent(in) :: s(*) + complex(${ck}$), intent(inout) :: x(*), y(*), z(*) ! ===================================================================== ! Local Scalars integer(ilp) :: i, ic, ix - real(qp) :: ci, sii, sir, t1i, t1r, t5, t6, xi, yi, zii, zir - complex(qp) :: si, t2, t3, t4, zi + real(${ck}$) :: ci, sii, sir, t1i, t1r, t5, t6, xi, yi, zii, zir + complex(${ck}$) :: si, t2, t3, t4, zi ! Intrinsic Functions intrinsic :: real,cmplx,conjg,aimag ! Executable Statements ix = 1 ic = 1 do i = 1, n - xi = real( x( ix ),KIND=qp) - yi = real( y( ix ),KIND=qp) + xi = real( x( ix ),KIND=${ck}$) + yi = real( y( ix ),KIND=${ck}$) zi = z( ix ) - zir = real( zi,KIND=qp) + zir = real( zi,KIND=${ck}$) zii = aimag( zi ) ci = c( ic ) si = s( ic ) - sir = real( si,KIND=qp) + sir = real( si,KIND=${ck}$) sii = aimag( si ) t1r = sir*zir - sii*zii t1i = sir*zii + sii*zir @@ -48738,17 +48740,17 @@ module stdlib_linalg_lapack_w t4 = conjg( t2 ) + si*yi t5 = ci*xi + t1r t6 = ci*yi - t1r - x( ix ) = ci*t5 + ( sir*real( t4,KIND=qp)+sii*aimag( t4 ) ) - y( ix ) = ci*t6 - ( sir*real( t3,KIND=qp)-sii*aimag( t3 ) ) - z( ix ) = ci*t3 + conjg( si )*cmplx( t6, t1i,KIND=qp) + x( ix ) = ci*t5 + ( sir*real( t4,KIND=${ck}$)+sii*aimag( t4 ) ) + y( ix ) = ci*t6 - ( sir*real( t3,KIND=${ck}$)-sii*aimag( t3 ) ) + z( ix ) = ci*t3 + conjg( si )*cmplx( t6, t1i,KIND=${ck}$) ix = ix + incx ic = ic + incc end do return - end subroutine stdlib_wlar2v + end subroutine stdlib_${ci}$lar2v - pure subroutine stdlib_wlarcm( m, n, a, lda, b, ldb, c, ldc, rwork ) + pure subroutine stdlib_${ci}$larcm( m, n, a, lda, b, ldb, c, ldc, rwork ) !! ZLARCM: performs a very simple matrix-matrix multiplication: !! C := A * B, !! where A is M by M and real; B is M by N and complex; @@ -48759,10 +48761,10 @@ module stdlib_linalg_lapack_w ! Scalar Arguments integer(ilp), intent(in) :: lda, ldb, ldc, m, n ! Array Arguments - real(qp), intent(in) :: a(lda,*) - real(qp), intent(out) :: rwork(*) - complex(qp), intent(in) :: b(ldb,*) - complex(qp), intent(out) :: c(ldc,*) + real(${ck}$), intent(in) :: a(lda,*) + real(${ck}$), intent(out) :: rwork(*) + complex(${ck}$), intent(in) :: b(ldb,*) + complex(${ck}$), intent(out) :: c(ldc,*) ! ===================================================================== ! Local Scalars @@ -48774,11 +48776,11 @@ module stdlib_linalg_lapack_w if( ( m==0 ) .or. ( n==0 ) )return do j = 1, n do i = 1, m - rwork( ( j-1 )*m+i ) = real( b( i, j ),KIND=qp) + rwork( ( j-1 )*m+i ) = real( b( i, j ),KIND=${ck}$) end do end do l = m*n + 1 - call stdlib_qgemm( 'N', 'N', m, n, m, one, a, lda, rwork, m, zero,rwork( l ), m ) + call stdlib_${c2ri(ci)}$gemm( 'N', 'N', m, n, m, one, a, lda, rwork, m, zero,rwork( l ), m ) do j = 1, n do i = 1, m @@ -48790,19 +48792,19 @@ module stdlib_linalg_lapack_w rwork( ( j-1 )*m+i ) = aimag( b( i, j ) ) end do end do - call stdlib_qgemm( 'N', 'N', m, n, m, one, a, lda, rwork, m, zero,rwork( l ), m ) + call stdlib_${c2ri(ci)}$gemm( 'N', 'N', m, n, m, one, a, lda, rwork, m, zero,rwork( l ), m ) do j = 1, n do i = 1, m - c( i, j ) = cmplx( real( c( i, j ),KIND=qp),rwork( l+( j-1 )*m+i-1 ),KIND=qp) + c( i, j ) = cmplx( real( c( i, j ),KIND=${ck}$),rwork( l+( j-1 )*m+i-1 ),KIND=${ck}$) end do end do return - end subroutine stdlib_wlarcm + end subroutine stdlib_${ci}$larcm - pure subroutine stdlib_wlarf( side, m, n, v, incv, tau, c, ldc, work ) + pure subroutine stdlib_${ci}$larf( side, m, n, v, incv, tau, c, ldc, work ) !! ZLARF: applies a complex elementary reflector H to a complex M-by-N !! matrix C, from either the left or the right. H is represented in the !! form @@ -48817,11 +48819,11 @@ module stdlib_linalg_lapack_w ! Scalar Arguments character, intent(in) :: side integer(ilp), intent(in) :: incv, ldc, m, n - complex(qp), intent(in) :: tau + complex(${ck}$), intent(in) :: tau ! Array Arguments - complex(qp), intent(inout) :: c(ldc,*) - complex(qp), intent(in) :: v(*) - complex(qp), intent(out) :: work(*) + complex(${ck}$), intent(inout) :: c(ldc,*) + complex(${ck}$), intent(in) :: v(*) + complex(${ck}$), intent(out) :: work(*) ! ===================================================================== ! Local Scalars @@ -48851,38 +48853,38 @@ module stdlib_linalg_lapack_w end do if( applyleft ) then ! scan for the last non-czero column in c(1:lastv,:). - lastc = stdlib_ilawlc(lastv, n, c, ldc) + lastc = stdlib_ila${ci}$lc(lastv, n, c, ldc) else ! scan for the last non-czero row in c(:,1:lastv). - lastc = stdlib_ilawlr(m, lastv, c, ldc) + lastc = stdlib_ila${ci}$lr(m, lastv, c, ldc) end if end if - ! note that lastc.eq.0_qp renders the blas operations null; no special + ! note that lastc.eq.0_${ck}$ renders the blas operations null; no special ! case is needed at this level. if( applyleft ) then ! form h * c if( lastv>0 ) then ! w(1:lastc,1) := c(1:lastv,1:lastc)**h * v(1:lastv,1) - call stdlib_wgemv( 'CONJUGATE TRANSPOSE', lastv, lastc, cone,c, ldc, v, incv, & + call stdlib_${ci}$gemv( 'CONJUGATE TRANSPOSE', lastv, lastc, cone,c, ldc, v, incv, & czero, work, 1 ) ! c(1:lastv,1:lastc) := c(...) - v(1:lastv,1) * w(1:lastc,1)**h - call stdlib_wgerc( lastv, lastc, -tau, v, incv, work, 1, c, ldc ) + call stdlib_${ci}$gerc( lastv, lastc, -tau, v, incv, work, 1, c, ldc ) end if else ! form c * h if( lastv>0 ) then ! w(1:lastc,1) := c(1:lastc,1:lastv) * v(1:lastv,1) - call stdlib_wgemv( 'NO TRANSPOSE', lastc, lastv, cone, c, ldc,v, incv, czero, & + call stdlib_${ci}$gemv( 'NO TRANSPOSE', lastc, lastv, cone, c, ldc,v, incv, czero, & work, 1 ) ! c(1:lastc,1:lastv) := c(...) - w(1:lastc,1) * v(1:lastv,1)**h - call stdlib_wgerc( lastc, lastv, -tau, work, 1, v, incv, c, ldc ) + call stdlib_${ci}$gerc( lastc, lastv, -tau, work, 1, v, incv, c, ldc ) end if end if return - end subroutine stdlib_wlarf + end subroutine stdlib_${ci}$larf - pure subroutine stdlib_wlarfb( side, trans, direct, storev, m, n, k, v, ldv,t, ldt, c, ldc, & + pure subroutine stdlib_${ci}$larfb( side, trans, direct, storev, m, n, k, v, ldv,t, ldt, c, ldc, & !! ZLARFB: applies a complex block reflector H or its transpose H**H to a !! complex M-by-N matrix C, from either the left or the right. work, ldwork ) @@ -48893,9 +48895,9 @@ module stdlib_linalg_lapack_w character, intent(in) :: direct, side, storev, trans integer(ilp), intent(in) :: k, ldc, ldt, ldv, ldwork, m, n ! Array Arguments - complex(qp), intent(inout) :: c(ldc,*) - complex(qp), intent(in) :: t(ldt,*), v(ldv,*) - complex(qp), intent(out) :: work(ldwork,*) + complex(${ck}$), intent(inout) :: c(ldc,*) + complex(${ck}$), intent(in) :: t(ldt,*), v(ldv,*) + complex(${ck}$), intent(out) :: work(ldwork,*) ! ===================================================================== ! Local Scalars @@ -48922,28 +48924,28 @@ module stdlib_linalg_lapack_w ! w := c**h * v = (c1**h * v1 + c2**h * v2) (stored in work) ! w := c1**h do j = 1, k - call stdlib_wcopy( n, c( j, 1 ), ldc, work( 1, j ), 1 ) - call stdlib_wlacgv( n, work( 1, j ), 1 ) + call stdlib_${ci}$copy( n, c( j, 1 ), ldc, work( 1, j ), 1 ) + call stdlib_${ci}$lacgv( n, work( 1, j ), 1 ) end do ! w := w * v1 - call stdlib_wtrmm( 'RIGHT', 'LOWER', 'NO TRANSPOSE', 'UNIT', n,k, cone, v, & + call stdlib_${ci}$trmm( 'RIGHT', 'LOWER', 'NO TRANSPOSE', 'UNIT', n,k, cone, v, & ldv, work, ldwork ) if( m>k ) then ! w := w + c2**h * v2 - call stdlib_wgemm( 'CONJUGATE TRANSPOSE', 'NO TRANSPOSE', n,k, m-k, cone, & + call stdlib_${ci}$gemm( 'CONJUGATE TRANSPOSE', 'NO TRANSPOSE', n,k, m-k, cone, & c( k+1, 1 ), ldc,v( k+1, 1 ), ldv, cone, work, ldwork ) end if ! w := w * t**h or w * t - call stdlib_wtrmm( 'RIGHT', 'UPPER', transt, 'NON-UNIT', n, k,cone, t, ldt, & + call stdlib_${ci}$trmm( 'RIGHT', 'UPPER', transt, 'NON-UNIT', n, k,cone, t, ldt, & work, ldwork ) ! c := c - v * w**h if( m>k ) then ! c2 := c2 - v2 * w**h - call stdlib_wgemm( 'NO TRANSPOSE', 'CONJUGATE TRANSPOSE',m-k, n, k, -cone, & + call stdlib_${ci}$gemm( 'NO TRANSPOSE', 'CONJUGATE TRANSPOSE',m-k, n, k, -cone, & v( k+1, 1 ), ldv, work,ldwork, cone, c( k+1, 1 ), ldc ) end if ! w := w * v1**h - call stdlib_wtrmm( 'RIGHT', 'LOWER', 'CONJUGATE TRANSPOSE','UNIT', n, k, cone,& + call stdlib_${ci}$trmm( 'RIGHT', 'LOWER', 'CONJUGATE TRANSPOSE','UNIT', n, k, cone,& v, ldv, work, ldwork ) ! c1 := c1 - w**h do j = 1, k @@ -48956,27 +48958,27 @@ module stdlib_linalg_lapack_w ! w := c * v = (c1*v1 + c2*v2) (stored in work) ! w := c1 do j = 1, k - call stdlib_wcopy( m, c( 1, j ), 1, work( 1, j ), 1 ) + call stdlib_${ci}$copy( m, c( 1, j ), 1, work( 1, j ), 1 ) end do ! w := w * v1 - call stdlib_wtrmm( 'RIGHT', 'LOWER', 'NO TRANSPOSE', 'UNIT', m,k, cone, v, & + call stdlib_${ci}$trmm( 'RIGHT', 'LOWER', 'NO TRANSPOSE', 'UNIT', m,k, cone, v, & ldv, work, ldwork ) if( n>k ) then ! w := w + c2 * v2 - call stdlib_wgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', m, k, n-k,cone, c( 1, k+& + call stdlib_${ci}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', m, k, n-k,cone, c( 1, k+& 1 ), ldc, v( k+1, 1 ), ldv,cone, work, ldwork ) end if ! w := w * t or w * t**h - call stdlib_wtrmm( 'RIGHT', 'UPPER', trans, 'NON-UNIT', m, k,cone, t, ldt, & + call stdlib_${ci}$trmm( 'RIGHT', 'UPPER', trans, 'NON-UNIT', m, k,cone, t, ldt, & work, ldwork ) ! c := c - w * v**h if( n>k ) then ! c2 := c2 - w * v2**h - call stdlib_wgemm( 'NO TRANSPOSE', 'CONJUGATE TRANSPOSE', m,n-k, k, -cone, & + call stdlib_${ci}$gemm( 'NO TRANSPOSE', 'CONJUGATE TRANSPOSE', m,n-k, k, -cone, & work, ldwork, v( k+1, 1 ),ldv, cone, c( 1, k+1 ), ldc ) end if ! w := w * v1**h - call stdlib_wtrmm( 'RIGHT', 'LOWER', 'CONJUGATE TRANSPOSE','UNIT', m, k, cone,& + call stdlib_${ci}$trmm( 'RIGHT', 'LOWER', 'CONJUGATE TRANSPOSE','UNIT', m, k, cone,& v, ldv, work, ldwork ) ! c1 := c1 - w do j = 1, k @@ -48995,28 +48997,28 @@ module stdlib_linalg_lapack_w ! w := c**h * v = (c1**h * v1 + c2**h * v2) (stored in work) ! w := c2**h do j = 1, k - call stdlib_wcopy( n, c( m-k+j, 1 ), ldc, work( 1, j ), 1 ) - call stdlib_wlacgv( n, work( 1, j ), 1 ) + call stdlib_${ci}$copy( n, c( m-k+j, 1 ), ldc, work( 1, j ), 1 ) + call stdlib_${ci}$lacgv( n, work( 1, j ), 1 ) end do ! w := w * v2 - call stdlib_wtrmm( 'RIGHT', 'UPPER', 'NO TRANSPOSE', 'UNIT', n,k, cone, v( m-& + call stdlib_${ci}$trmm( 'RIGHT', 'UPPER', 'NO TRANSPOSE', 'UNIT', n,k, cone, v( m-& k+1, 1 ), ldv, work, ldwork ) if( m>k ) then ! w := w + c1**h * v1 - call stdlib_wgemm( 'CONJUGATE TRANSPOSE', 'NO TRANSPOSE', n,k, m-k, cone, & + call stdlib_${ci}$gemm( 'CONJUGATE TRANSPOSE', 'NO TRANSPOSE', n,k, m-k, cone, & c, ldc, v, ldv, cone, work,ldwork ) end if ! w := w * t**h or w * t - call stdlib_wtrmm( 'RIGHT', 'LOWER', transt, 'NON-UNIT', n, k,cone, t, ldt, & + call stdlib_${ci}$trmm( 'RIGHT', 'LOWER', transt, 'NON-UNIT', n, k,cone, t, ldt, & work, ldwork ) ! c := c - v * w**h if( m>k ) then ! c1 := c1 - v1 * w**h - call stdlib_wgemm( 'NO TRANSPOSE', 'CONJUGATE TRANSPOSE',m-k, n, k, -cone, & + call stdlib_${ci}$gemm( 'NO TRANSPOSE', 'CONJUGATE TRANSPOSE',m-k, n, k, -cone, & v, ldv, work, ldwork,cone, c, ldc ) end if ! w := w * v2**h - call stdlib_wtrmm( 'RIGHT', 'UPPER', 'CONJUGATE TRANSPOSE','UNIT', n, k, cone,& + call stdlib_${ci}$trmm( 'RIGHT', 'UPPER', 'CONJUGATE TRANSPOSE','UNIT', n, k, cone,& v( m-k+1, 1 ), ldv, work,ldwork ) ! c2 := c2 - w**h do j = 1, k @@ -49029,27 +49031,27 @@ module stdlib_linalg_lapack_w ! w := c * v = (c1*v1 + c2*v2) (stored in work) ! w := c2 do j = 1, k - call stdlib_wcopy( m, c( 1, n-k+j ), 1, work( 1, j ), 1 ) + call stdlib_${ci}$copy( m, c( 1, n-k+j ), 1, work( 1, j ), 1 ) end do ! w := w * v2 - call stdlib_wtrmm( 'RIGHT', 'UPPER', 'NO TRANSPOSE', 'UNIT', m,k, cone, v( n-& + call stdlib_${ci}$trmm( 'RIGHT', 'UPPER', 'NO TRANSPOSE', 'UNIT', m,k, cone, v( n-& k+1, 1 ), ldv, work, ldwork ) if( n>k ) then ! w := w + c1 * v1 - call stdlib_wgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', m, k, n-k,cone, c, ldc, & + call stdlib_${ci}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', m, k, n-k,cone, c, ldc, & v, ldv, cone, work, ldwork ) end if ! w := w * t or w * t**h - call stdlib_wtrmm( 'RIGHT', 'LOWER', trans, 'NON-UNIT', m, k,cone, t, ldt, & + call stdlib_${ci}$trmm( 'RIGHT', 'LOWER', trans, 'NON-UNIT', m, k,cone, t, ldt, & work, ldwork ) ! c := c - w * v**h if( n>k ) then ! c1 := c1 - w * v1**h - call stdlib_wgemm( 'NO TRANSPOSE', 'CONJUGATE TRANSPOSE', m,n-k, k, -cone, & + call stdlib_${ci}$gemm( 'NO TRANSPOSE', 'CONJUGATE TRANSPOSE', m,n-k, k, -cone, & work, ldwork, v, ldv, cone,c, ldc ) end if ! w := w * v2**h - call stdlib_wtrmm( 'RIGHT', 'UPPER', 'CONJUGATE TRANSPOSE','UNIT', m, k, cone,& + call stdlib_${ci}$trmm( 'RIGHT', 'UPPER', 'CONJUGATE TRANSPOSE','UNIT', m, k, cone,& v( n-k+1, 1 ), ldv, work,ldwork ) ! c2 := c2 - w do j = 1, k @@ -49069,28 +49071,28 @@ module stdlib_linalg_lapack_w ! w := c**h * v**h = (c1**h * v1**h + c2**h * v2**h) (stored in work) ! w := c1**h do j = 1, k - call stdlib_wcopy( n, c( j, 1 ), ldc, work( 1, j ), 1 ) - call stdlib_wlacgv( n, work( 1, j ), 1 ) + call stdlib_${ci}$copy( n, c( j, 1 ), ldc, work( 1, j ), 1 ) + call stdlib_${ci}$lacgv( n, work( 1, j ), 1 ) end do ! w := w * v1**h - call stdlib_wtrmm( 'RIGHT', 'UPPER', 'CONJUGATE TRANSPOSE','UNIT', n, k, cone,& + call stdlib_${ci}$trmm( 'RIGHT', 'UPPER', 'CONJUGATE TRANSPOSE','UNIT', n, k, cone,& v, ldv, work, ldwork ) if( m>k ) then ! w := w + c2**h * v2**h - call stdlib_wgemm( 'CONJUGATE TRANSPOSE','CONJUGATE TRANSPOSE', n, k, m-k, & + call stdlib_${ci}$gemm( 'CONJUGATE TRANSPOSE','CONJUGATE TRANSPOSE', n, k, m-k, & cone,c( k+1, 1 ), ldc, v( 1, k+1 ), ldv, cone,work, ldwork ) end if ! w := w * t**h or w * t - call stdlib_wtrmm( 'RIGHT', 'UPPER', transt, 'NON-UNIT', n, k,cone, t, ldt, & + call stdlib_${ci}$trmm( 'RIGHT', 'UPPER', transt, 'NON-UNIT', n, k,cone, t, ldt, & work, ldwork ) ! c := c - v**h * w**h if( m>k ) then ! c2 := c2 - v2**h * w**h - call stdlib_wgemm( 'CONJUGATE TRANSPOSE','CONJUGATE TRANSPOSE', m-k, n, k, & + call stdlib_${ci}$gemm( 'CONJUGATE TRANSPOSE','CONJUGATE TRANSPOSE', m-k, n, k, & -cone,v( 1, k+1 ), ldv, work, ldwork, cone,c( k+1, 1 ), ldc ) end if ! w := w * v1 - call stdlib_wtrmm( 'RIGHT', 'UPPER', 'NO TRANSPOSE', 'UNIT', n,k, cone, v, & + call stdlib_${ci}$trmm( 'RIGHT', 'UPPER', 'NO TRANSPOSE', 'UNIT', n,k, cone, v, & ldv, work, ldwork ) ! c1 := c1 - w**h do j = 1, k @@ -49103,27 +49105,27 @@ module stdlib_linalg_lapack_w ! w := c * v**h = (c1*v1**h + c2*v2**h) (stored in work) ! w := c1 do j = 1, k - call stdlib_wcopy( m, c( 1, j ), 1, work( 1, j ), 1 ) + call stdlib_${ci}$copy( m, c( 1, j ), 1, work( 1, j ), 1 ) end do ! w := w * v1**h - call stdlib_wtrmm( 'RIGHT', 'UPPER', 'CONJUGATE TRANSPOSE','UNIT', m, k, cone,& + call stdlib_${ci}$trmm( 'RIGHT', 'UPPER', 'CONJUGATE TRANSPOSE','UNIT', m, k, cone,& v, ldv, work, ldwork ) if( n>k ) then ! w := w + c2 * v2**h - call stdlib_wgemm( 'NO TRANSPOSE', 'CONJUGATE TRANSPOSE', m,k, n-k, cone, & + call stdlib_${ci}$gemm( 'NO TRANSPOSE', 'CONJUGATE TRANSPOSE', m,k, n-k, cone, & c( 1, k+1 ), ldc,v( 1, k+1 ), ldv, cone, work, ldwork ) end if ! w := w * t or w * t**h - call stdlib_wtrmm( 'RIGHT', 'UPPER', trans, 'NON-UNIT', m, k,cone, t, ldt, & + call stdlib_${ci}$trmm( 'RIGHT', 'UPPER', trans, 'NON-UNIT', m, k,cone, t, ldt, & work, ldwork ) ! c := c - w * v if( n>k ) then ! c2 := c2 - w * v2 - call stdlib_wgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', m, n-k, k,-cone, work, & + call stdlib_${ci}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', m, n-k, k,-cone, work, & ldwork, v( 1, k+1 ), ldv, cone,c( 1, k+1 ), ldc ) end if ! w := w * v1 - call stdlib_wtrmm( 'RIGHT', 'UPPER', 'NO TRANSPOSE', 'UNIT', m,k, cone, v, & + call stdlib_${ci}$trmm( 'RIGHT', 'UPPER', 'NO TRANSPOSE', 'UNIT', m,k, cone, v, & ldv, work, ldwork ) ! c1 := c1 - w do j = 1, k @@ -49141,28 +49143,28 @@ module stdlib_linalg_lapack_w ! w := c**h * v**h = (c1**h * v1**h + c2**h * v2**h) (stored in work) ! w := c2**h do j = 1, k - call stdlib_wcopy( n, c( m-k+j, 1 ), ldc, work( 1, j ), 1 ) - call stdlib_wlacgv( n, work( 1, j ), 1 ) + call stdlib_${ci}$copy( n, c( m-k+j, 1 ), ldc, work( 1, j ), 1 ) + call stdlib_${ci}$lacgv( n, work( 1, j ), 1 ) end do ! w := w * v2**h - call stdlib_wtrmm( 'RIGHT', 'LOWER', 'CONJUGATE TRANSPOSE','UNIT', n, k, cone,& + call stdlib_${ci}$trmm( 'RIGHT', 'LOWER', 'CONJUGATE TRANSPOSE','UNIT', n, k, cone,& v( 1, m-k+1 ), ldv, work,ldwork ) if( m>k ) then ! w := w + c1**h * v1**h - call stdlib_wgemm( 'CONJUGATE TRANSPOSE','CONJUGATE TRANSPOSE', n, k, m-k, & + call stdlib_${ci}$gemm( 'CONJUGATE TRANSPOSE','CONJUGATE TRANSPOSE', n, k, m-k, & cone, c,ldc, v, ldv, cone, work, ldwork ) end if ! w := w * t**h or w * t - call stdlib_wtrmm( 'RIGHT', 'LOWER', transt, 'NON-UNIT', n, k,cone, t, ldt, & + call stdlib_${ci}$trmm( 'RIGHT', 'LOWER', transt, 'NON-UNIT', n, k,cone, t, ldt, & work, ldwork ) ! c := c - v**h * w**h if( m>k ) then ! c1 := c1 - v1**h * w**h - call stdlib_wgemm( 'CONJUGATE TRANSPOSE','CONJUGATE TRANSPOSE', m-k, n, k, & + call stdlib_${ci}$gemm( 'CONJUGATE TRANSPOSE','CONJUGATE TRANSPOSE', m-k, n, k, & -cone, v,ldv, work, ldwork, cone, c, ldc ) end if ! w := w * v2 - call stdlib_wtrmm( 'RIGHT', 'LOWER', 'NO TRANSPOSE', 'UNIT', n,k, cone, v( 1, & + call stdlib_${ci}$trmm( 'RIGHT', 'LOWER', 'NO TRANSPOSE', 'UNIT', n,k, cone, v( 1, & m-k+1 ), ldv, work, ldwork ) ! c2 := c2 - w**h do j = 1, k @@ -49175,27 +49177,27 @@ module stdlib_linalg_lapack_w ! w := c * v**h = (c1*v1**h + c2*v2**h) (stored in work) ! w := c2 do j = 1, k - call stdlib_wcopy( m, c( 1, n-k+j ), 1, work( 1, j ), 1 ) + call stdlib_${ci}$copy( m, c( 1, n-k+j ), 1, work( 1, j ), 1 ) end do ! w := w * v2**h - call stdlib_wtrmm( 'RIGHT', 'LOWER', 'CONJUGATE TRANSPOSE','UNIT', m, k, cone,& + call stdlib_${ci}$trmm( 'RIGHT', 'LOWER', 'CONJUGATE TRANSPOSE','UNIT', m, k, cone,& v( 1, n-k+1 ), ldv, work,ldwork ) if( n>k ) then ! w := w + c1 * v1**h - call stdlib_wgemm( 'NO TRANSPOSE', 'CONJUGATE TRANSPOSE', m,k, n-k, cone, & + call stdlib_${ci}$gemm( 'NO TRANSPOSE', 'CONJUGATE TRANSPOSE', m,k, n-k, cone, & c, ldc, v, ldv, cone, work,ldwork ) end if ! w := w * t or w * t**h - call stdlib_wtrmm( 'RIGHT', 'LOWER', trans, 'NON-UNIT', m, k,cone, t, ldt, & + call stdlib_${ci}$trmm( 'RIGHT', 'LOWER', trans, 'NON-UNIT', m, k,cone, t, ldt, & work, ldwork ) ! c := c - w * v if( n>k ) then ! c1 := c1 - w * v1 - call stdlib_wgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', m, n-k, k,-cone, work, & + call stdlib_${ci}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', m, n-k, k,-cone, work, & ldwork, v, ldv, cone, c, ldc ) end if ! w := w * v2 - call stdlib_wtrmm( 'RIGHT', 'LOWER', 'NO TRANSPOSE', 'UNIT', m,k, cone, v( 1, & + call stdlib_${ci}$trmm( 'RIGHT', 'LOWER', 'NO TRANSPOSE', 'UNIT', m,k, cone, v( 1, & n-k+1 ), ldv, work, ldwork ) ! c1 := c1 - w do j = 1, k @@ -49207,10 +49209,10 @@ module stdlib_linalg_lapack_w end if end if return - end subroutine stdlib_wlarfb + end subroutine stdlib_${ci}$larfb - pure subroutine stdlib_wlarfb_gett( ident, m, n, k, t, ldt, a, lda, b, ldb,work, ldwork ) + pure subroutine stdlib_${ci}$larfb_gett( ident, m, n, k, t, ldt, a, lda, b, ldb,work, ldwork ) !! ZLARFB_GETT: applies a complex Householder block reflector H from the !! left to a complex (K+M)-by-N "triangular-pentagonal" matrix !! composed of two block matrices: an upper trapezoidal K-by-N matrix A @@ -49226,9 +49228,9 @@ module stdlib_linalg_lapack_w character, intent(in) :: ident integer(ilp), intent(in) :: k, lda, ldb, ldt, ldwork, m, n ! Array Arguments - complex(qp), intent(inout) :: a(lda,*), b(ldb,*) - complex(qp), intent(in) :: t(ldt,*) - complex(qp), intent(out) :: work(ldwork,*) + complex(${ck}$), intent(inout) :: a(lda,*), b(ldb,*) + complex(${ck}$), intent(in) :: t(ldt,*) + complex(${ck}$), intent(out) :: work(ldwork,*) ! ===================================================================== ! Local Scalars @@ -49247,35 +49249,35 @@ module stdlib_linalg_lapack_w ! col2_(1) compute w2: = a2. therefore, copy a2 = a(1:k, k+1:n) ! into w2=work(1:k, 1:n-k) column-by-column. do j = 1, n-k - call stdlib_wcopy( k, a( 1, k+j ), 1, work( 1, j ), 1 ) + call stdlib_${ci}$copy( k, a( 1, k+j ), 1, work( 1, j ), 1 ) end do if( lnotident ) then ! col2_(2) compute w2: = (v1**h) * w2 = (a1**h) * w2, ! v1 is not an identy matrix, but unit lower-triangular ! v1 stored in a1 (diagonal ones are not stored). - call stdlib_wtrmm( 'L', 'L', 'C', 'U', k, n-k, cone, a, lda,work, ldwork ) + call stdlib_${ci}$trmm( 'L', 'L', 'C', 'U', k, n-k, cone, a, lda,work, ldwork ) end if ! col2_(3) compute w2: = w2 + (v2**h) * b2 = w2 + (b1**h) * b2 ! v2 stored in b1. if( m>0 ) then - call stdlib_wgemm( 'C', 'N', k, n-k, m, cone, b, ldb,b( 1, k+1 ), ldb, cone, & + call stdlib_${ci}$gemm( 'C', 'N', k, n-k, m, cone, b, ldb,b( 1, k+1 ), ldb, cone, & work, ldwork ) end if ! col2_(4) compute w2: = t * w2, ! t is upper-triangular. - call stdlib_wtrmm( 'L', 'U', 'N', 'N', k, n-k, cone, t, ldt,work, ldwork ) + call stdlib_${ci}$trmm( 'L', 'U', 'N', 'N', k, n-k, cone, t, ldt,work, ldwork ) ! col2_(5) compute b2: = b2 - v2 * w2 = b2 - b1 * w2, ! v2 stored in b1. if( m>0 ) then - call stdlib_wgemm( 'N', 'N', m, n-k, k, -cone, b, ldb,work, ldwork, cone, b( 1, & + call stdlib_${ci}$gemm( 'N', 'N', m, n-k, k, -cone, b, ldb,work, ldwork, cone, b( 1, & k+1 ), ldb ) end if if( lnotident ) then ! col2_(6) compute w2: = v1 * w2 = a1 * w2, ! v1 is not an identity matrix, but unit lower-triangular, ! v1 stored in a1 (diagonal ones are not stored). - call stdlib_wtrmm( 'L', 'L', 'N', 'U', k, n-k, cone, a, lda,work, ldwork ) + call stdlib_${ci}$trmm( 'L', 'L', 'N', 'U', k, n-k, cone, a, lda,work, ldwork ) end if ! col2_(7) compute a2: = a2 - w2 = @@ -49296,7 +49298,7 @@ module stdlib_linalg_lapack_w ! a1 = a(1:k, 1:k) into the upper-triangular ! w1 = work(1:k, 1:k) column-by-column. do j = 1, k - call stdlib_wcopy( j, a( 1, j ), 1, work( 1, j ), 1 ) + call stdlib_${ci}$copy( j, a( 1, j ), 1, work( 1, j ), 1 ) end do ! set the subdiagonal elements of w1 to zero column-by-column. do j = 1, k - 1 @@ -49309,16 +49311,16 @@ module stdlib_linalg_lapack_w ! v1 is not an identity matrix, but unit lower-triangular ! v1 stored in a1 (diagonal ones are not stored), ! w1 is upper-triangular with zeroes below the diagonal. - call stdlib_wtrmm( 'L', 'L', 'C', 'U', k, k, cone, a, lda,work, ldwork ) + call stdlib_${ci}$trmm( 'L', 'L', 'C', 'U', k, k, cone, a, lda,work, ldwork ) end if ! col1_(3) compute w1: = t * w1, ! t is upper-triangular, ! w1 is upper-triangular with zeroes below the diagonal. - call stdlib_wtrmm( 'L', 'U', 'N', 'N', k, k, cone, t, ldt,work, ldwork ) + call stdlib_${ci}$trmm( 'L', 'U', 'N', 'N', k, k, cone, t, ldt,work, ldwork ) ! col1_(4) compute b1: = - v2 * w1 = - b1 * w1, ! v2 = b1, w1 is upper-triangular with zeroes below the diagonal. if( m>0 ) then - call stdlib_wtrmm( 'R', 'U', 'N', 'N', m, k, -cone, work, ldwork,b, ldb ) + call stdlib_${ci}$trmm( 'R', 'U', 'N', 'N', m, k, -cone, work, ldwork,b, ldb ) end if if( lnotident ) then ! col1_(5) compute w1: = v1 * w1 = a1 * w1, @@ -49326,7 +49328,7 @@ module stdlib_linalg_lapack_w ! v1 stored in a1 (diagonal ones are not stored), ! w1 is upper-triangular on input with zeroes below the diagonal, ! and square on output. - call stdlib_wtrmm( 'L', 'L', 'N', 'U', k, k, cone, a, lda,work, ldwork ) + call stdlib_${ci}$trmm( 'L', 'L', 'N', 'U', k, k, cone, a, lda,work, ldwork ) ! col1_(6) compute a1: = a1 - w1 = a(1:k, 1:k) - work(1:k, 1:k) ! column-by-column. a1 is upper-triangular on input. ! if ident, a1 is square on output, and w1 is square, @@ -49346,10 +49348,10 @@ module stdlib_linalg_lapack_w end do end do return - end subroutine stdlib_wlarfb_gett + end subroutine stdlib_${ci}$larfb_gett - pure subroutine stdlib_wlarfg( n, alpha, x, incx, tau ) + pure subroutine stdlib_${ci}$larfg( n, alpha, x, incx, tau ) !! ZLARFG: generates a complex elementary reflector H of order n, such !! that !! H**H * ( alpha ) = ( beta ), H**H * H = I. @@ -49368,15 +49370,15 @@ module stdlib_linalg_lapack_w ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments integer(ilp), intent(in) :: incx, n - complex(qp), intent(inout) :: alpha - complex(qp), intent(out) :: tau + complex(${ck}$), intent(inout) :: alpha + complex(${ck}$), intent(out) :: tau ! Array Arguments - complex(qp), intent(inout) :: x(*) + complex(${ck}$), intent(inout) :: x(*) ! ===================================================================== ! Local Scalars integer(ilp) :: j, knt - real(qp) :: alphi, alphr, beta, rsafmn, safmin, xnorm + real(${ck}$) :: alphi, alphr, beta, rsafmn, safmin, xnorm ! Intrinsic Functions intrinsic :: abs,real,cmplx,aimag,sign ! Executable Statements @@ -49384,35 +49386,35 @@ module stdlib_linalg_lapack_w tau = zero return end if - xnorm = stdlib_qznrm2( n-1, x, incx ) - alphr = real( alpha,KIND=qp) + xnorm = stdlib_${c2ri(ci)}$znrm2( n-1, x, incx ) + alphr = real( alpha,KIND=${ck}$) alphi = aimag( alpha ) if( xnorm==zero .and. alphi==zero ) then ! h = i tau = zero else ! general case - beta = -sign( stdlib_qlapy3( alphr, alphi, xnorm ), alphr ) - safmin = stdlib_qlamch( 'S' ) / stdlib_qlamch( 'E' ) + beta = -sign( stdlib_${c2ri(ci)}$lapy3( alphr, alphi, xnorm ), alphr ) + safmin = stdlib_${c2ri(ci)}$lamch( 'S' ) / stdlib_${c2ri(ci)}$lamch( 'E' ) rsafmn = one / safmin knt = 0 if( abs( beta )= 0. @@ -49480,8 +49482,8 @@ module stdlib_linalg_lapack_w end if else ! only "reflecting" the diagonal entry to be real and non-negative. - xnorm = stdlib_qlapy2( alphr, alphi ) - tau = cmplx( one - alphr / xnorm, -alphi / xnorm,KIND=qp) + xnorm = stdlib_${c2ri(ci)}$lapy2( alphr, alphi ) + tau = cmplx( one - alphr / xnorm, -alphi / xnorm,KIND=${ck}$) do j = 1, n-1 x( 1 + (j-1)*incx ) = zero end do @@ -49489,23 +49491,23 @@ module stdlib_linalg_lapack_w end if else ! general case - beta = sign( stdlib_qlapy3( alphr, alphi, xnorm ), alphr ) - smlnum = stdlib_qlamch( 'S' ) / stdlib_qlamch( 'E' ) + beta = sign( stdlib_${c2ri(ci)}$lapy3( alphr, alphi, xnorm ), alphr ) + smlnum = stdlib_${c2ri(ci)}$lamch( 'S' ) / stdlib_${c2ri(ci)}$lamch( 'E' ) bignum = one / smlnum knt = 0 if( abs( beta )=zero ) then @@ -49535,11 +49537,11 @@ module stdlib_linalg_lapack_w do j = 1, n-1 x( 1 + (j-1)*incx ) = zero end do - beta = real( -savealpha,KIND=qp) + beta = real( -savealpha,KIND=${ck}$) end if else - xnorm = stdlib_qlapy2( alphr, alphi ) - tau = cmplx( one - alphr / xnorm, -alphi / xnorm,KIND=qp) + xnorm = stdlib_${c2ri(ci)}$lapy2( alphr, alphi ) + tau = cmplx( one - alphr / xnorm, -alphi / xnorm,KIND=${ck}$) do j = 1, n-1 x( 1 + (j-1)*incx ) = zero end do @@ -49547,7 +49549,7 @@ module stdlib_linalg_lapack_w end if else ! this is the general case. - call stdlib_wscal( n-1, alpha, x, incx ) + call stdlib_${ci}$scal( n-1, alpha, x, incx ) end if ! if beta is subnormal, it may lose relative accuracy do j = 1, knt @@ -49556,10 +49558,10 @@ module stdlib_linalg_lapack_w alpha = beta end if return - end subroutine stdlib_wlarfgp + end subroutine stdlib_${ci}$larfgp - pure subroutine stdlib_wlarft( direct, storev, n, k, v, ldv, tau, t, ldt ) + pure subroutine stdlib_${ci}$larft( direct, storev, n, k, v, ldv, tau, t, ldt ) !! ZLARFT: forms the triangular factor T of a complex block reflector H !! of order n, which is defined as a product of k elementary reflectors. !! If DIRECT = 'F', H = H(1) H(2) . . . H(k) and T is upper triangular; @@ -49577,8 +49579,8 @@ module stdlib_linalg_lapack_w character, intent(in) :: direct, storev integer(ilp), intent(in) :: k, ldt, ldv, n ! Array Arguments - complex(qp), intent(out) :: t(ldt,*) - complex(qp), intent(in) :: tau(*), v(ldv,*) + complex(${ck}$), intent(out) :: t(ldt,*) + complex(${ck}$), intent(in) :: tau(*), v(ldv,*) ! ===================================================================== ! Local Scalars @@ -49607,7 +49609,7 @@ module stdlib_linalg_lapack_w end do j = min( lastv, prevlastv ) ! t(1:i-1,i) := - tau(i) * v(i:j,1:i-1)**h * v(i:j,i) - call stdlib_wgemv( 'CONJUGATE TRANSPOSE', j-i, i-1,-tau( i ), v( i+1, 1 ), & + call stdlib_${ci}$gemv( 'CONJUGATE TRANSPOSE', j-i, i-1,-tau( i ), v( i+1, 1 ), & ldv,v( i+1, i ), 1, cone, t( 1, i ), 1 ) else ! skip any trailing zeros. @@ -49619,11 +49621,11 @@ module stdlib_linalg_lapack_w end do j = min( lastv, prevlastv ) ! t(1:i-1,i) := - tau(i) * v(1:i-1,i:j) * v(i,i:j)**h - call stdlib_wgemm( 'N', 'C', i-1, 1, j-i, -tau( i ),v( 1, i+1 ), ldv, v( i,& + call stdlib_${ci}$gemm( 'N', 'C', i-1, 1, j-i, -tau( i ),v( 1, i+1 ), ldv, v( i,& i+1 ), ldv,cone, t( 1, i ), ldt ) end if ! t(1:i-1,i) := t(1:i-1,1:i-1) * t(1:i-1,i) - call stdlib_wtrmv( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', i-1, t,ldt, t( 1, i ),& + call stdlib_${ci}$trmv( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', i-1, t,ldt, t( 1, i ),& 1 ) t( i, i ) = tau( i ) if( i>1 ) then @@ -49654,7 +49656,7 @@ module stdlib_linalg_lapack_w end do j = max( lastv, prevlastv ) ! t(i+1:k,i) = -tau(i) * v(j:n-k+i,i+1:k)**h * v(j:n-k+i,i) - call stdlib_wgemv( 'CONJUGATE TRANSPOSE', n-k+i-j, k-i,-tau( i ), v( j, & + call stdlib_${ci}$gemv( 'CONJUGATE TRANSPOSE', n-k+i-j, k-i,-tau( i ), v( j, & i+1 ), ldv, v( j, i ),1, cone, t( i+1, i ), 1 ) else ! skip any leading zeros. @@ -49666,11 +49668,11 @@ module stdlib_linalg_lapack_w end do j = max( lastv, prevlastv ) ! t(i+1:k,i) = -tau(i) * v(i+1:k,j:n-k+i) * v(i,j:n-k+i)**h - call stdlib_wgemm( 'N', 'C', k-i, 1, n-k+i-j, -tau( i ),v( i+1, j ), & + call stdlib_${ci}$gemm( 'N', 'C', k-i, 1, n-k+i-j, -tau( i ),v( i+1, j ), & ldv, v( i, j ), ldv,cone, t( i+1, i ), ldt ) end if ! t(i+1:k,i) := t(i+1:k,i+1:k) * t(i+1:k,i) - call stdlib_wtrmv( 'LOWER', 'NO TRANSPOSE', 'NON-UNIT', k-i,t( i+1, i+1 ), & + call stdlib_${ci}$trmv( 'LOWER', 'NO TRANSPOSE', 'NON-UNIT', k-i,t( i+1, i+1 ), & ldt, t( i+1, i ), 1 ) if( i>1 ) then prevlastv = min( prevlastv, lastv ) @@ -49683,10 +49685,10 @@ module stdlib_linalg_lapack_w end do end if return - end subroutine stdlib_wlarft + end subroutine stdlib_${ci}$larft - pure subroutine stdlib_wlarfx( side, m, n, v, tau, c, ldc, work ) + pure subroutine stdlib_${ci}$larfx( side, m, n, v, tau, c, ldc, work ) !! ZLARFX: applies a complex elementary reflector H to a complex m by n !! matrix C, from either the left or the right. H is represented in the !! form @@ -49700,16 +49702,16 @@ module stdlib_linalg_lapack_w ! Scalar Arguments character, intent(in) :: side integer(ilp), intent(in) :: ldc, m, n - complex(qp), intent(in) :: tau + complex(${ck}$), intent(in) :: tau ! Array Arguments - complex(qp), intent(inout) :: c(ldc,*) - complex(qp), intent(in) :: v(*) - complex(qp), intent(out) :: work(*) + complex(${ck}$), intent(inout) :: c(ldc,*) + complex(${ck}$), intent(in) :: v(*) + complex(${ck}$), intent(out) :: work(*) ! ===================================================================== ! Local Scalars integer(ilp) :: j - complex(qp) :: sum, t1, t10, t2, t3, t4, t5, t6, t7, t8, t9, v1, v10, v2, v3, v4, v5, & + complex(${ck}$) :: sum, t1, t10, t2, t3, t4, t5, t6, t7, t8, t9, v1, v10, v2, v3, v4, v5, & v6, v7, v8, v9 ! Intrinsic Functions intrinsic :: conjg @@ -49719,7 +49721,7 @@ module stdlib_linalg_lapack_w ! form h * c, where h has order m. go to ( 10, 30, 50, 70, 90, 110, 130, 150,170, 190 )m ! code for general m - call stdlib_wlarf( side, m, n, v, 1, tau, c, ldc, work ) + call stdlib_${ci}$larf( side, m, n, v, 1, tau, c, ldc, work ) go to 410 10 continue ! special code for 1 x 1 householder @@ -49954,7 +49956,7 @@ module stdlib_linalg_lapack_w ! form c * h, where h has order n. go to ( 210, 230, 250, 270, 290, 310, 330, 350,370, 390 )n ! code for general n - call stdlib_wlarf( side, m, n, v, 1, tau, c, ldc, work ) + call stdlib_${ci}$larf( side, m, n, v, 1, tau, c, ldc, work ) go to 410 210 continue ! special code for 1 x 1 householder @@ -50188,10 +50190,10 @@ module stdlib_linalg_lapack_w end if 410 continue return - end subroutine stdlib_wlarfx + end subroutine stdlib_${ci}$larfx - pure subroutine stdlib_wlarfy( uplo, n, v, incv, tau, c, ldc, work ) + pure subroutine stdlib_${ci}$larfy( uplo, n, v, incv, tau, c, ldc, work ) !! ZLARFY: applies an elementary reflector, or Householder matrix, H, !! to an n x n Hermitian matrix C, from both the left and the right. !! H is represented in the form @@ -50204,28 +50206,28 @@ module stdlib_linalg_lapack_w ! Scalar Arguments character, intent(in) :: uplo integer(ilp), intent(in) :: incv, ldc, n - complex(qp), intent(in) :: tau + complex(${ck}$), intent(in) :: tau ! Array Arguments - complex(qp), intent(inout) :: c(ldc,*) - complex(qp), intent(in) :: v(*) - complex(qp), intent(out) :: work(*) + complex(${ck}$), intent(inout) :: c(ldc,*) + complex(${ck}$), intent(in) :: v(*) + complex(${ck}$), intent(out) :: work(*) ! ===================================================================== ! Local Scalars - complex(qp) :: alpha + complex(${ck}$) :: alpha ! Executable Statements if( tau==czero )return ! form w:= c * v - call stdlib_whemv( uplo, n, cone, c, ldc, v, incv, czero, work, 1 ) - alpha = -chalf*tau*stdlib_wdotc( n, work, 1, v, incv ) - call stdlib_waxpy( n, alpha, v, incv, work, 1 ) + call stdlib_${ci}$hemv( uplo, n, cone, c, ldc, v, incv, czero, work, 1 ) + alpha = -chalf*tau*stdlib_${ci}$dotc( n, work, 1, v, incv ) + call stdlib_${ci}$axpy( n, alpha, v, incv, work, 1 ) ! c := c - v * w' - w * v' - call stdlib_wher2( uplo, n, -tau, v, incv, work, 1, c, ldc ) + call stdlib_${ci}$her2( uplo, n, -tau, v, incv, work, 1, c, ldc ) return - end subroutine stdlib_wlarfy + end subroutine stdlib_${ci}$larfy - pure subroutine stdlib_wlargv( n, x, incx, y, incy, c, incc ) + pure subroutine stdlib_${ci}$largv( n, x, incx, y, incy, c, incc ) !! ZLARGV: generates a vector of complex plane rotations with real !! cosines, determined by elements of the complex vectors x and y. !! For i = 1,2,...,n @@ -50242,33 +50244,33 @@ module stdlib_linalg_lapack_w ! Scalar Arguments integer(ilp), intent(in) :: incc, incx, incy, n ! Array Arguments - real(qp), intent(out) :: c(*) - complex(qp), intent(inout) :: x(*), y(*) + real(${ck}$), intent(out) :: c(*) + complex(${ck}$), intent(inout) :: x(*), y(*) ! ===================================================================== ! Local Scalars ! logical first integer(ilp) :: count, i, ic, ix, iy, j - real(qp) :: cs, d, di, dr, eps, f2, f2s, g2, g2s, safmin, safmn2, safmx2, scale - complex(qp) :: f, ff, fs, g, gs, r, sn + real(${ck}$) :: cs, d, di, dr, eps, f2, f2s, g2, g2s, safmin, safmn2, safmx2, scale + complex(${ck}$) :: f, ff, fs, g, gs, r, sn ! Intrinsic Functions intrinsic :: abs,real,cmplx,conjg,aimag,int,log,max,sqrt ! Statement Functions - real(qp) :: abs1, abssq + real(${ck}$) :: abs1, abssq ! Save Statement ! save first, safmx2, safmin, safmn2 ! Data Statements ! data first / .true. / ! Statement Function Definitions - abs1( ff ) = max( abs( real( ff,KIND=qp) ), abs( aimag( ff ) ) ) - abssq( ff ) = real( ff,KIND=qp)**2 + aimag( ff )**2 + abs1( ff ) = max( abs( real( ff,KIND=${ck}$) ), abs( aimag( ff ) ) ) + abssq( ff ) = real( ff,KIND=${ck}$)**2 + aimag( ff )**2 ! Executable Statements ! if( first ) then ! first = .false. - safmin = stdlib_qlamch( 'S' ) - eps = stdlib_qlamch( 'E' ) - safmn2 = stdlib_qlamch( 'B' )**int( log( safmin / eps ) /log( stdlib_qlamch( 'B' ) )& + safmin = stdlib_${c2ri(ci)}$lamch( 'S' ) + eps = stdlib_${c2ri(ci)}$lamch( 'E' ) + safmn2 = stdlib_${c2ri(ci)}$lamch( 'B' )**int( log( safmin / eps ) /log( stdlib_${c2ri(ci)}$lamch( 'B' ) )& / two,KIND=ilp) safmx2 = one / safmn2 ! end if @@ -50278,7 +50280,7 @@ module stdlib_linalg_lapack_w loop_60: do i = 1, n f = x( ix ) g = y( iy ) - ! use identical algorithm as in stdlib_wlartg + ! use identical algorithm as in stdlib_${ci}$lartg scale = max( abs1( f ), abs1( g ) ) fs = f gs = g @@ -50310,14 +50312,14 @@ module stdlib_linalg_lapack_w ! this is a rare case: f is very small. if( f==czero ) then cs = zero - r = stdlib_qlapy2( real( g,KIND=qp), aimag( g ) ) + r = stdlib_${c2ri(ci)}$lapy2( real( g,KIND=${ck}$), aimag( g ) ) ! do complex/real division explicitly with two real ! divisions - d = stdlib_qlapy2( real( gs,KIND=qp), aimag( gs ) ) - sn = cmplx( real( gs,KIND=qp) / d, -aimag( gs ) / d,KIND=qp) + d = stdlib_${c2ri(ci)}$lapy2( real( gs,KIND=${ck}$), aimag( gs ) ) + sn = cmplx( real( gs,KIND=${ck}$) / d, -aimag( gs ) / d,KIND=${ck}$) go to 50 end if - f2s = stdlib_qlapy2( real( fs,KIND=qp), aimag( fs ) ) + f2s = stdlib_${c2ri(ci)}$lapy2( real( fs,KIND=${ck}$), aimag( fs ) ) ! g2 and g2s are accurate ! g2 is at least safmin, and g2s is at least safmn2 g2s = sqrt( g2 ) @@ -50332,15 +50334,15 @@ module stdlib_linalg_lapack_w ! make sure abs(ff) = 1 ! do complex/real division explicitly with 2 real divisions if( abs1( f )>one ) then - d = stdlib_qlapy2( real( f,KIND=qp), aimag( f ) ) - ff = cmplx( real( f,KIND=qp) / d, aimag( f ) / d,KIND=qp) + d = stdlib_${c2ri(ci)}$lapy2( real( f,KIND=${ck}$), aimag( f ) ) + ff = cmplx( real( f,KIND=${ck}$) / d, aimag( f ) / d,KIND=${ck}$) else - dr = safmx2*real( f,KIND=qp) + dr = safmx2*real( f,KIND=${ck}$) di = safmx2*aimag( f ) - d = stdlib_qlapy2( dr, di ) - ff = cmplx( dr / d, di / d,KIND=qp) + d = stdlib_${c2ri(ci)}$lapy2( dr, di ) + ff = cmplx( dr / d, di / d,KIND=${ck}$) end if - sn = ff*cmplx( real( gs,KIND=qp) / g2s, -aimag( gs ) / g2s,KIND=qp) + sn = ff*cmplx( real( gs,KIND=${ck}$) / g2s, -aimag( gs ) / g2s,KIND=${ck}$) r = cs*f + sn*g else ! this is the most common case. @@ -50349,11 +50351,11 @@ module stdlib_linalg_lapack_w f2s = sqrt( one+g2 / f2 ) ! do the f2s(real)*fs(complex) multiply with two real ! multiplies - r = cmplx( f2s*real( fs,KIND=qp), f2s*aimag( fs ),KIND=qp) + r = cmplx( f2s*real( fs,KIND=${ck}$), f2s*aimag( fs ),KIND=${ck}$) cs = one / f2s d = f2 + g2 ! do complex/real division explicitly with two real divisions - sn = cmplx( real( r,KIND=qp) / d, aimag( r ) / d,KIND=qp) + sn = cmplx( real( r,KIND=${ck}$) / d, aimag( r ) / d,KIND=${ck}$) sn = sn*conjg( gs ) if( count/=0 ) then if( count>0 ) then @@ -50376,10 +50378,10 @@ module stdlib_linalg_lapack_w ix = ix + incx end do loop_60 return - end subroutine stdlib_wlargv + end subroutine stdlib_${ci}$largv - pure subroutine stdlib_wlarnv( idist, iseed, n, x ) + pure subroutine stdlib_${ci}$larnv( idist, iseed, n, x ) !! ZLARNV: returns a vector of n random complex numbers from a uniform or !! normal distribution. ! -- lapack auxiliary routine -- @@ -50389,62 +50391,62 @@ module stdlib_linalg_lapack_w integer(ilp), intent(in) :: idist, n ! Array Arguments integer(ilp), intent(inout) :: iseed(4) - complex(qp), intent(out) :: x(*) + complex(${ck}$), intent(out) :: x(*) ! ===================================================================== ! Parameters integer(ilp), parameter :: lv = 128 - real(qp), parameter :: twopi = 6.28318530717958647692528676655900576839e+0_qp + real(${ck}$), parameter :: twopi = 6.28318530717958647692528676655900576839e+0_${ck}$ ! Local Scalars integer(ilp) :: i, il, iv ! Local Arrays - real(qp) :: u(lv) + real(${ck}$) :: u(lv) ! Intrinsic Functions intrinsic :: cmplx,exp,log,min,sqrt ! Executable Statements do 60 iv = 1, n, lv / 2 il = min( lv / 2, n-iv+1 ) - ! call stdlib_qlaruv to generate 2*il realnumbers from a uniform (0,1,KIND=qp) + ! call stdlib_${c2ri(ci)}$laruv to generate 2*il realnumbers from a uniform (0,1,KIND=${ck}$) ! distribution (2*il <= lv) - call stdlib_qlaruv( iseed, 2*il, u ) + call stdlib_${c2ri(ci)}$laruv( iseed, 2*il, u ) if( idist==1 ) then ! copy generated numbers do i = 1, il - x( iv+i-1 ) = cmplx( u( 2*i-1 ), u( 2*i ),KIND=qp) + x( iv+i-1 ) = cmplx( u( 2*i-1 ), u( 2*i ),KIND=${ck}$) end do else if( idist==2 ) then ! convert generated numbers to uniform (-1,1) distribution do i = 1, il - x( iv+i-1 ) = cmplx( two*u( 2*i-1 )-one,two*u( 2*i )-one,KIND=qp) + x( iv+i-1 ) = cmplx( two*u( 2*i-1 )-one,two*u( 2*i )-one,KIND=${ck}$) end do else if( idist==3 ) then ! convert generated numbers to normal (0,1) distribution do i = 1, il x( iv+i-1 ) = sqrt( -two*log( u( 2*i-1 ) ) )*exp( cmplx( zero, twopi*u( 2*i ),& - KIND=qp) ) + KIND=${ck}$) ) end do else if( idist==4 ) then ! convert generated numbers to complex numbers uniformly ! distributed on the unit disk do i = 1, il - x( iv+i-1 ) = sqrt( u( 2*i-1 ) )*exp( cmplx( zero, twopi*u( 2*i ),KIND=qp) ) + x( iv+i-1 ) = sqrt( u( 2*i-1 ) )*exp( cmplx( zero, twopi*u( 2*i ),KIND=${ck}$) ) end do else if( idist==5 ) then ! convert generated numbers to complex numbers uniformly ! distributed on the unit circle do i = 1, il - x( iv+i-1 ) = exp( cmplx( zero, twopi*u( 2*i ),KIND=qp) ) + x( iv+i-1 ) = exp( cmplx( zero, twopi*u( 2*i ),KIND=${ck}$) ) end do end if 60 continue return - end subroutine stdlib_wlarnv + end subroutine stdlib_${ci}$larnv - pure subroutine stdlib_wlarrv( n, vl, vu, d, l, pivmin,isplit, m, dol, dou, minrgp,rtol1, & + pure subroutine stdlib_${ci}$larrv( n, vl, vu, d, l, pivmin,isplit, m, dol, dou, minrgp,rtol1, & !! ZLARRV: computes the eigenvectors of the tridiagonal matrix !! T = L D L**T given L, D and APPROXIMATIONS to the eigenvalues of L D L**T. !! The input eigenvalues should have been computed by DLARRE. @@ -50455,15 +50457,15 @@ module stdlib_linalg_lapack_w ! Scalar Arguments integer(ilp), intent(in) :: dol, dou, ldz, m, n integer(ilp), intent(out) :: info - real(qp), intent(in) :: minrgp, pivmin, vl, vu - real(qp), intent(inout) :: rtol1, rtol2 + real(${ck}$), intent(in) :: minrgp, pivmin, vl, vu + real(${ck}$), intent(inout) :: rtol1, rtol2 ! Array Arguments integer(ilp), intent(in) :: iblock(*), indexw(*), isplit(*) integer(ilp), intent(out) :: isuppz(*), iwork(*) - real(qp), intent(inout) :: d(*), l(*), w(*), werr(*), wgap(*) - real(qp), intent(in) :: gers(*) - real(qp), intent(out) :: work(*) - complex(qp), intent(out) :: z(ldz,*) + real(${ck}$), intent(inout) :: d(*), l(*), w(*), werr(*), wgap(*) + real(${ck}$), intent(in) :: gers(*) + real(${ck}$), intent(out) :: work(*) + complex(${ck}$), intent(out) :: z(ldz,*) ! ===================================================================== ! Parameters integer(ilp), parameter :: maxitr = 10 @@ -50478,7 +50480,7 @@ module stdlib_linalg_lapack_w offset, oldcls, oldfst, oldien, oldlst, oldncl, p, parity, q, wbegin, wend, windex, & windmn, windpl, zfrom, zto, zusedl, zusedu, zusedw integer(ilp) :: indin1, indin2 - real(qp) :: bstres, bstw, eps, fudge, gap, gaptol, gl, gu, lambda, left, lgap, mingma, & + real(${ck}$) :: bstres, bstw, eps, fudge, gap, gaptol, gl, gu, lambda, left, lgap, mingma, & nrminv, resid, rgap, right, rqcorr, rqtol, savgap, sgndef, sigma, spdiam, ssigma, tau, & tmp, tol, ztz ! Intrinsic Functions @@ -50524,8 +50526,8 @@ module stdlib_linalg_lapack_w endif ! the width of the part of z that is used zusedw = zusedu - zusedl + 1 - call stdlib_wlaset( 'FULL', n, zusedw, czero, czero,z(1,zusedl), ldz ) - eps = stdlib_qlamch( 'PRECISION' ) + call stdlib_${ci}$laset( 'FULL', n, zusedw, czero, czero,z(1,zusedl), ldz ) + eps = stdlib_${c2ri(ci)}$lamch( 'PRECISION' ) rqtol = two * eps ! set expert flags for standard code. tryrqc = .true. @@ -50584,7 +50586,7 @@ module stdlib_linalg_lapack_w ! this is for a 1x1 block if( ibegin==iend ) then done = done+1 - z( ibegin, wbegin ) = cmplx( one, zero,KIND=qp) + z( ibegin, wbegin ) = cmplx( one, zero,KIND=${ck}$) isuppz( 2*wbegin-1 ) = ibegin isuppz( 2*wbegin ) = ibegin w( wbegin ) = w( wbegin ) + sigma @@ -50599,7 +50601,7 @@ module stdlib_linalg_lapack_w ! the eigenvalue approximations will be refined when necessary as ! high relative accuracy is required for the computation of the ! corresponding eigenvectors. - call stdlib_qcopy( im, w( wbegin ), 1,work( wbegin ), 1 ) + call stdlib_${c2ri(ci)}$copy( im, w( wbegin ), 1,work( wbegin ), 1 ) ! we store in w the eigenvalue approximations w.r.t. the original ! matrix t. do i=1,im @@ -50669,13 +50671,13 @@ module stdlib_linalg_lapack_w endif endif do k = 1, in - 1 - d( ibegin+k-1 ) = real( z( ibegin+k-1,j ),KIND=qp) - l( ibegin+k-1 ) = real( z( ibegin+k-1,j+1 ),KIND=qp) + d( ibegin+k-1 ) = real( z( ibegin+k-1,j ),KIND=${ck}$) + l( ibegin+k-1 ) = real( z( ibegin+k-1,j+1 ),KIND=${ck}$) end do - d( iend ) = real( z( iend, j ),KIND=qp) - sigma = real( z( iend, j+1 ),KIND=qp) + d( iend ) = real( z( iend, j ),KIND=${ck}$) + sigma = real( z( iend, j+1 ),KIND=${ck}$) ! set the corresponding entries in z to zero - call stdlib_wlaset( 'FULL', in, 2, czero, czero,z( ibegin, j), ldz ) + call stdlib_${ci}$laset( 'FULL', in, 2, czero, czero,z( ibegin, j), ldz ) end if ! compute dl and dll of current rrr @@ -50695,7 +50697,7 @@ module stdlib_linalg_lapack_w offset = indexw( wbegin ) - 1 ! perform limited bisection (if necessary) to get approximate ! eigenvalues to the precision needed. - call stdlib_qlarrb( in, d( ibegin ),work(indlld+ibegin-1),p, q, rtol1, & + call stdlib_${c2ri(ci)}$larrb( in, d( ibegin ),work(indlld+ibegin-1),p, q, rtol1, & rtol2, offset,work(wbegin),wgap(wbegin),werr(wbegin),work( indwrk ), iwork(& iindwk ),pivmin, spdiam, in, iinfo ) if( iinfo/=0 ) then @@ -50706,7 +50708,7 @@ module stdlib_linalg_lapack_w ! of the unshifted matrix and must be used for computation ! of wgap, the entries of work might stem from rrrs with ! different shifts. the gaps from wbegin-1+oldfst to - ! wbegin-1+oldlst are correctly computed in stdlib_qlarrb. + ! wbegin-1+oldlst are correctly computed in stdlib_${c2ri(ci)}$larrb. ! however, we only allow the gaps to become greater since ! this is what should happen when we decrease werr if( oldfst>1) then @@ -50788,7 +50790,7 @@ module stdlib_linalg_lapack_w p = indexw( wbegin-1+newlst ) endif offset = indexw( wbegin ) - 1 - call stdlib_qlarrb( in, d(ibegin),work( indlld+ibegin-1 ),p,p,rqtol, & + call stdlib_${c2ri(ci)}$larrb( in, d(ibegin),work( indlld+ibegin-1 ),p,p,rqtol, & rqtol, offset,work(wbegin),wgap(wbegin),werr(wbegin),work( indwrk ),& iwork( iindwk ), pivmin, spdiam,in, iinfo ) end do @@ -50804,26 +50806,26 @@ module stdlib_linalg_lapack_w endif ! compute rrr of child cluster. ! note that the new rrr is stored in z - ! stdlib_qlarrf needs lwork = 2*n - call stdlib_qlarrf( in, d( ibegin ), l( ibegin ),work(indld+ibegin-1),& + ! stdlib_${c2ri(ci)}$larrf needs lwork = 2*n + call stdlib_${c2ri(ci)}$larrf( in, d( ibegin ), l( ibegin ),work(indld+ibegin-1),& newfst, newlst, work(wbegin),wgap(wbegin), werr(wbegin),spdiam, lgap, & rgap, pivmin, tau,work( indin1 ), work( indin2 ),work( indwrk ), iinfo ) - ! in the complex case, stdlib_qlarrf cannot write + ! in the complex case, stdlib_${c2ri(ci)}$larrf cannot write ! the new rrr directly into z and needs an intermediate ! workspace do k = 1, in-1 - z( ibegin+k-1, newftt ) =cmplx( work( indin1+k-1 ), zero,KIND=qp) + z( ibegin+k-1, newftt ) =cmplx( work( indin1+k-1 ), zero,KIND=${ck}$) - z( ibegin+k-1, newftt+1 ) =cmplx( work( indin2+k-1 ), zero,KIND=qp) + z( ibegin+k-1, newftt+1 ) =cmplx( work( indin2+k-1 ), zero,KIND=${ck}$) end do - z( iend, newftt ) =cmplx( work( indin1+in-1 ), zero,KIND=qp) + z( iend, newftt ) =cmplx( work( indin1+in-1 ), zero,KIND=${ck}$) if( iinfo==0 ) then - ! a new rrr for the cluster was found by stdlib_qlarrf + ! a new rrr for the cluster was found by stdlib_${c2ri(ci)}$larrf ! update shift and store it ssigma = sigma + tau - z( iend, newftt+1 ) = cmplx( ssigma, zero,KIND=qp) + z( iend, newftt+1 ) = cmplx( ssigma, zero,KIND=${ck}$) ! work() are the midpoints and werr() the semi-width ! note that the entries in w are unchanged. do k = newfst, newlst @@ -50851,7 +50853,7 @@ module stdlib_linalg_lapack_w else ! compute eigenvector of singleton iter = 0 - tol = four * log(real(in,KIND=qp)) * eps + tol = four * log(real(in,KIND=${ck}$)) * eps k = newfst windex = wbegin + k - 1 windmn = max(windex - 1,1) @@ -50930,7 +50932,7 @@ module stdlib_linalg_lapack_w usedbs = .true. itmp1 = iwork( iindr+windex ) offset = indexw( wbegin ) - 1 - call stdlib_qlarrb( in, d(ibegin),work(indlld+ibegin-1),indeig,& + call stdlib_${c2ri(ci)}$larrb( in, d(ibegin),work(indlld+ibegin-1),indeig,& indeig,zero, two*eps, offset,work(wbegin),wgap(wbegin),werr(wbegin),& work( indwrk ),iwork( iindwk ), pivmin, spdiam,itmp1, iinfo ) if( iinfo/=0 ) then @@ -50943,7 +50945,7 @@ module stdlib_linalg_lapack_w iwork( iindr+windex ) = 0 endif ! given lambda, compute the eigenvector. - call stdlib_wlar1v( in, 1, in, lambda, d( ibegin ),l( ibegin ), work(& + call stdlib_${ci}$lar1v( in, 1, in, lambda, d( ibegin ),l( ibegin ), work(& indld+ibegin-1),work(indlld+ibegin-1),pivmin, gaptol, z( ibegin, windex & ),.not.usedbs, negcnt, ztz, mingma,iwork( iindr+windex ), isuppz( & 2*windex-1 ),nrminv, resid, rqcorr, work( indwrk ) ) @@ -51030,7 +51032,7 @@ module stdlib_linalg_lapack_w endif if (stp2ii) then ! improve error angle by second step - call stdlib_wlar1v( in, 1, in, lambda,d( ibegin ), l( ibegin ),& + call stdlib_${ci}$lar1v( in, 1, in, lambda,d( ibegin ), l( ibegin ),& work(indld+ibegin-1),work(indlld+ibegin-1),pivmin, gaptol, z( & ibegin, windex ),.not.usedbs, negcnt, ztz, mingma,iwork( iindr+& windex ),isuppz( 2*windex-1 ),nrminv, resid, rqcorr, work( indwrk & @@ -51056,7 +51058,7 @@ module stdlib_linalg_lapack_w z( ii, windex ) = zero end do endif - call stdlib_wdscal( zto-zfrom+1, nrminv,z( zfrom, windex ), 1 ) + call stdlib_${ci}$dscal( zto-zfrom+1, nrminv,z( zfrom, windex ), 1 ) 125 continue ! update w w( windex ) = lambda+sigma @@ -51091,10 +51093,10 @@ module stdlib_linalg_lapack_w wbegin = wend + 1 end do loop_170 return - end subroutine stdlib_wlarrv + end subroutine stdlib_${ci}$larrv - pure subroutine stdlib_wlartg( f, g, c, s, r ) + pure subroutine stdlib_${ci}$lartg( f, g, c, s, r ) !! ZLARTG: generates a plane rotation so that !! [ C S ] . [ F ] = [ R ] !! [ -conjg(S) C ] [ G ] [ 0 ] @@ -51122,18 +51124,18 @@ module stdlib_linalg_lapack_w ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! february 2021 ! Scalar Arguments - real(qp), intent(out) :: c - complex(qp), intent(in) :: f, g - complex(qp), intent(out) :: r, s + real(${ck}$), intent(out) :: c + complex(${ck}$), intent(in) :: f, g + complex(${ck}$), intent(out) :: r, s ! Local Scalars - real(qp) :: d, f1, f2, g1, g2, h2, p, u, uu, v, vv, w - complex(qp) :: fs, gs, t + real(${ck}$) :: d, f1, f2, g1, g2, h2, p, u, uu, v, vv, w + complex(${ck}$) :: fs, gs, t ! Intrinsic Functions intrinsic :: abs,aimag,conjg,max,min,real,sqrt ! Statement Functions - real(qp) :: abssq + real(${ck}$) :: abssq ! Statement Function Definitions - abssq( t ) = real( t,KIND=qp)**2 + aimag( t )**2 + abssq( t ) = real( t,KIND=${ck}$)**2 + aimag( t )**2 ! Executable Statements if( g == czero ) then c = one @@ -51141,7 +51143,7 @@ module stdlib_linalg_lapack_w r = f else if( f == czero ) then c = zero - g1 = max( abs(real(g,KIND=qp)), abs(aimag(g)) ) + g1 = max( abs(real(g,KIND=${ck}$)), abs(aimag(g)) ) if( g1 > rtmin .and. g1 < rtmax ) then ! use unscaled algorithm g2 = abssq( g ) @@ -51159,8 +51161,8 @@ module stdlib_linalg_lapack_w r = d*u end if else - f1 = max( abs(real(f,KIND=qp)), abs(aimag(f)) ) - g1 = max( abs(real(g,KIND=qp)), abs(aimag(g)) ) + f1 = max( abs(real(f,KIND=${ck}$)), abs(aimag(f)) ) + g1 = max( abs(real(g,KIND=${ck}$)), abs(aimag(g)) ) if( f1 > rtmin .and. f1 < rtmax .and. g1 > rtmin .and. g1 < rtmax ) then ! use unscaled algorithm f2 = abssq( f ) @@ -51209,10 +51211,10 @@ module stdlib_linalg_lapack_w end if end if return - end subroutine stdlib_wlartg + end subroutine stdlib_${ci}$lartg - pure subroutine stdlib_wlartv( n, x, incx, y, incy, c, s, incc ) + pure subroutine stdlib_${ci}$lartv( n, x, incx, y, incy, c, s, incc ) !! ZLARTV: applies a vector of complex plane rotations with real cosines !! to elements of the complex vectors x and y. For i = 1,2,...,n !! ( x(i) ) := ( c(i) s(i) ) ( x(i) ) @@ -51223,13 +51225,13 @@ module stdlib_linalg_lapack_w ! Scalar Arguments integer(ilp), intent(in) :: incc, incx, incy, n ! Array Arguments - real(qp), intent(in) :: c(*) - complex(qp), intent(in) :: s(*) - complex(qp), intent(inout) :: x(*), y(*) + real(${ck}$), intent(in) :: c(*) + complex(${ck}$), intent(in) :: s(*) + complex(${ck}$), intent(inout) :: x(*), y(*) ! ===================================================================== ! Local Scalars integer(ilp) :: i, ic, ix, iy - complex(qp) :: xi, yi + complex(${ck}$) :: xi, yi ! Intrinsic Functions intrinsic :: conjg ! Executable Statements @@ -51246,10 +51248,10 @@ module stdlib_linalg_lapack_w ic = ic + incc end do return - end subroutine stdlib_wlartv + end subroutine stdlib_${ci}$lartv - pure subroutine stdlib_wlarz( side, m, n, l, v, incv, tau, c, ldc, work ) + pure subroutine stdlib_${ci}$larz( side, m, n, l, v, incv, tau, c, ldc, work ) !! ZLARZ: applies a complex elementary reflector H to a complex !! M-by-N matrix C, from either the left or the right. H is represented !! in the form @@ -51265,11 +51267,11 @@ module stdlib_linalg_lapack_w ! Scalar Arguments character, intent(in) :: side integer(ilp), intent(in) :: incv, l, ldc, m, n - complex(qp), intent(in) :: tau + complex(${ck}$), intent(in) :: tau ! Array Arguments - complex(qp), intent(inout) :: c(ldc,*) - complex(qp), intent(in) :: v(*) - complex(qp), intent(out) :: work(*) + complex(${ck}$), intent(inout) :: c(ldc,*) + complex(${ck}$), intent(in) :: v(*) + complex(${ck}$), intent(out) :: work(*) ! ===================================================================== ! Executable Statements @@ -51277,38 +51279,38 @@ module stdlib_linalg_lapack_w ! form h * c if( tau/=czero ) then ! w( 1:n ) = conjg( c( 1, 1:n ) ) - call stdlib_wcopy( n, c, ldc, work, 1 ) - call stdlib_wlacgv( n, work, 1 ) + call stdlib_${ci}$copy( n, c, ldc, work, 1 ) + call stdlib_${ci}$lacgv( n, work, 1 ) ! w( 1:n ) = conjg( w( 1:n ) + c( m-l+1:m, 1:n )**h * v( 1:l ) ) - call stdlib_wgemv( 'CONJUGATE TRANSPOSE', l, n, cone, c( m-l+1, 1 ),ldc, v, incv,& + call stdlib_${ci}$gemv( 'CONJUGATE TRANSPOSE', l, n, cone, c( m-l+1, 1 ),ldc, v, incv,& cone, work, 1 ) - call stdlib_wlacgv( n, work, 1 ) + call stdlib_${ci}$lacgv( n, work, 1 ) ! c( 1, 1:n ) = c( 1, 1:n ) - tau * w( 1:n ) - call stdlib_waxpy( n, -tau, work, 1, c, ldc ) + call stdlib_${ci}$axpy( n, -tau, work, 1, c, ldc ) ! c( m-l+1:m, 1:n ) = c( m-l+1:m, 1:n ) - ... ! tau * v( 1:l ) * w( 1:n )**h - call stdlib_wgeru( l, n, -tau, v, incv, work, 1, c( m-l+1, 1 ),ldc ) + call stdlib_${ci}$geru( l, n, -tau, v, incv, work, 1, c( m-l+1, 1 ),ldc ) end if else ! form c * h if( tau/=czero ) then ! w( 1:m ) = c( 1:m, 1 ) - call stdlib_wcopy( m, c, 1, work, 1 ) + call stdlib_${ci}$copy( m, c, 1, work, 1 ) ! w( 1:m ) = w( 1:m ) + c( 1:m, n-l+1:n, 1:n ) * v( 1:l ) - call stdlib_wgemv( 'NO TRANSPOSE', m, l, cone, c( 1, n-l+1 ), ldc,v, incv, cone, & + call stdlib_${ci}$gemv( 'NO TRANSPOSE', m, l, cone, c( 1, n-l+1 ), ldc,v, incv, cone, & work, 1 ) ! c( 1:m, 1 ) = c( 1:m, 1 ) - tau * w( 1:m ) - call stdlib_waxpy( m, -tau, work, 1, c, 1 ) + call stdlib_${ci}$axpy( m, -tau, work, 1, c, 1 ) ! c( 1:m, n-l+1:n ) = c( 1:m, n-l+1:n ) - ... ! tau * w( 1:m ) * v( 1:l )**h - call stdlib_wgerc( m, l, -tau, work, 1, v, incv, c( 1, n-l+1 ),ldc ) + call stdlib_${ci}$gerc( m, l, -tau, work, 1, v, incv, c( 1, n-l+1 ),ldc ) end if end if return - end subroutine stdlib_wlarz + end subroutine stdlib_${ci}$larz - pure subroutine stdlib_wlarzb( side, trans, direct, storev, m, n, k, l, v,ldv, t, ldt, c, & + pure subroutine stdlib_${ci}$larzb( side, trans, direct, storev, m, n, k, l, v,ldv, t, ldt, c, & !! ZLARZB: applies a complex block reflector H or its transpose H**H !! to a complex distributed M-by-N C from the left or the right. !! Currently, only STOREV = 'R' and DIRECT = 'B' are supported. @@ -51320,8 +51322,8 @@ module stdlib_linalg_lapack_w character, intent(in) :: direct, side, storev, trans integer(ilp), intent(in) :: k, l, ldc, ldt, ldv, ldwork, m, n ! Array Arguments - complex(qp), intent(inout) :: c(ldc,*), t(ldt,*), v(ldv,*) - complex(qp), intent(out) :: work(ldwork,*) + complex(${ck}$), intent(inout) :: c(ldc,*), t(ldt,*), v(ldv,*) + complex(${ck}$), intent(out) :: work(ldwork,*) ! ===================================================================== ! Local Scalars @@ -51350,14 +51352,14 @@ module stdlib_linalg_lapack_w ! form h * c or h**h * c ! w( 1:n, 1:k ) = c( 1:k, 1:n )**h do j = 1, k - call stdlib_wcopy( n, c( j, 1 ), ldc, work( 1, j ), 1 ) + call stdlib_${ci}$copy( n, c( j, 1 ), ldc, work( 1, j ), 1 ) end do ! w( 1:n, 1:k ) = w( 1:n, 1:k ) + ... ! c( m-l+1:m, 1:n )**h * v( 1:k, 1:l )**t - if( l>0 )call stdlib_wgemm( 'TRANSPOSE', 'CONJUGATE TRANSPOSE', n, k, l,cone, c( m-& + if( l>0 )call stdlib_${ci}$gemm( 'TRANSPOSE', 'CONJUGATE TRANSPOSE', n, k, l,cone, c( m-& l+1, 1 ), ldc, v, ldv, cone, work,ldwork ) ! w( 1:n, 1:k ) = w( 1:n, 1:k ) * t**t or w( 1:m, 1:k ) * t - call stdlib_wtrmm( 'RIGHT', 'LOWER', transt, 'NON-UNIT', n, k, cone, t,ldt, work, & + call stdlib_${ci}$trmm( 'RIGHT', 'LOWER', transt, 'NON-UNIT', n, k, cone, t,ldt, work, & ldwork ) ! c( 1:k, 1:n ) = c( 1:k, 1:n ) - w( 1:n, 1:k )**h do j = 1, n @@ -51367,27 +51369,27 @@ module stdlib_linalg_lapack_w end do ! c( m-l+1:m, 1:n ) = c( m-l+1:m, 1:n ) - ... ! v( 1:k, 1:l )**h * w( 1:n, 1:k )**h - if( l>0 )call stdlib_wgemm( 'TRANSPOSE', 'TRANSPOSE', l, n, k, -cone, v, ldv,work, & + if( l>0 )call stdlib_${ci}$gemm( 'TRANSPOSE', 'TRANSPOSE', l, n, k, -cone, v, ldv,work, & ldwork, cone, c( m-l+1, 1 ), ldc ) else if( stdlib_lsame( side, 'R' ) ) then ! form c * h or c * h**h ! w( 1:m, 1:k ) = c( 1:m, 1:k ) do j = 1, k - call stdlib_wcopy( m, c( 1, j ), 1, work( 1, j ), 1 ) + call stdlib_${ci}$copy( m, c( 1, j ), 1, work( 1, j ), 1 ) end do ! w( 1:m, 1:k ) = w( 1:m, 1:k ) + ... ! c( 1:m, n-l+1:n ) * v( 1:k, 1:l )**h - if( l>0 )call stdlib_wgemm( 'NO TRANSPOSE', 'TRANSPOSE', m, k, l, cone,c( 1, n-l+1 )& + if( l>0 )call stdlib_${ci}$gemm( 'NO TRANSPOSE', 'TRANSPOSE', m, k, l, cone,c( 1, n-l+1 )& , ldc, v, ldv, cone, work, ldwork ) ! w( 1:m, 1:k ) = w( 1:m, 1:k ) * conjg( t ) or ! w( 1:m, 1:k ) * t**h do j = 1, k - call stdlib_wlacgv( k-j+1, t( j, j ), 1 ) + call stdlib_${ci}$lacgv( k-j+1, t( j, j ), 1 ) end do - call stdlib_wtrmm( 'RIGHT', 'LOWER', trans, 'NON-UNIT', m, k, cone, t,ldt, work, & + call stdlib_${ci}$trmm( 'RIGHT', 'LOWER', trans, 'NON-UNIT', m, k, cone, t,ldt, work, & ldwork ) do j = 1, k - call stdlib_wlacgv( k-j+1, t( j, j ), 1 ) + call stdlib_${ci}$lacgv( k-j+1, t( j, j ), 1 ) end do ! c( 1:m, 1:k ) = c( 1:m, 1:k ) - w( 1:m, 1:k ) do j = 1, k @@ -51398,19 +51400,19 @@ module stdlib_linalg_lapack_w ! c( 1:m, n-l+1:n ) = c( 1:m, n-l+1:n ) - ... ! w( 1:m, 1:k ) * conjg( v( 1:k, 1:l ) ) do j = 1, l - call stdlib_wlacgv( k, v( 1, j ), 1 ) + call stdlib_${ci}$lacgv( k, v( 1, j ), 1 ) end do - if( l>0 )call stdlib_wgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', m, l, k, -cone,work, & + if( l>0 )call stdlib_${ci}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', m, l, k, -cone,work, & ldwork, v, ldv, cone, c( 1, n-l+1 ), ldc ) do j = 1, l - call stdlib_wlacgv( k, v( 1, j ), 1 ) + call stdlib_${ci}$lacgv( k, v( 1, j ), 1 ) end do end if return - end subroutine stdlib_wlarzb + end subroutine stdlib_${ci}$larzb - pure subroutine stdlib_wlarzt( direct, storev, n, k, v, ldv, tau, t, ldt ) + pure subroutine stdlib_${ci}$larzt( direct, storev, n, k, v, ldv, tau, t, ldt ) !! ZLARZT: forms the triangular factor T of a complex block reflector !! H of order > n, which is defined as a product of k elementary !! reflectors. @@ -51430,9 +51432,9 @@ module stdlib_linalg_lapack_w character, intent(in) :: direct, storev integer(ilp), intent(in) :: k, ldt, ldv, n ! Array Arguments - complex(qp), intent(out) :: t(ldt,*) - complex(qp), intent(in) :: tau(*) - complex(qp), intent(inout) :: v(ldv,*) + complex(${ck}$), intent(out) :: t(ldt,*) + complex(${ck}$), intent(in) :: tau(*) + complex(${ck}$), intent(inout) :: v(ldv,*) ! ===================================================================== ! Local Scalars @@ -51459,22 +51461,22 @@ module stdlib_linalg_lapack_w ! general case if( i tbig) then abig = abig + (ax*sbig)**2 notbig = .false. @@ -52081,10 +52083,10 @@ module stdlib_linalg_lapack_w sumsq = amed end if return - end subroutine stdlib_wlassq + end subroutine stdlib_${ci}$lassq - pure subroutine stdlib_wlaswlq( m, n, mb, nb, a, lda, t, ldt, work, lwork,info) + pure subroutine stdlib_${ci}$laswlq( m, n, mb, nb, a, lda, t, ldt, work, lwork,info) !! ZLASWLQ: computes a blocked Tall-Skinny LQ factorization of !! a complexx M-by-N matrix A for M <= N: !! A = ( L 0 ) * Q, @@ -52102,8 +52104,8 @@ module stdlib_linalg_lapack_w integer(ilp), intent(out) :: info integer(ilp), intent(in) :: lda, m, n, mb, nb, lwork, ldt ! Array Arguments - complex(qp), intent(inout) :: a(lda,*) - complex(qp), intent(out) :: work(*), t(ldt,*) + complex(${ck}$), intent(inout) :: a(lda,*) + complex(${ck}$), intent(out) :: work(*), t(ldt,*) ! ===================================================================== ! Local Scalars logical(lk) :: lquery @@ -52144,31 +52146,31 @@ module stdlib_linalg_lapack_w end if ! the lq decomposition if((m>=n).or.(nb<=m).or.(nb>=n)) then - call stdlib_wgelqt( m, n, mb, a, lda, t, ldt, work, info) + call stdlib_${ci}$gelqt( m, n, mb, a, lda, t, ldt, work, info) return end if kk = mod((n-m),(nb-m)) ii=n-kk+1 ! compute the lq factorization of the first block a(1:m,1:nb) - call stdlib_wgelqt( m, nb, mb, a(1,1), lda, t, ldt, work, info) + call stdlib_${ci}$gelqt( m, nb, mb, a(1,1), lda, t, ldt, work, info) ctr = 1 do i = nb+1, ii-nb+m , (nb-m) ! compute the qr factorization of the current block a(1:m,i:i+nb-m) - call stdlib_wtplqt( m, nb-m, 0, mb, a(1,1), lda, a( 1, i ),lda, t(1, ctr * m + 1),& + call stdlib_${ci}$tplqt( m, nb-m, 0, mb, a(1,1), lda, a( 1, i ),lda, t(1, ctr * m + 1),& ldt, work, info ) ctr = ctr + 1 end do ! compute the qr factorization of the last block a(1:m,ii:n) if (ii<=n) then - call stdlib_wtplqt( m, kk, 0, mb, a(1,1), lda, a( 1, ii ),lda, t(1, ctr * m + 1), & + call stdlib_${ci}$tplqt( m, kk, 0, mb, a(1,1), lda, a( 1, ii ),lda, t(1, ctr * m + 1), & ldt,work, info ) end if work( 1 ) = m * mb return - end subroutine stdlib_wlaswlq + end subroutine stdlib_${ci}$laswlq - pure subroutine stdlib_wlaswp( n, a, lda, k1, k2, ipiv, incx ) + pure subroutine stdlib_${ci}$laswp( n, a, lda, k1, k2, ipiv, incx ) !! ZLASWP: performs a series of row interchanges on the matrix A. !! One row interchange is initiated for each of rows K1 through K2 of A. ! -- lapack auxiliary routine -- @@ -52178,11 +52180,11 @@ module stdlib_linalg_lapack_w integer(ilp), intent(in) :: incx, k1, k2, lda, n ! Array Arguments integer(ilp), intent(in) :: ipiv(*) - complex(qp), intent(inout) :: a(lda,*) + complex(${ck}$), intent(inout) :: a(lda,*) ! ===================================================================== ! Local Scalars integer(ilp) :: i, i1, i2, inc, ip, ix, ix0, j, k, n32 - complex(qp) :: temp + complex(${ck}$) :: temp ! Executable Statements ! interchange row i with row ipiv(k1+(i-k1)*abs(incx)) for each of rows ! k1 through k2. @@ -52232,10 +52234,10 @@ module stdlib_linalg_lapack_w end do end if return - end subroutine stdlib_wlaswp + end subroutine stdlib_${ci}$laswp - pure subroutine stdlib_wlasyf( uplo, n, nb, kb, a, lda, ipiv, w, ldw, info ) + pure subroutine stdlib_${ci}$lasyf( uplo, n, nb, kb, a, lda, ipiv, w, ldw, info ) !! ZLASYF: computes a partial factorization of a complex symmetric matrix !! A using the Bunch-Kaufman diagonal pivoting method. The partial !! factorization has the form: @@ -52258,24 +52260,24 @@ module stdlib_linalg_lapack_w integer(ilp), intent(in) :: lda, ldw, n, nb ! Array Arguments integer(ilp), intent(out) :: ipiv(*) - complex(qp), intent(inout) :: a(lda,*) - complex(qp), intent(out) :: w(ldw,*) + complex(${ck}$), intent(inout) :: a(lda,*) + complex(${ck}$), intent(out) :: w(ldw,*) ! ===================================================================== ! Parameters - real(qp), parameter :: sevten = 17.0e+0_qp + real(${ck}$), parameter :: sevten = 17.0e+0_${ck}$ ! Local Scalars integer(ilp) :: imax, j, jb, jj, jmax, jp, k, kk, kkw, kp, kstep, kw - real(qp) :: absakk, alpha, colmax, rowmax - complex(qp) :: d11, d21, d22, r1, t, z + real(${ck}$) :: absakk, alpha, colmax, rowmax + complex(${ck}$) :: d11, d21, d22, r1, t, z ! Intrinsic Functions intrinsic :: abs,real,aimag,max,min,sqrt ! Statement Functions - real(qp) :: cabs1 + real(${ck}$) :: cabs1 ! Statement Function Definitions - cabs1( z ) = abs( real( z,KIND=qp) ) + abs( aimag( z ) ) + cabs1( z ) = abs( real( z,KIND=${ck}$) ) + abs( aimag( z ) ) ! Executable Statements info = 0 ! initialize alpha for use in choosing pivot block size. @@ -52292,8 +52294,8 @@ module stdlib_linalg_lapack_w ! exit from loop if( ( k<=n-nb+1 .and. nb1 ) then - imax = stdlib_iwamax( k-1, w( 1, kw ), 1 ) + imax = stdlib_i${ci}$amax( k-1, w( 1, kw ), 1 ) colmax = cabs1( w( imax, kw ) ) else colmax = zero @@ -52316,17 +52318,17 @@ module stdlib_linalg_lapack_w kp = k else ! copy column imax to column kw-1 of w and update it - call stdlib_wcopy( imax, a( 1, imax ), 1, w( 1, kw-1 ), 1 ) - call stdlib_wcopy( k-imax, a( imax, imax+1 ), lda,w( imax+1, kw-1 ), 1 ) + call stdlib_${ci}$copy( imax, a( 1, imax ), 1, w( 1, kw-1 ), 1 ) + call stdlib_${ci}$copy( k-imax, a( imax, imax+1 ), lda,w( imax+1, kw-1 ), 1 ) - if( k1 ) then - jmax = stdlib_iwamax( imax-1, w( 1, kw-1 ), 1 ) + jmax = stdlib_i${ci}$amax( imax-1, w( 1, kw-1 ), 1 ) rowmax = max( rowmax, cabs1( w( jmax, kw-1 ) ) ) end if if( absakk>=alpha*colmax*( colmax / rowmax ) ) then @@ -52337,7 +52339,7 @@ module stdlib_linalg_lapack_w ! pivot block kp = imax ! copy column kw-1 of w to column kw of w - call stdlib_wcopy( k, w( 1, kw-1 ), 1, w( 1, kw ), 1 ) + call stdlib_${ci}$copy( k, w( 1, kw-1 ), 1, w( 1, kw ), 1 ) else ! interchange rows and columns k-1 and imax, use 2-by-2 ! pivot block @@ -52358,14 +52360,14 @@ module stdlib_linalg_lapack_w ! (or k and k-1 for 2-by-2 pivot) of a, since these columns ! will be later overwritten. a( kp, kp ) = a( kk, kk ) - call stdlib_wcopy( kk-1-kp, a( kp+1, kk ), 1, a( kp, kp+1 ),lda ) - if( kp>1 )call stdlib_wcopy( kp-1, a( 1, kk ), 1, a( 1, kp ), 1 ) + call stdlib_${ci}$copy( kk-1-kp, a( kp+1, kk ), 1, a( kp, kp+1 ),lda ) + if( kp>1 )call stdlib_${ci}$copy( kp-1, a( 1, kk ), 1, a( 1, kp ), 1 ) ! interchange rows kk and kp in last k+1 to n columns of a ! (columns k (or k and k-1 for 2-by-2 pivot) of a will be ! later overwritten). interchange rows kk and kp ! in last kkw to nb columns of w. - if( k=nb .and. nbn )go to 90 ! copy column k of a to column k of w and update it - call stdlib_wcopy( n-k+1, a( k, k ), 1, w( k, k ), 1 ) - call stdlib_wgemv( 'NO TRANSPOSE', n-k+1, k-1, -cone, a( k, 1 ), lda,w( k, 1 ), ldw,& + call stdlib_${ci}$copy( n-k+1, a( k, k ), 1, w( k, k ), 1 ) + call stdlib_${ci}$gemv( 'NO TRANSPOSE', n-k+1, k-1, -cone, a( k, 1 ), lda,w( k, 1 ), ldw,& cone, w( k, k ), 1 ) kstep = 1 ! determine rows and columns to be interchanged and whether @@ -52495,7 +52497,7 @@ module stdlib_linalg_lapack_w absakk = cabs1( w( k, k ) ) ! imax is the row-index of the largest off-diagonal element in if( k=alpha*colmax*( colmax / rowmax ) ) then @@ -52530,7 +52532,7 @@ module stdlib_linalg_lapack_w ! pivot block kp = imax ! copy column k+1 of w to column k of w - call stdlib_wcopy( n-k+1, w( k, k+1 ), 1, w( k, k ), 1 ) + call stdlib_${ci}$copy( n-k+1, w( k, k+1 ), 1, w( k, k ), 1 ) else ! interchange rows and columns k+1 and imax, use 2-by-2 ! pivot block @@ -52549,15 +52551,15 @@ module stdlib_linalg_lapack_w ! (or k and k+1 for 2-by-2 pivot) of a, since these columns ! will be later overwritten. a( kp, kp ) = a( kk, kk ) - call stdlib_wcopy( kp-kk-1, a( kk+1, kk ), 1, a( kp, kk+1 ),lda ) - if( kp1 )call stdlib_wswap( k-1, a( kk, 1 ), lda, a( kp, 1 ), lda ) - call stdlib_wswap( kk, w( kk, 1 ), ldw, w( kp, 1 ), ldw ) + if( k>1 )call stdlib_${ci}$swap( k-1, a( kk, 1 ), lda, a( kp, 1 ), lda ) + call stdlib_${ci}$swap( kk, w( kk, 1 ), ldw, w( kp, 1 ), ldw ) end if if( kstep==1 ) then ! 1-by-1 pivot block d(k): column k of w now holds @@ -52569,10 +52571,10 @@ module stdlib_linalg_lapack_w ! and not stored) ! a(k,k) := d(k,k) = w(k,k) ! a(k+1:n,k) := l(k+1:n,k) = w(k+1:n,k)/d(k,k) - call stdlib_wcopy( n-k+1, w( k, k ), 1, a( k, k ), 1 ) + call stdlib_${ci}$copy( n-k+1, w( k, k ), 1, a( k, k ), 1 ) if( k=1 )call stdlib_wswap( j, a( jp, 1 ), lda, a( jj, 1 ), lda ) + if( jp/=jj .and. j>=1 )call stdlib_${ci}$swap( j, a( jp, 1 ), lda, a( jj, 1 ), lda ) if( j>1 )go to 120 ! set kb to the number of columns factorized kb = k - 1 end if return - end subroutine stdlib_wlasyf + end subroutine stdlib_${ci}$lasyf - pure subroutine stdlib_wlasyf_aa( uplo, j1, m, nb, a, lda, ipiv,h, ldh, work ) + pure subroutine stdlib_${ci}$lasyf_aa( uplo, j1, m, nb, a, lda, ipiv,h, ldh, work ) !! DLATRF_AA factorizes a panel of a complex symmetric matrix A using !! the Aasen's algorithm. The panel consists of a set of NB rows of A !! when UPLO is U, or a set of NB columns when UPLO is L. @@ -52694,13 +52696,13 @@ module stdlib_linalg_lapack_w integer(ilp), intent(in) :: m, nb, j1, lda, ldh ! Array Arguments integer(ilp), intent(out) :: ipiv(*) - complex(qp), intent(inout) :: a(lda,*), h(ldh,*) - complex(qp), intent(out) :: work(*) + complex(${ck}$), intent(inout) :: a(lda,*), h(ldh,*) + complex(${ck}$), intent(out) :: work(*) ! ===================================================================== ! Local Scalars integer(ilp) :: j, k, k1, i1, i2, mj - complex(qp) :: piv, alpha + complex(${ck}$) :: piv, alpha ! Intrinsic Functions intrinsic :: max ! Executable Statements @@ -52715,7 +52717,7 @@ module stdlib_linalg_lapack_w 10 continue if ( j>min(m, nb) )go to 20 ! k is the column to be factorized - ! when being called from stdlib_wsytrf_aa, + ! when being called from stdlib_${ci}$sytrf_aa, ! > for the first block column, j1 is 1, hence j1+j-1 is j, ! > for the rest of the columns, j1 is 2, and j1+j-1 is j+1, k = j1+j-1 @@ -52733,16 +52735,16 @@ module stdlib_linalg_lapack_w ! columns ! > for the rest of the columns, k is j+1, skipping only the ! first column - call stdlib_wgemv( 'NO TRANSPOSE', mj, j-k1,-cone, h( j, k1 ), ldh,a( 1, j ), 1,& + call stdlib_${ci}$gemv( 'NO TRANSPOSE', mj, j-k1,-cone, h( j, k1 ), ldh,a( 1, j ), 1,& cone, h( j, j ), 1 ) end if ! copy h(i:m, i) into work - call stdlib_wcopy( mj, h( j, j ), 1, work( 1 ), 1 ) + call stdlib_${ci}$copy( mj, h( j, j ), 1, work( 1 ), 1 ) if( j>k1 ) then ! compute work := work - l(j-1, j:m) * t(j-1,j), ! where a(j-1, j) stores t(j-1, j) and a(j-2, j:m) stores u(j-1, j:m) alpha = -a( k-1, j ) - call stdlib_waxpy( mj, alpha, a( k-2, j ), lda, work( 1 ), 1 ) + call stdlib_${ci}$axpy( mj, alpha, a( k-2, j ), lda, work( 1 ), 1 ) end if ! set a(j, j) = t(j, j) a( k, j ) = work( 1 ) @@ -52751,10 +52753,10 @@ module stdlib_linalg_lapack_w ! where a(j, j) stores t(j, j) and a(j-1, (j+1):m) stores u(j, (j+1):m) if( k>1 ) then alpha = -a( k, j ) - call stdlib_waxpy( m-j, alpha, a( k-1, j+1 ), lda,work( 2 ), 1 ) + call stdlib_${ci}$axpy( m-j, alpha, a( k-1, j+1 ), lda,work( 2 ), 1 ) endif ! find max(|work(2:m)|) - i2 = stdlib_iwamax( m-j, work( 2 ), 1 ) + 1 + i2 = stdlib_i${ci}$amax( m-j, work( 2 ), 1 ) + 1 piv = work( i2 ) ! apply symmetric pivot if( (i2/=2) .and. (piv/=0) ) then @@ -52765,22 +52767,22 @@ module stdlib_linalg_lapack_w ! swap a(i1, i1+1:m) with a(i1+1:m, i2) i1 = i1+j-1 i2 = i2+j-1 - call stdlib_wswap( i2-i1-1, a( j1+i1-1, i1+1 ), lda,a( j1+i1, i2 ), 1 ) + call stdlib_${ci}$swap( i2-i1-1, a( j1+i1-1, i1+1 ), lda,a( j1+i1, i2 ), 1 ) ! swap a(i1, i2+1:m) with a(i2, i2+1:m) - if( i2(k1-1) ) then ! swap l(1:i1-1, i1) with l(1:i1-1, i2), ! skipping the first column - call stdlib_wswap( i1-k1+1, a( 1, i1 ), 1,a( 1, i2 ), 1 ) + call stdlib_${ci}$swap( i1-k1+1, a( 1, i1 ), 1,a( 1, i2 ), 1 ) end if else ipiv( j+1 ) = j+1 @@ -52789,17 +52791,17 @@ module stdlib_linalg_lapack_w a( k, j+1 ) = work( 2 ) if( jmin( m, nb ) )go to 40 ! k is the column to be factorized - ! when being called from stdlib_wsytrf_aa, + ! when being called from stdlib_${ci}$sytrf_aa, ! > for the first block column, j1 is 1, hence j1+j-1 is j, ! > for the rest of the columns, j1 is 2, and j1+j-1 is j+1, k = j1+j-1 @@ -52832,16 +52834,16 @@ module stdlib_linalg_lapack_w ! columns ! > for the rest of the columns, k is j+1, skipping only the ! first column - call stdlib_wgemv( 'NO TRANSPOSE', mj, j-k1,-cone, h( j, k1 ), ldh,a( j, 1 ), & + call stdlib_${ci}$gemv( 'NO TRANSPOSE', mj, j-k1,-cone, h( j, k1 ), ldh,a( j, 1 ), & lda,cone, h( j, j ), 1 ) end if ! copy h(j:m, j) into work - call stdlib_wcopy( mj, h( j, j ), 1, work( 1 ), 1 ) + call stdlib_${ci}$copy( mj, h( j, j ), 1, work( 1 ), 1 ) if( j>k1 ) then ! compute work := work - l(j:m, j-1) * t(j-1,j), ! where a(j-1, j) = t(j-1, j) and a(j, j-2) = l(j, j-1) alpha = -a( j, k-1 ) - call stdlib_waxpy( mj, alpha, a( j, k-2 ), 1, work( 1 ), 1 ) + call stdlib_${ci}$axpy( mj, alpha, a( j, k-2 ), 1, work( 1 ), 1 ) end if ! set a(j, j) = t(j, j) a( j, k ) = work( 1 ) @@ -52850,10 +52852,10 @@ module stdlib_linalg_lapack_w ! where a(j, j) = t(j, j) and a((j+1):m, j-1) = l((j+1):m, j) if( k>1 ) then alpha = -a( j, k ) - call stdlib_waxpy( m-j, alpha, a( j+1, k-1 ), 1,work( 2 ), 1 ) + call stdlib_${ci}$axpy( m-j, alpha, a( j+1, k-1 ), 1,work( 2 ), 1 ) endif ! find max(|work(2:m)|) - i2 = stdlib_iwamax( m-j, work( 2 ), 1 ) + 1 + i2 = stdlib_i${ci}$amax( m-j, work( 2 ), 1 ) + 1 piv = work( i2 ) ! apply symmetric pivot if( (i2/=2) .and. (piv/=0) ) then @@ -52864,22 +52866,22 @@ module stdlib_linalg_lapack_w ! swap a(i1+1:m, i1) with a(i2, i1+1:m) i1 = i1+j-1 i2 = i2+j-1 - call stdlib_wswap( i2-i1-1, a( i1+1, j1+i1-1 ), 1,a( i2, j1+i1 ), lda ) + call stdlib_${ci}$swap( i2-i1-1, a( i1+1, j1+i1-1 ), 1,a( i2, j1+i1 ), lda ) ! swap a(i2+1:m, i1) with a(i2+1:m, i2) - if( i2(k1-1) ) then ! swap l(1:i1-1, i1) with l(1:i1-1, i2), ! skipping the first column - call stdlib_wswap( i1-k1+1, a( i1, 1 ), lda,a( i2, 1 ), lda ) + call stdlib_${ci}$swap( i1-k1+1, a( i1, 1 ), lda,a( i2, 1 ), lda ) end if else ipiv( j+1 ) = j+1 @@ -52888,17 +52890,17 @@ module stdlib_linalg_lapack_w a( j+1, k ) = work( 2 ) if( j1 ) then - imax = stdlib_iwamax( k-1, w( 1, kw ), 1 ) + imax = stdlib_i${ci}$amax( k-1, w( 1, kw ), 1 ) colmax = cabs1( w( imax, kw ) ) else colmax = zero @@ -52994,7 +52996,7 @@ module stdlib_linalg_lapack_w ! column k is zero or underflow: set info and continue if( info==0 )info = k kp = k - call stdlib_wcopy( k, w( 1, kw ), 1, a( 1, k ), 1 ) + call stdlib_${ci}$copy( k, w( 1, kw ), 1, a( 1, k ), 1 ) ! set e( k ) to zero if( k>1 )e( k ) = czero else @@ -53011,22 +53013,22 @@ module stdlib_linalg_lapack_w 12 continue ! begin pivot search loop body ! copy column imax to column kw-1 of w and update it - call stdlib_wcopy( imax, a( 1, imax ), 1, w( 1, kw-1 ), 1 ) - call stdlib_wcopy( k-imax, a( imax, imax+1 ), lda,w( imax+1, kw-1 ), 1 ) + call stdlib_${ci}$copy( imax, a( 1, imax ), 1, w( 1, kw-1 ), 1 ) + call stdlib_${ci}$copy( k-imax, a( imax, imax+1 ), lda,w( imax+1, kw-1 ), 1 ) - if( k1 ) then - itemp = stdlib_iwamax( imax-1, w( 1, kw-1 ), 1 ) + itemp = stdlib_i${ci}$amax( imax-1, w( 1, kw-1 ), 1 ) dtemp = cabs1( w( itemp, kw-1 ) ) if( dtemp>rowmax ) then rowmax = dtemp @@ -53041,7 +53043,7 @@ module stdlib_linalg_lapack_w ! use 1-by-1 pivot block kp = imax ! copy column kw-1 of w to column kw of w - call stdlib_wcopy( k, w( 1, kw-1 ), 1, w( 1, kw ), 1 ) + call stdlib_${ci}$copy( k, w( 1, kw-1 ), 1, w( 1, kw ), 1 ) done = .true. ! equivalent to testing for rowmax==colmax, ! (used to handle nan and inf) @@ -53057,7 +53059,7 @@ module stdlib_linalg_lapack_w colmax = rowmax imax = jmax ! copy updated jmaxth (next imaxth) column to kth of w - call stdlib_wcopy( k, w( 1, kw-1 ), 1, w( 1, kw ), 1 ) + call stdlib_${ci}$copy( k, w( 1, kw-1 ), 1, w( 1, kw ), 1 ) end if ! end pivot search loop body if( .not. done ) goto 12 @@ -53068,34 +53070,34 @@ module stdlib_linalg_lapack_w kkw = nb + kk - n if( ( kstep==2 ) .and. ( p/=k ) ) then ! copy non-updated column k to column p - call stdlib_wcopy( k-p, a( p+1, k ), 1, a( p, p+1 ), lda ) - call stdlib_wcopy( p, a( 1, k ), 1, a( 1, p ), 1 ) + call stdlib_${ci}$copy( k-p, a( p+1, k ), 1, a( p, p+1 ), lda ) + call stdlib_${ci}$copy( p, a( 1, k ), 1, a( 1, p ), 1 ) ! interchange rows k and p in last n-k+1 columns of a ! and last n-k+2 columns of w - call stdlib_wswap( n-k+1, a( k, k ), lda, a( p, k ), lda ) - call stdlib_wswap( n-kk+1, w( k, kkw ), ldw, w( p, kkw ), ldw ) + call stdlib_${ci}$swap( n-k+1, a( k, k ), lda, a( p, k ), lda ) + call stdlib_${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_wcopy( k-1-kp, a( kp+1, kk ), 1, a( kp, kp+1 ),lda ) - call stdlib_wcopy( kp, a( 1, kk ), 1, a( 1, kp ), 1 ) + call stdlib_${ci}$copy( k-1-kp, a( kp+1, kk ), 1, a( kp, kp+1 ),lda ) + call stdlib_${ci}$copy( kp, a( 1, kk ), 1, a( 1, kp ), 1 ) ! interchange rows kk and kp in last n-kk+1 columns ! of a and w - call stdlib_wswap( n-kk+1, a( kk, kk ), lda, a( kp, kk ), lda ) - call stdlib_wswap( n-kk+1, w( kk, kkw ), ldw, w( kp, kkw ),ldw ) + call stdlib_${ci}$swap( n-kk+1, a( kk, kk ), lda, a( kp, kk ), lda ) + call stdlib_${ci}$swap( n-kk+1, w( kk, kkw ), ldw, w( kp, kkw ),ldw ) end if if( kstep==1 ) 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_wcopy( k, w( 1, kw ), 1, a( 1, k ), 1 ) + call stdlib_${ci}$copy( k, w( 1, kw ), 1, a( 1, k ), 1 ) if( k>1 ) then if( cabs1( a( k, k ) )>=sfmin ) then r1 = cone / a( k, k ) - call stdlib_wscal( k-1, r1, a( 1, k ), 1 ) + call stdlib_${ci}$scal( k-1, r1, a( 1, k ), 1 ) else if( a( k, k )/=czero ) then do ii = 1, k - 1 a( ii, k ) = a( ii, k ) / a( k, k ) @@ -53150,11 +53152,11 @@ module stdlib_linalg_lapack_w jb = min( nb, k-j+1 ) ! update the upper triangle of the diagonal block do jj = j, j + jb - 1 - call stdlib_wgemv( 'NO TRANSPOSE', jj-j+1, n-k, -cone,a( j, k+1 ), lda, w( jj,& + call stdlib_${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 ) end do ! update the rectangular superdiagonal block - if( j>=2 )call stdlib_wgemm( 'NO TRANSPOSE', 'TRANSPOSE', j-1, jb,n-k, -cone, a( & + if( j>=2 )call stdlib_${ci}$gemm( 'NO TRANSPOSE', 'TRANSPOSE', j-1, jb,n-k, -cone, a( & 1, k+1 ), lda, w( j, kw+1 ),ldw, cone, a( 1, j ), lda ) end do ! set kb to the number of columns factorized @@ -53173,8 +53175,8 @@ module stdlib_linalg_lapack_w kstep = 1 p = k ! copy column k of a to column k of w and update it - call stdlib_wcopy( n-k+1, a( k, k ), 1, w( k, k ), 1 ) - if( k>1 )call stdlib_wgemv( 'NO TRANSPOSE', n-k+1, k-1, -cone, a( k, 1 ),lda, w( k, & + call stdlib_${ci}$copy( n-k+1, a( k, k ), 1, w( k, k ), 1 ) + if( k>1 )call stdlib_${ci}$gemv( 'NO TRANSPOSE', n-k+1, k-1, -cone, a( k, 1 ),lda, w( k, & 1 ), ldw, cone, w( k, k ), 1 ) ! determine rows and columns to be interchanged and whether ! a 1-by-1 or 2-by-2 pivot block will be used @@ -53183,7 +53185,7 @@ module stdlib_linalg_lapack_w ! column k, and colmax is its absolute value. ! determine both colmax and imax. if( k1 )call stdlib_wgemv( 'NO TRANSPOSE', n-k+1, k-1, -cone,a( k, 1 ), & + call stdlib_${ci}$copy( imax-k, a( imax, k ), lda, w( k, k+1 ), 1) + call stdlib_${ci}$copy( n-imax+1, a( imax, imax ), 1,w( imax, k+1 ), 1 ) + if( k>1 )call stdlib_${ci}$gemv( 'NO TRANSPOSE', n-k+1, k-1, -cone,a( k, 1 ), & lda, w( imax, 1 ), ldw,cone, w( k, k+1 ), 1 ) ! 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 + stdlib_iwamax( imax-k, w( k, k+1 ), 1 ) + jmax = k - 1 + stdlib_i${ci}$amax( imax-k, w( k, k+1 ), 1 ) rowmax = cabs1( w( jmax, k+1 ) ) else rowmax = zero end if if( imaxrowmax ) then rowmax = dtemp @@ -53238,7 +53240,7 @@ module stdlib_linalg_lapack_w ! use 1-by-1 pivot block kp = imax ! copy column k+1 of w to column k of w - call stdlib_wcopy( n-k+1, w( k, k+1 ), 1, w( k, k ), 1 ) + call stdlib_${ci}$copy( n-k+1, w( k, k+1 ), 1, w( k, k ), 1 ) done = .true. ! equivalent to testing for rowmax==colmax, ! (used to handle nan and inf) @@ -53254,7 +53256,7 @@ module stdlib_linalg_lapack_w colmax = rowmax imax = jmax ! copy updated jmaxth (next imaxth) column to kth of w - call stdlib_wcopy( n-k+1, w( k, k+1 ), 1, w( k, k ), 1 ) + call stdlib_${ci}$copy( n-k+1, w( k, k+1 ), 1, w( k, k ), 1 ) end if ! end pivot search loop body if( .not. done ) goto 72 @@ -53263,33 +53265,33 @@ module stdlib_linalg_lapack_w kk = k + kstep - 1 if( ( kstep==2 ) .and. ( p/=k ) ) then ! copy non-updated column k to column p - call stdlib_wcopy( p-k, a( k, k ), 1, a( p, k ), lda ) - call stdlib_wcopy( n-p+1, a( p, k ), 1, a( p, p ), 1 ) + call stdlib_${ci}$copy( p-k, a( k, k ), 1, a( p, k ), lda ) + call stdlib_${ci}$copy( n-p+1, a( p, k ), 1, a( p, p ), 1 ) ! interchange rows k and p in first k columns of a ! and first k+1 columns of w - call stdlib_wswap( k, a( k, 1 ), lda, a( p, 1 ), lda ) - call stdlib_wswap( kk, w( k, 1 ), ldw, w( p, 1 ), ldw ) + call stdlib_${ci}$swap( k, a( k, 1 ), lda, a( p, 1 ), lda ) + call stdlib_${ci}$swap( kk, w( k, 1 ), ldw, w( p, 1 ), 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_wcopy( kp-k-1, a( k+1, kk ), 1, a( kp, k+1 ), lda ) - call stdlib_wcopy( n-kp+1, a( kp, kk ), 1, a( kp, kp ), 1 ) + call stdlib_${ci}$copy( kp-k-1, a( k+1, kk ), 1, a( kp, k+1 ), lda ) + call stdlib_${ci}$copy( n-kp+1, a( kp, kk ), 1, a( kp, kp ), 1 ) ! interchange rows kk and kp in first kk columns of a and w - call stdlib_wswap( kk, a( kk, 1 ), lda, a( kp, 1 ), lda ) - call stdlib_wswap( kk, w( kk, 1 ), ldw, w( kp, 1 ), ldw ) + call stdlib_${ci}$swap( kk, a( kk, 1 ), lda, a( kp, 1 ), lda ) + call stdlib_${ci}$swap( kk, w( kk, 1 ), ldw, w( kp, 1 ), ldw ) end if if( kstep==1 ) 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_wcopy( n-k+1, w( k, k ), 1, a( k, k ), 1 ) + call stdlib_${ci}$copy( n-k+1, w( k, k ), 1, a( k, k ), 1 ) if( k=sfmin ) then r1 = cone / a( k, k ) - call stdlib_wscal( n-k, r1, a( k+1, k ), 1 ) + call stdlib_${ci}$scal( n-k, r1, a( k+1, k ), 1 ) else if( a( k, k )/=czero ) then do ii = k + 1, n a( ii, k ) = a( ii, k ) / a( k, k ) @@ -53343,21 +53345,21 @@ module stdlib_linalg_lapack_w jb = min( nb, n-j+1 ) ! update the lower triangle of the diagonal block do jj = j, j + jb - 1 - call stdlib_wgemv( 'NO TRANSPOSE', j+jb-jj, k-1, -cone,a( jj, 1 ), lda, w( jj,& + call stdlib_${ci}$gemv( 'NO TRANSPOSE', j+jb-jj, k-1, -cone,a( jj, 1 ), lda, w( jj,& 1 ), ldw, cone,a( jj, jj ), 1 ) end do ! update the rectangular subdiagonal block - if( j+jb<=n )call stdlib_wgemm( 'NO TRANSPOSE', 'TRANSPOSE', n-j-jb+1, jb,k-1, -& + if( j+jb<=n )call stdlib_${ci}$gemm( 'NO TRANSPOSE', 'TRANSPOSE', n-j-jb+1, jb,k-1, -& cone, a( j+jb, 1 ), lda, w( j, 1 ),ldw, cone, a( j+jb, j ), lda ) end do ! set kb to the number of columns factorized kb = k - 1 end if return - end subroutine stdlib_wlasyf_rk + end subroutine stdlib_${ci}$lasyf_rk - pure subroutine stdlib_wlasyf_rook( uplo, n, nb, kb, a, lda, ipiv, w, ldw,info ) + pure subroutine stdlib_${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: @@ -53379,11 +53381,11 @@ module stdlib_linalg_lapack_w integer(ilp), intent(in) :: lda, ldw, n, nb ! Array Arguments integer(ilp), intent(out) :: ipiv(*) - complex(qp), intent(inout) :: a(lda,*) - complex(qp), intent(out) :: w(ldw,*) + complex(${ck}$), intent(inout) :: a(lda,*) + complex(${ck}$), intent(out) :: w(ldw,*) ! ===================================================================== ! Parameters - real(qp), parameter :: sevten = 17.0e+0_qp + real(${ck}$), parameter :: sevten = 17.0e+0_${ck}$ @@ -53391,20 +53393,20 @@ module stdlib_linalg_lapack_w logical(lk) :: done integer(ilp) :: imax, itemp, j, jb, jj, jmax, jp1, jp2, k, kk, kw, kkw, kp, kstep, p, & ii - real(qp) :: absakk, alpha, colmax, rowmax, dtemp, sfmin - complex(qp) :: d11, d12, d21, d22, r1, t, z + real(${ck}$) :: absakk, alpha, colmax, rowmax, dtemp, sfmin + complex(${ck}$) :: d11, d12, d21, d22, r1, t, z ! Intrinsic Functions intrinsic :: abs,max,min,sqrt,aimag,real ! Statement Functions - real(qp) :: cabs1 + real(${ck}$) :: cabs1 ! Statement Function Definitions - cabs1( z ) = abs( real( z,KIND=qp) ) + abs( aimag( z ) ) + cabs1( z ) = abs( real( z,KIND=${ck}$) ) + abs( aimag( z ) ) ! Executable Statements info = 0 ! initialize alpha for use in choosing pivot block size. alpha = ( one+sqrt( sevten ) ) / eight ! compute machine safe minimum - sfmin = stdlib_qlamch( 'S' ) + sfmin = stdlib_${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 @@ -53419,8 +53421,8 @@ module stdlib_linalg_lapack_w kstep = 1 p = k ! copy column k of a to column kw of w and update it - call stdlib_wcopy( k, a( 1, k ), 1, w( 1, kw ), 1 ) - if( k1 ) then - imax = stdlib_iwamax( k-1, w( 1, kw ), 1 ) + imax = stdlib_i${ci}$amax( k-1, w( 1, kw ), 1 ) colmax = cabs1( w( imax, kw ) ) else colmax = zero @@ -53438,7 +53440,7 @@ module stdlib_linalg_lapack_w ! column k is zero or underflow: set info and continue if( info==0 )info = k kp = k - call stdlib_wcopy( k, w( 1, kw ), 1, a( 1, k ), 1 ) + call stdlib_${ci}$copy( k, w( 1, kw ), 1, a( 1, k ), 1 ) else ! ============================================================ ! test for interchange @@ -53453,22 +53455,22 @@ module stdlib_linalg_lapack_w 12 continue ! begin pivot search loop body ! copy column imax to column kw-1 of w and update it - call stdlib_wcopy( imax, a( 1, imax ), 1, w( 1, kw-1 ), 1 ) - call stdlib_wcopy( k-imax, a( imax, imax+1 ), lda,w( imax+1, kw-1 ), 1 ) + call stdlib_${ci}$copy( imax, a( 1, imax ), 1, w( 1, kw-1 ), 1 ) + call stdlib_${ci}$copy( k-imax, a( imax, imax+1 ), lda,w( imax+1, kw-1 ), 1 ) - if( k1 ) then - itemp = stdlib_iwamax( imax-1, w( 1, kw-1 ), 1 ) + itemp = stdlib_i${ci}$amax( imax-1, w( 1, kw-1 ), 1 ) dtemp = cabs1( w( itemp, kw-1 ) ) if( dtemp>rowmax ) then rowmax = dtemp @@ -53483,7 +53485,7 @@ module stdlib_linalg_lapack_w ! use 1-by-1 pivot block kp = imax ! copy column kw-1 of w to column kw of w - call stdlib_wcopy( k, w( 1, kw-1 ), 1, w( 1, kw ), 1 ) + call stdlib_${ci}$copy( k, w( 1, kw-1 ), 1, w( 1, kw ), 1 ) done = .true. ! equivalent to testing for rowmax==colmax, ! (used to handle nan and inf) @@ -53499,7 +53501,7 @@ module stdlib_linalg_lapack_w colmax = rowmax imax = jmax ! copy updated jmaxth (next imaxth) column to kth of w - call stdlib_wcopy( k, w( 1, kw-1 ), 1, w( 1, kw ), 1 ) + call stdlib_${ci}$copy( k, w( 1, kw-1 ), 1, w( 1, kw ), 1 ) end if ! end pivot search loop body if( .not. done ) goto 12 @@ -53510,34 +53512,34 @@ module stdlib_linalg_lapack_w kkw = nb + kk - n if( ( kstep==2 ) .and. ( p/=k ) ) then ! copy non-updated column k to column p - call stdlib_wcopy( k-p, a( p+1, k ), 1, a( p, p+1 ), lda ) - call stdlib_wcopy( p, a( 1, k ), 1, a( 1, p ), 1 ) + call stdlib_${ci}$copy( k-p, a( p+1, k ), 1, a( p, p+1 ), lda ) + call stdlib_${ci}$copy( p, a( 1, k ), 1, a( 1, p ), 1 ) ! interchange rows k and p in last n-k+1 columns of a ! and last n-k+2 columns of w - call stdlib_wswap( n-k+1, a( k, k ), lda, a( p, k ), lda ) - call stdlib_wswap( n-kk+1, w( k, kkw ), ldw, w( p, kkw ), ldw ) + call stdlib_${ci}$swap( n-k+1, a( k, k ), lda, a( p, k ), lda ) + call stdlib_${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_wcopy( k-1-kp, a( kp+1, kk ), 1, a( kp, kp+1 ),lda ) - call stdlib_wcopy( kp, a( 1, kk ), 1, a( 1, kp ), 1 ) + call stdlib_${ci}$copy( k-1-kp, a( kp+1, kk ), 1, a( kp, kp+1 ),lda ) + call stdlib_${ci}$copy( kp, a( 1, kk ), 1, a( 1, kp ), 1 ) ! interchange rows kk and kp in last n-kk+1 columns ! of a and w - call stdlib_wswap( n-kk+1, a( kk, kk ), lda, a( kp, kk ), lda ) - call stdlib_wswap( n-kk+1, w( kk, kkw ), ldw, w( kp, kkw ),ldw ) + call stdlib_${ci}$swap( n-kk+1, a( kk, kk ), lda, a( kp, kk ), lda ) + call stdlib_${ci}$swap( n-kk+1, w( kk, kkw ), ldw, w( kp, kkw ),ldw ) end if if( kstep==1 ) 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_wcopy( k, w( 1, kw ), 1, a( 1, k ), 1 ) + call stdlib_${ci}$copy( k, w( 1, kw ), 1, a( 1, k ), 1 ) if( k>1 ) then if( cabs1( a( k, k ) )>=sfmin ) then r1 = cone / a( k, k ) - call stdlib_wscal( k-1, r1, a( 1, k ), 1 ) + call stdlib_${ci}$scal( k-1, r1, a( 1, k ), 1 ) else if( a( k, k )/=czero ) then do ii = 1, k - 1 a( ii, k ) = a( ii, k ) / a( k, k ) @@ -53585,11 +53587,11 @@ module stdlib_linalg_lapack_w jb = min( nb, k-j+1 ) ! update the upper triangle of the diagonal block do jj = j, j + jb - 1 - call stdlib_wgemv( 'NO TRANSPOSE', jj-j+1, n-k, -cone,a( j, k+1 ), lda, w( jj,& + call stdlib_${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 ) end do ! update the rectangular superdiagonal block - if( j>=2 )call stdlib_wgemm( 'NO TRANSPOSE', 'TRANSPOSE', j-1, jb,n-k, -cone, a( & + if( j>=2 )call stdlib_${ci}$gemm( 'NO TRANSPOSE', 'TRANSPOSE', j-1, jb,n-k, -cone, a( & 1, k+1 ), lda, w( j, kw+1 ), ldw,cone, a( 1, j ), lda ) end do ! put u12 in standard form by partially undoing the interchanges @@ -53607,10 +53609,10 @@ module stdlib_linalg_lapack_w kstep = 2 end if j = j + 1 - if( jp2/=jj .and. j<=n )call stdlib_wswap( n-j+1, a( jp2, j ), lda, a( jj, j ), & + if( jp2/=jj .and. j<=n )call stdlib_${ci}$swap( n-j+1, a( jp2, j ), lda, a( jj, j ), & lda ) jj = j - 1 - if( jp1/=jj .and. kstep==2 )call stdlib_wswap( n-j+1, a( jp1, j ), lda, a( jj, j & + if( jp1/=jj .and. kstep==2 )call stdlib_${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 @@ -53627,8 +53629,8 @@ module stdlib_linalg_lapack_w kstep = 1 p = k ! copy column k of a to column k of w and update it - call stdlib_wcopy( n-k+1, a( k, k ), 1, w( k, k ), 1 ) - if( k>1 )call stdlib_wgemv( 'NO TRANSPOSE', n-k+1, k-1, -cone, a( k, 1 ),lda, w( k, & + call stdlib_${ci}$copy( n-k+1, a( k, k ), 1, w( k, k ), 1 ) + if( k>1 )call stdlib_${ci}$gemv( 'NO TRANSPOSE', n-k+1, k-1, -cone, a( k, 1 ),lda, w( k, & 1 ), ldw, cone, w( k, k ), 1 ) ! determine rows and columns to be interchanged and whether ! a 1-by-1 or 2-by-2 pivot block will be used @@ -53637,7 +53639,7 @@ module stdlib_linalg_lapack_w ! column k, and colmax is its absolute value. ! determine both colmax and imax. if( k1 )call stdlib_wgemv( 'NO TRANSPOSE', n-k+1, k-1, -cone,a( k, 1 ), & + call stdlib_${ci}$copy( imax-k, a( imax, k ), lda, w( k, k+1 ), 1) + call stdlib_${ci}$copy( n-imax+1, a( imax, imax ), 1,w( imax, k+1 ), 1 ) + if( k>1 )call stdlib_${ci}$gemv( 'NO TRANSPOSE', n-k+1, k-1, -cone,a( k, 1 ), & lda, w( imax, 1 ), ldw,cone, w( k, k+1 ), 1 ) ! 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 + stdlib_iwamax( imax-k, w( k, k+1 ), 1 ) + jmax = k - 1 + stdlib_i${ci}$amax( imax-k, w( k, k+1 ), 1 ) rowmax = cabs1( w( jmax, k+1 ) ) else rowmax = zero end if if( imaxrowmax ) then rowmax = dtemp @@ -53690,7 +53692,7 @@ module stdlib_linalg_lapack_w ! use 1-by-1 pivot block kp = imax ! copy column k+1 of w to column k of w - call stdlib_wcopy( n-k+1, w( k, k+1 ), 1, w( k, k ), 1 ) + call stdlib_${ci}$copy( n-k+1, w( k, k+1 ), 1, w( k, k ), 1 ) done = .true. ! equivalent to testing for rowmax==colmax, ! (used to handle nan and inf) @@ -53706,7 +53708,7 @@ module stdlib_linalg_lapack_w colmax = rowmax imax = jmax ! copy updated jmaxth (next imaxth) column to kth of w - call stdlib_wcopy( n-k+1, w( k, k+1 ), 1, w( k, k ), 1 ) + call stdlib_${ci}$copy( n-k+1, w( k, k+1 ), 1, w( k, k ), 1 ) end if ! end pivot search loop body if( .not. done ) goto 72 @@ -53715,33 +53717,33 @@ module stdlib_linalg_lapack_w kk = k + kstep - 1 if( ( kstep==2 ) .and. ( p/=k ) ) then ! copy non-updated column k to column p - call stdlib_wcopy( p-k, a( k, k ), 1, a( p, k ), lda ) - call stdlib_wcopy( n-p+1, a( p, k ), 1, a( p, p ), 1 ) + call stdlib_${ci}$copy( p-k, a( k, k ), 1, a( p, k ), lda ) + call stdlib_${ci}$copy( n-p+1, a( p, k ), 1, a( p, p ), 1 ) ! interchange rows k and p in first k columns of a ! and first k+1 columns of w - call stdlib_wswap( k, a( k, 1 ), lda, a( p, 1 ), lda ) - call stdlib_wswap( kk, w( k, 1 ), ldw, w( p, 1 ), ldw ) + call stdlib_${ci}$swap( k, a( k, 1 ), lda, a( p, 1 ), lda ) + call stdlib_${ci}$swap( kk, w( k, 1 ), ldw, w( p, 1 ), 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_wcopy( kp-k-1, a( k+1, kk ), 1, a( kp, k+1 ), lda ) - call stdlib_wcopy( n-kp+1, a( kp, kk ), 1, a( kp, kp ), 1 ) + call stdlib_${ci}$copy( kp-k-1, a( k+1, kk ), 1, a( kp, k+1 ), lda ) + call stdlib_${ci}$copy( n-kp+1, a( kp, kk ), 1, a( kp, kp ), 1 ) ! interchange rows kk and kp in first kk columns of a and w - call stdlib_wswap( kk, a( kk, 1 ), lda, a( kp, 1 ), lda ) - call stdlib_wswap( kk, w( kk, 1 ), ldw, w( kp, 1 ), ldw ) + call stdlib_${ci}$swap( kk, a( kk, 1 ), lda, a( kp, 1 ), lda ) + call stdlib_${ci}$swap( kk, w( kk, 1 ), ldw, w( kp, 1 ), ldw ) end if if( kstep==1 ) 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_wcopy( n-k+1, w( k, k ), 1, a( k, k ), 1 ) + call stdlib_${ci}$copy( n-k+1, w( k, k ), 1, a( k, k ), 1 ) if( k=sfmin ) then r1 = cone / a( k, k ) - call stdlib_wscal( n-k, r1, a( k+1, k ), 1 ) + call stdlib_${ci}$scal( n-k, r1, a( k+1, k ), 1 ) else if( a( k, k )/=czero ) then do ii = k + 1, n a( ii, k ) = a( ii, k ) / a( k, k ) @@ -53788,11 +53790,11 @@ module stdlib_linalg_lapack_w jb = min( nb, n-j+1 ) ! update the lower triangle of the diagonal block do jj = j, j + jb - 1 - call stdlib_wgemv( 'NO TRANSPOSE', j+jb-jj, k-1, -cone,a( jj, 1 ), lda, w( jj,& + call stdlib_${ci}$gemv( 'NO TRANSPOSE', j+jb-jj, k-1, -cone,a( jj, 1 ), lda, w( jj,& 1 ), ldw, cone,a( jj, jj ), 1 ) end do ! update the rectangular subdiagonal block - if( j+jb<=n )call stdlib_wgemm( 'NO TRANSPOSE', 'TRANSPOSE', n-j-jb+1, jb,k-1, -& + if( j+jb<=n )call stdlib_${ci}$gemm( 'NO TRANSPOSE', 'TRANSPOSE', n-j-jb+1, jb,k-1, -& cone, a( j+jb, 1 ), lda, w( j, 1 ), ldw,cone, a( j+jb, j ), lda ) end do ! put l21 in standard form by partially undoing the interchanges @@ -53810,20 +53812,20 @@ module stdlib_linalg_lapack_w kstep = 2 end if j = j - 1 - if( jp2/=jj .and. j>=1 )call stdlib_wswap( j, a( jp2, 1 ), lda, a( jj, 1 ), lda ) + if( jp2/=jj .and. j>=1 )call stdlib_${ci}$swap( j, a( jp2, 1 ), lda, a( jj, 1 ), lda ) jj = j + 1 - if( jp1/=jj .and. kstep==2 )call stdlib_wswap( j, a( jp1, 1 ), lda, a( jj, 1 ), & + if( jp1/=jj .and. kstep==2 )call stdlib_${ci}$swap( j, a( jp1, 1 ), lda, a( jj, 1 ), & lda ) if( j>=1 )go to 120 ! set kb to the number of columns factorized kb = k - 1 end if return - end subroutine stdlib_wlasyf_rook + end subroutine stdlib_${ci}$lasyf_rook - pure subroutine stdlib_wlat2c( uplo, n, a, lda, sa, ldsa, info ) + pure subroutine stdlib_${ci}$lat2c( uplo, n, a, lda, sa, ldsa, info ) !! ZLAT2C: converts a COMPLEX*16 triangular matrix, SA, to a COMPLEX !! triangular matrix, A. !! RMAX is the overflow for the SINGLE PRECISION arithmetic @@ -53839,11 +53841,11 @@ module stdlib_linalg_lapack_w integer(ilp), intent(in) :: lda, ldsa, n ! Array Arguments complex(dp), intent(out) :: sa(ldsa,*) - complex(qp), intent(in) :: a(lda,*) + complex(${ck}$), intent(in) :: a(lda,*) ! ===================================================================== ! Local Scalars integer(ilp) :: i, j - real(qp) :: rmax + real(${ck}$) :: rmax logical(lk) :: upper ! Intrinsic Functions intrinsic :: real,aimag @@ -53853,7 +53855,7 @@ module stdlib_linalg_lapack_w if( upper ) then do j = 1, n do i = 1, j - if( ( real( a( i, j ),KIND=qp)<-rmax ) .or.( real( a( i, j ),KIND=qp)>rmax ) & + if( ( real( a( i, j ),KIND=${ck}$)<-rmax ) .or.( real( a( i, j ),KIND=${ck}$)>rmax ) & .or.( aimag( a( i, j ) )<-rmax ) .or.( aimag( a( i, j ) )>rmax ) ) & then info = 1 @@ -53865,7 +53867,7 @@ module stdlib_linalg_lapack_w else do j = 1, n do i = j, n - if( ( real( a( i, j ),KIND=qp)<-rmax ) .or.( real( a( i, j ),KIND=qp)>rmax ) & + if( ( real( a( i, j ),KIND=${ck}$)<-rmax ) .or.( real( a( i, j ),KIND=${ck}$)>rmax ) & .or.( aimag( a( i, j ) )<-rmax ) .or.( aimag( a( i, j ) )>rmax ) ) & then info = 1 @@ -53877,10 +53879,10 @@ module stdlib_linalg_lapack_w end if 50 continue return - end subroutine stdlib_wlat2c + end subroutine stdlib_${ci}$lat2c - pure subroutine stdlib_wlatbs( uplo, trans, diag, normin, n, kd, ab, ldab, x,scale, cnorm, & + pure subroutine stdlib_${ci}$latbs( uplo, trans, diag, normin, n, kd, ab, ldab, x,scale, cnorm, & !! ZLATBS: solves one of the triangular systems !! A * x = s*b, A**T * x = s*b, or A**H * x = s*b, !! with scaling to prevent overflow, where A is an upper or lower @@ -53899,25 +53901,25 @@ module stdlib_linalg_lapack_w character, intent(in) :: diag, normin, trans, uplo integer(ilp), intent(out) :: info integer(ilp), intent(in) :: kd, ldab, n - real(qp), intent(out) :: scale + real(${ck}$), intent(out) :: scale ! Array Arguments - real(qp), intent(inout) :: cnorm(*) - complex(qp), intent(in) :: ab(ldab,*) - complex(qp), intent(inout) :: x(*) + real(${ck}$), intent(inout) :: cnorm(*) + complex(${ck}$), intent(in) :: ab(ldab,*) + complex(${ck}$), intent(inout) :: x(*) ! ===================================================================== ! Local Scalars logical(lk) :: notran, nounit, upper integer(ilp) :: i, imax, j, jfirst, jinc, jlast, jlen, maind - real(qp) :: bignum, grow, rec, smlnum, tjj, tmax, tscal, xbnd, xj, xmax - complex(qp) :: csumj, tjjs, uscal, zdum + real(${ck}$) :: bignum, grow, rec, smlnum, tjj, tmax, tscal, xbnd, xj, xmax + complex(${ck}$) :: csumj, tjjs, uscal, zdum ! Intrinsic Functions intrinsic :: abs,real,cmplx,conjg,aimag,max,min ! Statement Functions - real(qp) :: cabs1, cabs2 + real(${ck}$) :: cabs1, cabs2 ! Statement Function Definitions - cabs1( zdum ) = abs( real( zdum,KIND=qp) ) + abs( aimag( zdum ) ) - cabs2( zdum ) = abs( real( zdum,KIND=qp) / 2._qp ) +abs( aimag( zdum ) / 2._qp ) + cabs1( zdum ) = abs( real( zdum,KIND=${ck}$) ) + abs( aimag( zdum ) ) + cabs2( zdum ) = abs( real( zdum,KIND=${ck}$) / 2._${ck}$ ) +abs( aimag( zdum ) / 2._${ck}$ ) ! Executable Statements info = 0 @@ -53949,10 +53951,10 @@ module stdlib_linalg_lapack_w ! quick return if possible if( n==0 )return ! determine machine dependent parameters to control overflow. - smlnum = stdlib_qlamch( 'SAFE MINIMUM' ) + smlnum = stdlib_${c2ri(ci)}$lamch( 'SAFE MINIMUM' ) bignum = one / smlnum - call stdlib_qlabad( smlnum, bignum ) - smlnum = smlnum / stdlib_qlamch( 'PRECISION' ) + call stdlib_${c2ri(ci)}$labad( smlnum, bignum ) + smlnum = smlnum / stdlib_${c2ri(ci)}$lamch( 'PRECISION' ) bignum = one / smlnum scale = one if( stdlib_lsame( normin, 'N' ) ) then @@ -53961,14 +53963,14 @@ module stdlib_linalg_lapack_w ! a is upper triangular. do j = 1, n jlen = min( kd, j-1 ) - cnorm( j ) = stdlib_qzasum( jlen, ab( kd+1-jlen, j ), 1 ) + cnorm( j ) = stdlib_${c2ri(ci)}$zasum( jlen, ab( kd+1-jlen, j ), 1 ) end do else ! a is lower triangular. do j = 1, n jlen = min( kd, n-j ) if( jlen>0 ) then - cnorm( j ) = stdlib_qzasum( jlen, ab( 2, j ), 1 ) + cnorm( j ) = stdlib_${c2ri(ci)}$zasum( jlen, ab( 2, j ), 1 ) else cnorm( j ) = zero end if @@ -53977,16 +53979,16 @@ module stdlib_linalg_lapack_w end if ! scale the column norms by tscal if the maximum element in cnorm is ! greater than bignum/2. - imax = stdlib_iqamax( n, cnorm, 1 ) + imax = stdlib_i${c2ri(ci)}$amax( n, cnorm, 1 ) tmax = cnorm( imax ) if( tmax<=bignum*half ) then tscal = one else tscal = half / ( smlnum*tmax ) - call stdlib_qscal( n, tscal, cnorm, 1 ) + call stdlib_${c2ri(ci)}$scal( n, tscal, cnorm, 1 ) end if ! compute a bound on the computed solution vector to see if the - ! level 2 blas routine stdlib_wtbsv can be used. + ! level 2 blas routine stdlib_${ci}$tbsv can be used. xmax = zero do j = 1, n xmax = max( xmax, cabs2( x( j ) ) ) @@ -54105,14 +54107,14 @@ module stdlib_linalg_lapack_w if( ( grow*tscal )>smlnum ) then ! use the level 2 blas solve if the reciprocal of the bound on ! elements of x is not too small. - call stdlib_wtbsv( uplo, trans, diag, n, kd, ab, ldab, x, 1 ) + call stdlib_${ci}$tbsv( uplo, trans, diag, n, kd, ab, ldab, x, 1 ) else ! use a level 1 blas solve, scaling intermediate results. if( xmax>bignum*half ) then ! scale x so that its components are less than or equal to ! bignum in absolute value. scale = ( bignum*half ) / xmax - call stdlib_wdscal( n, scale, x, 1 ) + call stdlib_${ci}$dscal( n, scale, x, 1 ) xmax = bignum else xmax = xmax*two @@ -54135,12 +54137,12 @@ module stdlib_linalg_lapack_w if( xj>tjj*bignum ) then ! scale x by 1/b(j). rec = one / xj - call stdlib_wdscal( n, rec, x, 1 ) + call stdlib_${ci}$dscal( n, rec, x, 1 ) scale = scale*rec xmax = xmax*rec end if end if - x( j ) = stdlib_wladiv( x( j ), tjjs ) + x( j ) = stdlib_${ci}$ladiv( x( j ), tjjs ) xj = cabs1( x( j ) ) else if( tjj>zero ) then ! 0 < abs(a(j,j)) <= smlnum: @@ -54153,11 +54155,11 @@ module stdlib_linalg_lapack_w ! multiplying x(j) times column j. rec = rec / cnorm( j ) end if - call stdlib_wdscal( n, rec, x, 1 ) + call stdlib_${ci}$dscal( n, rec, x, 1 ) scale = scale*rec xmax = xmax*rec end if - x( j ) = stdlib_wladiv( x( j ), tjjs ) + x( j ) = stdlib_${ci}$ladiv( x( j ), tjjs ) xj = cabs1( x( j ) ) else ! a(j,j) = 0: set x(1:n) = 0, x(j) = 1, and @@ -54178,12 +54180,12 @@ module stdlib_linalg_lapack_w if( cnorm( j )>( bignum-xmax )*rec ) then ! scale x by 1/(2*abs(x(j))). rec = rec*half - call stdlib_wdscal( n, rec, x, 1 ) + call stdlib_${ci}$dscal( n, rec, x, 1 ) scale = scale*rec end if else if( xj*cnorm( j )>( bignum-xmax ) ) then ! scale x by 1/2. - call stdlib_wdscal( n, half, x, 1 ) + call stdlib_${ci}$dscal( n, half, x, 1 ) scale = scale*half end if if( upper ) then @@ -54192,9 +54194,9 @@ module stdlib_linalg_lapack_w ! x(max(1,j-kd):j-1) := x(max(1,j-kd):j-1) - ! x(j)* a(max(1,j-kd):j-1,j) jlen = min( kd, j-1 ) - call stdlib_waxpy( jlen, -x( j )*tscal,ab( kd+1-jlen, j ), 1, x( j-jlen & + call stdlib_${ci}$axpy( jlen, -x( j )*tscal,ab( kd+1-jlen, j ), 1, x( j-jlen & ), 1 ) - i = stdlib_iwamax( j-1, x, 1 ) + i = stdlib_i${ci}$amax( j-1, x, 1 ) xmax = cabs1( x( i ) ) end if else if( j0 )call stdlib_waxpy( jlen, -x( j )*tscal, ab( 2, j ), 1,x( j+1 ),& + if( jlen>0 )call stdlib_${ci}$axpy( jlen, -x( j )*tscal, ab( 2, j ), 1,x( j+1 ),& 1 ) - i = j + stdlib_iwamax( n-j, x( j+1 ), 1 ) + i = j + stdlib_i${ci}$amax( n-j, x( j+1 ), 1 ) xmax = cabs1( x( i ) ) end if end do loop_120 @@ -54228,25 +54230,25 @@ module stdlib_linalg_lapack_w if( tjj>one ) then ! divide by a(j,j) when scaling x if a(j,j) > 1. rec = min( one, rec*tjj ) - uscal = stdlib_wladiv( uscal, tjjs ) + uscal = stdlib_${ci}$ladiv( uscal, tjjs ) end if if( rec1 )csumj = stdlib_wdotu( jlen, ab( 2, j ), 1, x( j+1 ),1 ) + if( jlen>1 )csumj = stdlib_${ci}$dotu( jlen, ab( 2, j ), 1, x( j+1 ),1 ) end if else @@ -54263,7 +54265,7 @@ module stdlib_linalg_lapack_w end do end if end if - if( uscal==cmplx( tscal,KIND=qp) ) then + if( uscal==cmplx( tscal,KIND=${ck}$) ) then ! compute x(j) := ( x(j) - csumj ) / a(j,j) if 1/a(j,j) ! was not used to scale the dotproduct. x( j ) = x( j ) - csumj @@ -54282,22 +54284,22 @@ module stdlib_linalg_lapack_w if( xj>tjj*bignum ) then ! scale x by 1/abs(x(j)). rec = one / xj - call stdlib_wdscal( n, rec, x, 1 ) + call stdlib_${ci}$dscal( n, rec, x, 1 ) scale = scale*rec xmax = xmax*rec end if end if - x( j ) = stdlib_wladiv( x( j ), tjjs ) + x( j ) = stdlib_${ci}$ladiv( x( j ), tjjs ) else if( tjj>zero ) then ! 0 < abs(a(j,j)) <= smlnum: if( xj>tjj*bignum ) then ! scale x by (1/abs(x(j)))*abs(a(j,j))*bignum. rec = ( tjj*bignum ) / xj - call stdlib_wdscal( n, rec, x, 1 ) + call stdlib_${ci}$dscal( n, rec, x, 1 ) scale = scale*rec xmax = xmax*rec end if - x( j ) = stdlib_wladiv( x( j ), tjjs ) + x( j ) = stdlib_${ci}$ladiv( x( j ), tjjs ) else ! a(j,j) = 0: set x(1:n) = 0, x(j) = 1, and ! scale = 0 and compute a solution to a**t *x = 0. @@ -54312,7 +54314,7 @@ module stdlib_linalg_lapack_w else ! compute x(j) := x(j) / a(j,j) - csumj if the dot ! product has already been divided by 1/a(j,j). - x( j ) = stdlib_wladiv( x( j ), tjjs ) - csumj + x( j ) = stdlib_${ci}$ladiv( x( j ), tjjs ) - csumj end if xmax = max( xmax, cabs1( x( j ) ) ) end do loop_170 @@ -54336,25 +54338,25 @@ module stdlib_linalg_lapack_w if( tjj>one ) then ! divide by a(j,j) when scaling x if a(j,j) > 1. rec = min( one, rec*tjj ) - uscal = stdlib_wladiv( uscal, tjjs ) + uscal = stdlib_${ci}$ladiv( uscal, tjjs ) end if if( rec1 )csumj = stdlib_wdotc( jlen, ab( 2, j ), 1, x( j+1 ),1 ) + if( jlen>1 )csumj = stdlib_${ci}$dotc( jlen, ab( 2, j ), 1, x( j+1 ),1 ) end if else @@ -54372,7 +54374,7 @@ module stdlib_linalg_lapack_w end do end if end if - if( uscal==cmplx( tscal,KIND=qp) ) then + if( uscal==cmplx( tscal,KIND=${ck}$) ) then ! compute x(j) := ( x(j) - csumj ) / a(j,j) if 1/a(j,j) ! was not used to scale the dotproduct. x( j ) = x( j ) - csumj @@ -54391,22 +54393,22 @@ module stdlib_linalg_lapack_w if( xj>tjj*bignum ) then ! scale x by 1/abs(x(j)). rec = one / xj - call stdlib_wdscal( n, rec, x, 1 ) + call stdlib_${ci}$dscal( n, rec, x, 1 ) scale = scale*rec xmax = xmax*rec end if end if - x( j ) = stdlib_wladiv( x( j ), tjjs ) + x( j ) = stdlib_${ci}$ladiv( x( j ), tjjs ) else if( tjj>zero ) then ! 0 < abs(a(j,j)) <= smlnum: if( xj>tjj*bignum ) then ! scale x by (1/abs(x(j)))*abs(a(j,j))*bignum. rec = ( tjj*bignum ) / xj - call stdlib_wdscal( n, rec, x, 1 ) + call stdlib_${ci}$dscal( n, rec, x, 1 ) scale = scale*rec xmax = xmax*rec end if - x( j ) = stdlib_wladiv( x( j ), tjjs ) + x( j ) = stdlib_${ci}$ladiv( x( j ), tjjs ) else ! a(j,j) = 0: set x(1:n) = 0, x(j) = 1, and ! scale = 0 and compute a solution to a**h *x = 0. @@ -54421,7 +54423,7 @@ module stdlib_linalg_lapack_w else ! compute x(j) := x(j) / a(j,j) - csumj if the dot ! product has already been divided by 1/a(j,j). - x( j ) = stdlib_wladiv( x( j ), tjjs ) - csumj + x( j ) = stdlib_${ci}$ladiv( x( j ), tjjs ) - csumj end if xmax = max( xmax, cabs1( x( j ) ) ) end do loop_220 @@ -54430,13 +54432,13 @@ module stdlib_linalg_lapack_w end if ! scale the column norms by 1/tscal for return. if( tscal/=one ) then - call stdlib_qscal( n, one / tscal, cnorm, 1 ) + call stdlib_${c2ri(ci)}$scal( n, one / tscal, cnorm, 1 ) end if return - end subroutine stdlib_wlatbs + end subroutine stdlib_${ci}$latbs - pure subroutine stdlib_wlatdf( ijob, n, z, ldz, rhs, rdsum, rdscal, ipiv,jpiv ) + pure subroutine stdlib_${ci}$latdf( ijob, n, z, ldz, rhs, rdsum, rdscal, ipiv,jpiv ) !! ZLATDF: computes the contribution to the reciprocal Dif-estimate !! by solving for x in Z * x = b, where b is chosen such that the norm !! of x is as large as possible. It is assumed that LU decomposition @@ -54450,10 +54452,10 @@ module stdlib_linalg_lapack_w ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments integer(ilp), intent(in) :: ijob, ldz, n - real(qp), intent(inout) :: rdscal, rdsum + real(${ck}$), intent(inout) :: rdscal, rdsum ! Array Arguments integer(ilp), intent(in) :: ipiv(*), jpiv(*) - complex(qp), intent(inout) :: rhs(*), z(ldz,*) + complex(${ck}$), intent(inout) :: rhs(*), z(ldz,*) ! ===================================================================== ! Parameters integer(ilp), parameter :: maxdim = 2 @@ -54462,17 +54464,17 @@ module stdlib_linalg_lapack_w ! Local Scalars integer(ilp) :: i, info, j, k - real(qp) :: rtemp, scale, sminu, splus - complex(qp) :: bm, bp, pmone, temp + real(${ck}$) :: rtemp, scale, sminu, splus + complex(${ck}$) :: bm, bp, pmone, temp ! Local Arrays - real(qp) :: rwork(maxdim) - complex(qp) :: work(4*maxdim), xm(maxdim), xp(maxdim) + real(${ck}$) :: rwork(maxdim) + complex(${ck}$) :: work(4*maxdim), xm(maxdim), xp(maxdim) ! Intrinsic Functions intrinsic :: abs,real,sqrt ! Executable Statements if( ijob/=2 ) then ! apply permutations ipiv to rhs - call stdlib_wlaswp( 1, rhs, ldz, 1, n-1, ipiv, 1 ) + call stdlib_${ci}$laswp( 1, rhs, ldz, 1, n-1, ipiv, 1 ) ! solve for l-part choosing rhs either to +1 or -1. pmone = -cone loop_10: do j = 1, n - 1 @@ -54481,10 +54483,10 @@ module stdlib_linalg_lapack_w splus = one ! lockahead for l- part rhs(1:n-1) = +-1 ! splus and smin computed more efficiently than in bsolve[1]. - splus = splus + real( stdlib_wdotc( n-j, z( j+1, j ), 1, z( j+1,j ), 1 ),KIND=qp) + splus = splus + real( stdlib_${ci}$dotc( n-j, z( j+1, j ), 1, z( j+1,j ), 1 ),KIND=${ck}$) - sminu = real( stdlib_wdotc( n-j, z( j+1, j ), 1, rhs( j+1 ), 1 ),KIND=qp) - splus = splus*real( rhs( j ),KIND=qp) + sminu = real( stdlib_${ci}$dotc( n-j, z( j+1, j ), 1, rhs( j+1 ), 1 ),KIND=${ck}$) + splus = splus*real( rhs( j ),KIND=${ck}$) if( splus>sminu ) then rhs( j ) = bp else if( sminu>splus ) then @@ -54500,13 +54502,13 @@ module stdlib_linalg_lapack_w end if ! compute the remaining r.h.s. temp = -rhs( j ) - call stdlib_waxpy( n-j, temp, z( j+1, j ), 1, rhs( j+1 ), 1 ) + call stdlib_${ci}$axpy( n-j, temp, z( j+1, j ), 1, rhs( j+1 ), 1 ) end do loop_10 ! solve for u- part, lockahead for rhs(n) = +-1. this is not done ! in bsolve and will hopefully give us a better estimate because ! any ill-conditioning of the original matrix is transferred to u ! and not to l. u(n, n) is an approximation to sigma_min(lu). - call stdlib_wcopy( n-1, rhs, 1, work, 1 ) + call stdlib_${ci}$copy( n-1, rhs, 1, work, 1 ) work( n ) = rhs( n ) + cone rhs( n ) = rhs( n ) - cone splus = zero @@ -54522,35 +54524,35 @@ module stdlib_linalg_lapack_w splus = splus + abs( work( i ) ) sminu = sminu + abs( rhs( i ) ) end do - if( splus>sminu )call stdlib_wcopy( n, work, 1, rhs, 1 ) + if( splus>sminu )call stdlib_${ci}$copy( n, work, 1, rhs, 1 ) ! apply the permutations jpiv to the computed solution (rhs) - call stdlib_wlaswp( 1, rhs, ldz, 1, n-1, jpiv, -1 ) + call stdlib_${ci}$laswp( 1, rhs, ldz, 1, n-1, jpiv, -1 ) ! compute the sum of squares - call stdlib_wlassq( n, rhs, 1, rdscal, rdsum ) + call stdlib_${ci}$lassq( n, rhs, 1, rdscal, rdsum ) return end if ! entry ijob = 2 ! compute approximate nullvector xm of z - call stdlib_wgecon( 'I', n, z, ldz, one, rtemp, work, rwork, info ) - call stdlib_wcopy( n, work( n+1 ), 1, xm, 1 ) + call stdlib_${ci}$gecon( 'I', n, z, ldz, one, rtemp, work, rwork, info ) + call stdlib_${ci}$copy( n, work( n+1 ), 1, xm, 1 ) ! compute rhs - call stdlib_wlaswp( 1, xm, ldz, 1, n-1, ipiv, -1 ) - temp = cone / sqrt( stdlib_wdotc( n, xm, 1, xm, 1 ) ) - call stdlib_wscal( n, temp, xm, 1 ) - call stdlib_wcopy( n, xm, 1, xp, 1 ) - call stdlib_waxpy( n, cone, rhs, 1, xp, 1 ) - call stdlib_waxpy( n, -cone, xm, 1, rhs, 1 ) - call stdlib_wgesc2( n, z, ldz, rhs, ipiv, jpiv, scale ) - call stdlib_wgesc2( n, z, ldz, xp, ipiv, jpiv, scale ) - if( stdlib_qzasum( n, xp, 1 )>stdlib_qzasum( n, rhs, 1 ) )call stdlib_wcopy( n, xp, 1, & + call stdlib_${ci}$laswp( 1, xm, ldz, 1, n-1, ipiv, -1 ) + temp = cone / sqrt( stdlib_${ci}$dotc( n, xm, 1, xm, 1 ) ) + call stdlib_${ci}$scal( n, temp, xm, 1 ) + call stdlib_${ci}$copy( n, xm, 1, xp, 1 ) + call stdlib_${ci}$axpy( n, cone, rhs, 1, xp, 1 ) + call stdlib_${ci}$axpy( n, -cone, xm, 1, rhs, 1 ) + call stdlib_${ci}$gesc2( n, z, ldz, rhs, ipiv, jpiv, scale ) + call stdlib_${ci}$gesc2( n, z, ldz, xp, ipiv, jpiv, scale ) + if( stdlib_${c2ri(ci)}$zasum( n, xp, 1 )>stdlib_${c2ri(ci)}$zasum( n, rhs, 1 ) )call stdlib_${ci}$copy( n, xp, 1, & rhs, 1 ) ! compute the sum of squares - call stdlib_wlassq( n, rhs, 1, rdscal, rdsum ) + call stdlib_${ci}$lassq( n, rhs, 1, rdscal, rdsum ) return - end subroutine stdlib_wlatdf + end subroutine stdlib_${ci}$latdf - pure subroutine stdlib_wlatps( uplo, trans, diag, normin, n, ap, x, scale,cnorm, info ) + pure subroutine stdlib_${ci}$latps( uplo, trans, diag, normin, n, ap, x, scale,cnorm, info ) !! ZLATPS: solves one of the triangular systems !! A * x = s*b, A**T * x = s*b, or A**H * x = s*b, !! with scaling to prevent overflow, where A is an upper or lower @@ -54570,25 +54572,25 @@ module stdlib_linalg_lapack_w character, intent(in) :: diag, normin, trans, uplo integer(ilp), intent(out) :: info integer(ilp), intent(in) :: n - real(qp), intent(out) :: scale + real(${ck}$), intent(out) :: scale ! Array Arguments - real(qp), intent(inout) :: cnorm(*) - complex(qp), intent(in) :: ap(*) - complex(qp), intent(inout) :: x(*) + real(${ck}$), intent(inout) :: cnorm(*) + complex(${ck}$), intent(in) :: ap(*) + complex(${ck}$), intent(inout) :: x(*) ! ===================================================================== ! Local Scalars logical(lk) :: notran, nounit, upper integer(ilp) :: i, imax, ip, j, jfirst, jinc, jlast, jlen - real(qp) :: bignum, grow, rec, smlnum, tjj, tmax, tscal, xbnd, xj, xmax - complex(qp) :: csumj, tjjs, uscal, zdum + real(${ck}$) :: bignum, grow, rec, smlnum, tjj, tmax, tscal, xbnd, xj, xmax + complex(${ck}$) :: csumj, tjjs, uscal, zdum ! Intrinsic Functions intrinsic :: abs,real,cmplx,conjg,aimag,max,min ! Statement Functions - real(qp) :: cabs1, cabs2 + real(${ck}$) :: cabs1, cabs2 ! Statement Function Definitions - cabs1( zdum ) = abs( real( zdum,KIND=qp) ) + abs( aimag( zdum ) ) - cabs2( zdum ) = abs( real( zdum,KIND=qp) / 2._qp ) +abs( aimag( zdum ) / 2._qp ) + cabs1( zdum ) = abs( real( zdum,KIND=${ck}$) ) + abs( aimag( zdum ) ) + cabs2( zdum ) = abs( real( zdum,KIND=${ck}$) / 2._${ck}$ ) +abs( aimag( zdum ) / 2._${ck}$ ) ! Executable Statements info = 0 @@ -54616,10 +54618,10 @@ module stdlib_linalg_lapack_w ! quick return if possible if( n==0 )return ! determine machine dependent parameters to control overflow. - smlnum = stdlib_qlamch( 'SAFE MINIMUM' ) + smlnum = stdlib_${c2ri(ci)}$lamch( 'SAFE MINIMUM' ) bignum = one / smlnum - call stdlib_qlabad( smlnum, bignum ) - smlnum = smlnum / stdlib_qlamch( 'PRECISION' ) + call stdlib_${c2ri(ci)}$labad( smlnum, bignum ) + smlnum = smlnum / stdlib_${c2ri(ci)}$lamch( 'PRECISION' ) bignum = one / smlnum scale = one if( stdlib_lsame( normin, 'N' ) ) then @@ -54628,14 +54630,14 @@ module stdlib_linalg_lapack_w ! a is upper triangular. ip = 1 do j = 1, n - cnorm( j ) = stdlib_qzasum( j-1, ap( ip ), 1 ) + cnorm( j ) = stdlib_${c2ri(ci)}$zasum( j-1, ap( ip ), 1 ) ip = ip + j end do else ! a is lower triangular. ip = 1 do j = 1, n - 1 - cnorm( j ) = stdlib_qzasum( n-j, ap( ip+1 ), 1 ) + cnorm( j ) = stdlib_${c2ri(ci)}$zasum( n-j, ap( ip+1 ), 1 ) ip = ip + n - j + 1 end do cnorm( n ) = zero @@ -54643,16 +54645,16 @@ module stdlib_linalg_lapack_w end if ! scale the column norms by tscal if the maximum element in cnorm is ! greater than bignum/2. - imax = stdlib_iqamax( n, cnorm, 1 ) + imax = stdlib_i${c2ri(ci)}$amax( n, cnorm, 1 ) tmax = cnorm( imax ) if( tmax<=bignum*half ) then tscal = one else tscal = half / ( smlnum*tmax ) - call stdlib_qscal( n, tscal, cnorm, 1 ) + call stdlib_${c2ri(ci)}$scal( n, tscal, cnorm, 1 ) end if ! compute a bound on the computed solution vector to see if the - ! level 2 blas routine stdlib_wtpsv can be used. + ! level 2 blas routine stdlib_${ci}$tpsv can be used. xmax = zero do j = 1, n xmax = max( xmax, cabs2( x( j ) ) ) @@ -54775,14 +54777,14 @@ module stdlib_linalg_lapack_w if( ( grow*tscal )>smlnum ) then ! use the level 2 blas solve if the reciprocal of the bound on ! elements of x is not too small. - call stdlib_wtpsv( uplo, trans, diag, n, ap, x, 1 ) + call stdlib_${ci}$tpsv( uplo, trans, diag, n, ap, x, 1 ) else ! use a level 1 blas solve, scaling intermediate results. if( xmax>bignum*half ) then ! scale x so that its components are less than or equal to ! bignum in absolute value. scale = ( bignum*half ) / xmax - call stdlib_wdscal( n, scale, x, 1 ) + call stdlib_${ci}$dscal( n, scale, x, 1 ) xmax = bignum else xmax = xmax*two @@ -54806,12 +54808,12 @@ module stdlib_linalg_lapack_w if( xj>tjj*bignum ) then ! scale x by 1/b(j). rec = one / xj - call stdlib_wdscal( n, rec, x, 1 ) + call stdlib_${ci}$dscal( n, rec, x, 1 ) scale = scale*rec xmax = xmax*rec end if end if - x( j ) = stdlib_wladiv( x( j ), tjjs ) + x( j ) = stdlib_${ci}$ladiv( x( j ), tjjs ) xj = cabs1( x( j ) ) else if( tjj>zero ) then ! 0 < abs(a(j,j)) <= smlnum: @@ -54824,11 +54826,11 @@ module stdlib_linalg_lapack_w ! multiplying x(j) times column j. rec = rec / cnorm( j ) end if - call stdlib_wdscal( n, rec, x, 1 ) + call stdlib_${ci}$dscal( n, rec, x, 1 ) scale = scale*rec xmax = xmax*rec end if - x( j ) = stdlib_wladiv( x( j ), tjjs ) + x( j ) = stdlib_${ci}$ladiv( x( j ), tjjs ) xj = cabs1( x( j ) ) else ! a(j,j) = 0: set x(1:n) = 0, x(j) = 1, and @@ -54849,20 +54851,20 @@ module stdlib_linalg_lapack_w if( cnorm( j )>( bignum-xmax )*rec ) then ! scale x by 1/(2*abs(x(j))). rec = rec*half - call stdlib_wdscal( n, rec, x, 1 ) + call stdlib_${ci}$dscal( n, rec, x, 1 ) scale = scale*rec end if else if( xj*cnorm( j )>( bignum-xmax ) ) then ! scale x by 1/2. - call stdlib_wdscal( n, half, x, 1 ) + call stdlib_${ci}$dscal( n, half, x, 1 ) scale = scale*half end if if( upper ) then if( j>1 ) then ! compute the update ! x(1:j-1) := x(1:j-1) - x(j) * a(1:j-1,j) - call stdlib_waxpy( j-1, -x( j )*tscal, ap( ip-j+1 ), 1, x,1 ) - i = stdlib_iwamax( j-1, x, 1 ) + call stdlib_${ci}$axpy( j-1, -x( j )*tscal, ap( ip-j+1 ), 1, x,1 ) + i = stdlib_i${ci}$amax( j-1, x, 1 ) xmax = cabs1( x( i ) ) end if ip = ip - j @@ -54870,9 +54872,9 @@ module stdlib_linalg_lapack_w if( jone ) then ! divide by a(j,j) when scaling x if a(j,j) > 1. rec = min( one, rec*tjj ) - uscal = stdlib_wladiv( uscal, tjjs ) + uscal = stdlib_${ci}$ladiv( uscal, tjjs ) end if if( rectjj*bignum ) then ! scale x by 1/abs(x(j)). rec = one / xj - call stdlib_wdscal( n, rec, x, 1 ) + call stdlib_${ci}$dscal( n, rec, x, 1 ) scale = scale*rec xmax = xmax*rec end if end if - x( j ) = stdlib_wladiv( x( j ), tjjs ) + x( j ) = stdlib_${ci}$ladiv( x( j ), tjjs ) else if( tjj>zero ) then ! 0 < abs(a(j,j)) <= smlnum: if( xj>tjj*bignum ) then ! scale x by (1/abs(x(j)))*abs(a(j,j))*bignum. rec = ( tjj*bignum ) / xj - call stdlib_wdscal( n, rec, x, 1 ) + call stdlib_${ci}$dscal( n, rec, x, 1 ) scale = scale*rec xmax = xmax*rec end if - x( j ) = stdlib_wladiv( x( j ), tjjs ) + x( j ) = stdlib_${ci}$ladiv( x( j ), tjjs ) else ! a(j,j) = 0: set x(1:n) = 0, x(j) = 1, and ! scale = 0 and compute a solution to a**t *x = 0. @@ -54978,7 +54980,7 @@ module stdlib_linalg_lapack_w else ! compute x(j) := x(j) / a(j,j) - csumj if the dot ! product has already been divided by 1/a(j,j). - x( j ) = stdlib_wladiv( x( j ), tjjs ) - csumj + x( j ) = stdlib_${ci}$ladiv( x( j ), tjjs ) - csumj end if xmax = max( xmax, cabs1( x( j ) ) ) jlen = jlen + 1 @@ -55006,22 +55008,22 @@ module stdlib_linalg_lapack_w if( tjj>one ) then ! divide by a(j,j) when scaling x if a(j,j) > 1. rec = min( one, rec*tjj ) - uscal = stdlib_wladiv( uscal, tjjs ) + uscal = stdlib_${ci}$ladiv( uscal, tjjs ) end if if( rectjj*bignum ) then ! scale x by 1/abs(x(j)). rec = one / xj - call stdlib_wdscal( n, rec, x, 1 ) + call stdlib_${ci}$dscal( n, rec, x, 1 ) scale = scale*rec xmax = xmax*rec end if end if - x( j ) = stdlib_wladiv( x( j ), tjjs ) + x( j ) = stdlib_${ci}$ladiv( x( j ), tjjs ) else if( tjj>zero ) then ! 0 < abs(a(j,j)) <= smlnum: if( xj>tjj*bignum ) then ! scale x by (1/abs(x(j)))*abs(a(j,j))*bignum. rec = ( tjj*bignum ) / xj - call stdlib_wdscal( n, rec, x, 1 ) + call stdlib_${ci}$dscal( n, rec, x, 1 ) scale = scale*rec xmax = xmax*rec end if - x( j ) = stdlib_wladiv( x( j ), tjjs ) + x( j ) = stdlib_${ci}$ladiv( x( j ), tjjs ) else ! a(j,j) = 0: set x(1:n) = 0, x(j) = 1, and ! scale = 0 and compute a solution to a**h *x = 0. @@ -55084,7 +55086,7 @@ module stdlib_linalg_lapack_w else ! compute x(j) := x(j) / a(j,j) - csumj if the dot ! product has already been divided by 1/a(j,j). - x( j ) = stdlib_wladiv( x( j ), tjjs ) - csumj + x( j ) = stdlib_${ci}$ladiv( x( j ), tjjs ) - csumj end if xmax = max( xmax, cabs1( x( j ) ) ) jlen = jlen + 1 @@ -55095,13 +55097,13 @@ module stdlib_linalg_lapack_w end if ! scale the column norms by 1/tscal for return. if( tscal/=one ) then - call stdlib_qscal( n, one / tscal, cnorm, 1 ) + call stdlib_${c2ri(ci)}$scal( n, one / tscal, cnorm, 1 ) end if return - end subroutine stdlib_wlatps + end subroutine stdlib_${ci}$latps - pure subroutine stdlib_wlatrd( uplo, n, nb, a, lda, e, tau, w, ldw ) + pure subroutine stdlib_${ci}$latrd( uplo, n, nb, a, lda, e, tau, w, ldw ) !! ZLATRD: reduces NB rows and columns of a complex Hermitian matrix A to !! Hermitian tridiagonal form by a unitary similarity !! transformation Q**H * A * Q, and returns the matrices V and W which are @@ -55118,14 +55120,14 @@ module stdlib_linalg_lapack_w character, intent(in) :: uplo integer(ilp), intent(in) :: lda, ldw, n, nb ! Array Arguments - real(qp), intent(out) :: e(*) - complex(qp), intent(inout) :: a(lda,*) - complex(qp), intent(out) :: tau(*), w(ldw,*) + real(${ck}$), intent(out) :: e(*) + complex(${ck}$), intent(inout) :: a(lda,*) + complex(${ck}$), intent(out) :: tau(*), w(ldw,*) ! ===================================================================== ! Local Scalars integer(ilp) :: i, iw - complex(qp) :: alpha + complex(${ck}$) :: alpha ! Intrinsic Functions intrinsic :: real,min ! Executable Statements @@ -55137,87 +55139,87 @@ module stdlib_linalg_lapack_w iw = i - n + nb if( i1 ) then ! generate elementary reflector h(i) to annihilate ! a(1:i-2,i) alpha = a( i-1, i ) - call stdlib_wlarfg( i-1, alpha, a( 1, i ), 1, tau( i-1 ) ) - e( i-1 ) = real( alpha,KIND=qp) + call stdlib_${ci}$larfg( i-1, alpha, a( 1, i ), 1, tau( i-1 ) ) + e( i-1 ) = real( alpha,KIND=${ck}$) a( i-1, i ) = cone ! compute w(1:i-1,i) - call stdlib_whemv( 'UPPER', i-1, cone, a, lda, a( 1, i ), 1,czero, w( 1, iw ),& + call stdlib_${ci}$hemv( 'UPPER', i-1, cone, a, lda, a( 1, i ), 1,czero, w( 1, iw ),& 1 ) if( ismlnum ) then ! use the level 2 blas solve if the reciprocal of the bound on ! elements of x is not too small. - call stdlib_wtrsv( uplo, trans, diag, n, a, lda, x, 1 ) + call stdlib_${ci}$trsv( uplo, trans, diag, n, a, lda, x, 1 ) else ! use a level 1 blas solve, scaling intermediate results. if( xmax>bignum*half ) then ! scale x so that its components are less than or equal to ! bignum in absolute value. scale = ( bignum*half ) / xmax - call stdlib_wdscal( n, scale, x, 1 ) + call stdlib_${ci}$dscal( n, scale, x, 1 ) xmax = bignum else xmax = xmax*two @@ -55461,12 +55463,12 @@ module stdlib_linalg_lapack_w if( xj>tjj*bignum ) then ! scale x by 1/b(j). rec = one / xj - call stdlib_wdscal( n, rec, x, 1 ) + call stdlib_${ci}$dscal( n, rec, x, 1 ) scale = scale*rec xmax = xmax*rec end if end if - x( j ) = stdlib_wladiv( x( j ), tjjs ) + x( j ) = stdlib_${ci}$ladiv( x( j ), tjjs ) xj = cabs1( x( j ) ) else if( tjj>zero ) then ! 0 < abs(a(j,j)) <= smlnum: @@ -55479,11 +55481,11 @@ module stdlib_linalg_lapack_w ! multiplying x(j) times column j. rec = rec / cnorm( j ) end if - call stdlib_wdscal( n, rec, x, 1 ) + call stdlib_${ci}$dscal( n, rec, x, 1 ) scale = scale*rec xmax = xmax*rec end if - x( j ) = stdlib_wladiv( x( j ), tjjs ) + x( j ) = stdlib_${ci}$ladiv( x( j ), tjjs ) xj = cabs1( x( j ) ) else ! a(j,j) = 0: set x(1:n) = 0, x(j) = 1, and @@ -55504,29 +55506,29 @@ module stdlib_linalg_lapack_w if( cnorm( j )>( bignum-xmax )*rec ) then ! scale x by 1/(2*abs(x(j))). rec = rec*half - call stdlib_wdscal( n, rec, x, 1 ) + call stdlib_${ci}$dscal( n, rec, x, 1 ) scale = scale*rec end if else if( xj*cnorm( j )>( bignum-xmax ) ) then ! scale x by 1/2. - call stdlib_wdscal( n, half, x, 1 ) + call stdlib_${ci}$dscal( n, half, x, 1 ) scale = scale*half end if if( upper ) then if( j>1 ) then ! compute the update ! x(1:j-1) := x(1:j-1) - x(j) * a(1:j-1,j) - call stdlib_waxpy( j-1, -x( j )*tscal, a( 1, j ), 1, x,1 ) - i = stdlib_iwamax( j-1, x, 1 ) + call stdlib_${ci}$axpy( j-1, -x( j )*tscal, a( 1, j ), 1, x,1 ) + i = stdlib_i${ci}$amax( j-1, x, 1 ) xmax = cabs1( x( i ) ) end if else if( jone ) then ! divide by a(j,j) when scaling x if a(j,j) > 1. rec = min( one, rec*tjj ) - uscal = stdlib_wladiv( uscal, tjjs ) + uscal = stdlib_${ci}$ladiv( uscal, tjjs ) end if if( rectjj*bignum ) then ! scale x by 1/abs(x(j)). rec = one / xj - call stdlib_wdscal( n, rec, x, 1 ) + call stdlib_${ci}$dscal( n, rec, x, 1 ) scale = scale*rec xmax = xmax*rec end if end if - x( j ) = stdlib_wladiv( x( j ), tjjs ) + x( j ) = stdlib_${ci}$ladiv( x( j ), tjjs ) else if( tjj>zero ) then ! 0 < abs(a(j,j)) <= smlnum: if( xj>tjj*bignum ) then ! scale x by (1/abs(x(j)))*abs(a(j,j))*bignum. rec = ( tjj*bignum ) / xj - call stdlib_wdscal( n, rec, x, 1 ) + call stdlib_${ci}$dscal( n, rec, x, 1 ) scale = scale*rec xmax = xmax*rec end if - x( j ) = stdlib_wladiv( x( j ), tjjs ) + x( j ) = stdlib_${ci}$ladiv( x( j ), tjjs ) else ! a(j,j) = 0: set x(1:n) = 0, x(j) = 1, and ! scale = 0 and compute a solution to a**t *x = 0. @@ -55629,7 +55631,7 @@ module stdlib_linalg_lapack_w else ! compute x(j) := x(j) / a(j,j) - csumj if the dot ! product has already been divided by 1/a(j,j). - x( j ) = stdlib_wladiv( x( j ), tjjs ) - csumj + x( j ) = stdlib_${ci}$ladiv( x( j ), tjjs ) - csumj end if xmax = max( xmax, cabs1( x( j ) ) ) end do loop_170 @@ -55653,22 +55655,22 @@ module stdlib_linalg_lapack_w if( tjj>one ) then ! divide by a(j,j) when scaling x if a(j,j) > 1. rec = min( one, rec*tjj ) - uscal = stdlib_wladiv( uscal, tjjs ) + uscal = stdlib_${ci}$ladiv( uscal, tjjs ) end if if( rectjj*bignum ) then ! scale x by 1/abs(x(j)). rec = one / xj - call stdlib_wdscal( n, rec, x, 1 ) + call stdlib_${ci}$dscal( n, rec, x, 1 ) scale = scale*rec xmax = xmax*rec end if end if - x( j ) = stdlib_wladiv( x( j ), tjjs ) + x( j ) = stdlib_${ci}$ladiv( x( j ), tjjs ) else if( tjj>zero ) then ! 0 < abs(a(j,j)) <= smlnum: if( xj>tjj*bignum ) then ! scale x by (1/abs(x(j)))*abs(a(j,j))*bignum. rec = ( tjj*bignum ) / xj - call stdlib_wdscal( n, rec, x, 1 ) + call stdlib_${ci}$dscal( n, rec, x, 1 ) scale = scale*rec xmax = xmax*rec end if - x( j ) = stdlib_wladiv( x( j ), tjjs ) + x( j ) = stdlib_${ci}$ladiv( x( j ), tjjs ) else ! a(j,j) = 0: set x(1:n) = 0, x(j) = 1, and ! scale = 0 and compute a solution to a**h *x = 0. @@ -55731,7 +55733,7 @@ module stdlib_linalg_lapack_w else ! compute x(j) := x(j) / a(j,j) - csumj if the dot ! product has already been divided by 1/a(j,j). - x( j ) = stdlib_wladiv( x( j ), tjjs ) - csumj + x( j ) = stdlib_${ci}$ladiv( x( j ), tjjs ) - csumj end if xmax = max( xmax, cabs1( x( j ) ) ) end do loop_220 @@ -55740,13 +55742,13 @@ module stdlib_linalg_lapack_w end if ! scale the column norms by 1/tscal for return. if( tscal/=one ) then - call stdlib_qscal( n, one / tscal, cnorm, 1 ) + call stdlib_${c2ri(ci)}$scal( n, one / tscal, cnorm, 1 ) end if return - end subroutine stdlib_wlatrs + end subroutine stdlib_${ci}$latrs - pure subroutine stdlib_wlatrz( m, n, l, a, lda, tau, work ) + pure subroutine stdlib_${ci}$latrz( m, n, l, a, lda, tau, work ) !! ZLATRZ: factors the M-by-(M+L) complex upper trapezoidal matrix !! [ A1 A2 ] = [ A(1:M,1:M) A(1:M,N-L+1:N) ] as ( R 0 ) * Z by means !! of unitary transformations, where Z is an (M+L)-by-(M+L) unitary @@ -55757,13 +55759,13 @@ module stdlib_linalg_lapack_w ! Scalar Arguments integer(ilp), intent(in) :: l, lda, m, n ! Array Arguments - complex(qp), intent(inout) :: a(lda,*) - complex(qp), intent(out) :: tau(*), work(*) + complex(${ck}$), intent(inout) :: a(lda,*) + complex(${ck}$), intent(out) :: tau(*), work(*) ! ===================================================================== ! Local Scalars integer(ilp) :: i - complex(qp) :: alpha + complex(${ck}$) :: alpha ! Intrinsic Functions intrinsic :: conjg ! Executable Statements @@ -55779,20 +55781,20 @@ module stdlib_linalg_lapack_w do i = m, 1, -1 ! generate elementary reflector h(i) to annihilate ! [ a(i,i) a(i,n-l+1:n) ] - call stdlib_wlacgv( l, a( i, n-l+1 ), lda ) + call stdlib_${ci}$lacgv( l, a( i, n-l+1 ), lda ) alpha = conjg( a( i, i ) ) - call stdlib_wlarfg( l+1, alpha, a( i, n-l+1 ), lda, tau( i ) ) + call stdlib_${ci}$larfg( l+1, alpha, a( i, n-l+1 ), lda, tau( i ) ) tau( i ) = conjg( tau( i ) ) ! apply h(i) to a(1:i-1,i:n) from the right - call stdlib_wlarz( 'RIGHT', i-1, n-i+1, l, a( i, n-l+1 ), lda,conjg( tau( i ) ), a( & + call stdlib_${ci}$larz( 'RIGHT', i-1, n-i+1, l, a( i, n-l+1 ), lda,conjg( tau( i ) ), a( & 1, i ), lda, work ) a( i, i ) = conjg( alpha ) end do return - end subroutine stdlib_wlatrz + end subroutine stdlib_${ci}$latrz - pure subroutine stdlib_wlatsqr( m, n, mb, nb, a, lda, t, ldt, work,lwork, info) + pure subroutine stdlib_${ci}$latsqr( m, n, mb, nb, a, lda, t, ldt, work,lwork, info) !! ZLATSQR: computes a blocked Tall-Skinny QR factorization of !! a complex M-by-N matrix A for M >= N: !! A = Q * ( R ), @@ -55811,8 +55813,8 @@ module stdlib_linalg_lapack_w integer(ilp), intent(out) :: info integer(ilp), intent(in) :: lda, m, n, mb, nb, ldt, lwork ! Array Arguments - complex(qp), intent(inout) :: a(lda,*) - complex(qp), intent(out) :: work(*), t(ldt,*) + complex(${ck}$), intent(inout) :: a(lda,*) + complex(${ck}$), intent(out) :: work(*), t(ldt,*) ! ===================================================================== ! Local Scalars logical(lk) :: lquery @@ -55853,31 +55855,31 @@ module stdlib_linalg_lapack_w end if ! the qr decomposition if ((mb<=n).or.(mb>=m)) then - call stdlib_wgeqrt( m, n, nb, a, lda, t, ldt, work, info) + call stdlib_${ci}$geqrt( m, n, nb, a, lda, t, ldt, work, info) return end if kk = mod((m-n),(mb-n)) ii=m-kk+1 ! compute the qr factorization of the first block a(1:mb,1:n) - call stdlib_wgeqrt( mb, n, nb, a(1,1), lda, t, ldt, work, info ) + call stdlib_${ci}$geqrt( mb, n, nb, a(1,1), lda, t, ldt, work, info ) ctr = 1 do i = mb+1, ii-mb+n , (mb-n) ! compute the qr factorization of the current block a(i:i+mb-n,1:n) - call stdlib_wtpqrt( mb-n, n, 0, nb, a(1,1), lda, a( i, 1 ), lda,t(1, ctr * n + 1),& + call stdlib_${ci}$tpqrt( mb-n, n, 0, nb, a(1,1), lda, a( i, 1 ), lda,t(1, ctr * n + 1),& ldt, work, info ) ctr = ctr + 1 end do ! compute the qr factorization of the last block a(ii:m,1:n) if (ii<=m) then - call stdlib_wtpqrt( kk, n, 0, nb, a(1,1), lda, a( ii, 1 ), lda,t(1,ctr * n + 1), & + call stdlib_${ci}$tpqrt( kk, n, 0, nb, a(1,1), lda, a( ii, 1 ), lda,t(1,ctr * n + 1), & ldt,work, info ) end if work( 1 ) = n*nb return - end subroutine stdlib_wlatsqr + end subroutine stdlib_${ci}$latsqr - pure subroutine stdlib_wlaunhr_col_getrfnp( m, n, a, lda, d, info ) + pure subroutine stdlib_${ci}$launhr_col_getrfnp( m, n, a, lda, d, info ) !! ZLAUNHR_COL_GETRFNP: computes the modified LU factorization without !! pivoting of a complex general M-by-N matrix A. The factorization has !! the form: @@ -55918,8 +55920,8 @@ module stdlib_linalg_lapack_w integer(ilp), intent(out) :: info integer(ilp), intent(in) :: lda, m, n ! Array Arguments - complex(qp), intent(inout) :: a(lda,*) - complex(qp), intent(out) :: d(*) + complex(${ck}$), intent(inout) :: a(lda,*) + complex(${ck}$), intent(out) :: d(*) ! ===================================================================== ! Local Scalars @@ -55946,21 +55948,21 @@ module stdlib_linalg_lapack_w nb = stdlib_ilaenv( 1, 'ZLAUNHR_COL_GETRFNP', ' ', m, n, -1, -1 ) if( nb<=1 .or. nb>=min( m, n ) ) then ! use unblocked code. - call stdlib_wlaunhr_col_getrfnp2( m, n, a, lda, d, info ) + call stdlib_${ci}$launhr_col_getrfnp2( m, n, a, lda, d, info ) else ! use blocked code. do j = 1, min( m, n ), nb jb = min( min( m, n )-j+1, nb ) ! factor diagonal and subdiagonal blocks. - call stdlib_wlaunhr_col_getrfnp2( m-j+1, jb, a( j, j ), lda,d( j ), iinfo ) + call stdlib_${ci}$launhr_col_getrfnp2( m-j+1, jb, a( j, j ), lda,d( j ), iinfo ) if( j+jb<=n ) then ! compute block row of u. - call stdlib_wtrsm( 'LEFT', 'LOWER', 'NO TRANSPOSE', 'UNIT', jb,n-j-jb+1, cone,& + call stdlib_${ci}$trsm( 'LEFT', 'LOWER', 'NO TRANSPOSE', 'UNIT', jb,n-j-jb+1, cone,& a( j, j ), lda, a( j, j+jb ),lda ) if( j+jb<=m ) then ! update trailing submatrix. - call stdlib_wgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', m-j-jb+1,n-j-jb+1, jb, -& + call stdlib_${ci}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', m-j-jb+1,n-j-jb+1, jb, -& cone, a( j+jb, j ), lda,a( j, j+jb ), lda, cone, a( j+jb, j+jb ),lda ) end if @@ -55968,10 +55970,10 @@ module stdlib_linalg_lapack_w end do end if return - end subroutine stdlib_wlaunhr_col_getrfnp + end subroutine stdlib_${ci}$launhr_col_getrfnp - pure recursive subroutine stdlib_wlaunhr_col_getrfnp2( m, n, a, lda, d, info ) + pure recursive subroutine stdlib_${ci}$launhr_col_getrfnp2( m, n, a, lda, d, info ) !! ZLAUNHR_COL_GETRFNP2: computes the modified LU factorization without !! pivoting of a complex general M-by-N matrix A. The factorization has !! the form: @@ -56027,21 +56029,21 @@ module stdlib_linalg_lapack_w integer(ilp), intent(out) :: info integer(ilp), intent(in) :: lda, m, n ! Array Arguments - complex(qp), intent(inout) :: a(lda,*) - complex(qp), intent(out) :: d(*) + complex(${ck}$), intent(inout) :: a(lda,*) + complex(${ck}$), intent(out) :: d(*) ! ===================================================================== ! Local Scalars - real(qp) :: sfmin + real(${ck}$) :: sfmin integer(ilp) :: i, iinfo, n1, n2 - complex(qp) :: z + complex(${ck}$) :: z ! Intrinsic Functions intrinsic :: abs,real,cmplx,aimag,sign,max,min ! Statement Functions - real(qp) :: cabs1 + real(${ck}$) :: cabs1 ! Statement Function Definitions - cabs1( z ) = abs( real( z,KIND=qp) ) + abs( aimag( z ) ) + cabs1( z ) = abs( real( z,KIND=${ck}$) ) + abs( aimag( z ) ) ! Executable Statements ! test the input parameters info = 0 @@ -56062,22 +56064,22 @@ module stdlib_linalg_lapack_w ! one row case, (also recursion termination case), ! use unblocked code ! transfer the sign - d( 1 ) = cmplx( -sign( one, real( a( 1, 1 ),KIND=qp) ),KIND=qp) + d( 1 ) = cmplx( -sign( one, real( a( 1, 1 ),KIND=${ck}$) ),KIND=${ck}$) ! construct the row of u a( 1, 1 ) = a( 1, 1 ) - d( 1 ) else if( n==1 ) then ! one column case, (also recursion termination case), ! use unblocked code ! transfer the sign - d( 1 ) = cmplx( -sign( one, real( a( 1, 1 ),KIND=qp) ),KIND=qp) + d( 1 ) = cmplx( -sign( one, real( a( 1, 1 ),KIND=${ck}$) ),KIND=${ck}$) ! construct the row of u a( 1, 1 ) = a( 1, 1 ) - d( 1 ) ! scale the elements 2:m of the column ! determine machine safe minimum - sfmin = stdlib_qlamch('S') + sfmin = stdlib_${c2ri(ci)}$lamch('S') ! construct the subdiagonal elements of l if( cabs1( a( 1, 1 ) ) >= sfmin ) then - call stdlib_wscal( m-1, cone / a( 1, 1 ), a( 2, 1 ), 1 ) + call stdlib_${ci}$scal( m-1, cone / a( 1, 1 ), a( 2, 1 ), 1 ) else do i = 2, m a( i, 1 ) = a( i, 1 ) / a( 1, 1 ) @@ -56088,26 +56090,26 @@ module stdlib_linalg_lapack_w n1 = min( m, n ) / 2 n2 = n-n1 ! factor b11, recursive call - call stdlib_wlaunhr_col_getrfnp2( n1, n1, a, lda, d, iinfo ) + call stdlib_${ci}$launhr_col_getrfnp2( n1, n1, a, lda, d, iinfo ) ! solve for b21 - call stdlib_wtrsm( 'R', 'U', 'N', 'N', m-n1, n1, cone, a, lda,a( n1+1, 1 ), lda ) + call stdlib_${ci}$trsm( 'R', 'U', 'N', 'N', m-n1, n1, cone, a, lda,a( n1+1, 1 ), lda ) ! solve for b12 - call stdlib_wtrsm( 'L', 'L', 'N', 'U', n1, n2, cone, a, lda,a( 1, n1+1 ), lda ) + call stdlib_${ci}$trsm( 'L', 'L', 'N', 'U', n1, n2, cone, a, lda,a( 1, n1+1 ), lda ) ! update b22, i.e. compute the schur complement ! b22 := b22 - b21*b12 - call stdlib_wgemm( 'N', 'N', m-n1, n2, n1, -cone, a( n1+1, 1 ), lda,a( 1, n1+1 ), & + call stdlib_${ci}$gemm( 'N', 'N', m-n1, n2, n1, -cone, a( n1+1, 1 ), lda,a( 1, n1+1 ), & lda, cone, a( n1+1, n1+1 ), lda ) ! factor b22, recursive call - call stdlib_wlaunhr_col_getrfnp2( m-n1, n2, a( n1+1, n1+1 ), lda,d( n1+1 ), iinfo ) + call stdlib_${ci}$launhr_col_getrfnp2( m-n1, n2, a( n1+1, n1+1 ), lda,d( n1+1 ), iinfo ) end if return - end subroutine stdlib_wlaunhr_col_getrfnp2 + end subroutine stdlib_${ci}$launhr_col_getrfnp2 - pure subroutine stdlib_wlauu2( uplo, n, a, lda, info ) + pure subroutine stdlib_${ci}$lauu2( uplo, n, a, lda, info ) !! ZLAUU2: computes the product U * U**H or L**H * L, where the triangular !! factor U or L is stored in the upper or lower triangular part of !! the array A. @@ -56124,13 +56126,13 @@ module stdlib_linalg_lapack_w integer(ilp), intent(out) :: info integer(ilp), intent(in) :: lda, n ! Array Arguments - complex(qp), intent(inout) :: a(lda,*) + complex(${ck}$), intent(inout) :: a(lda,*) ! ===================================================================== ! Local Scalars logical(lk) :: upper integer(ilp) :: i - real(qp) :: aii + real(${ck}$) :: aii ! Intrinsic Functions intrinsic :: real,cmplx,max ! Executable Statements @@ -56153,39 +56155,39 @@ module stdlib_linalg_lapack_w if( upper ) then ! compute the product u * u**h. do i = 1, n - aii = real( a( i, i ),KIND=qp) + aii = real( a( i, i ),KIND=${ck}$) if( i=n ) then ! use unblocked code - call stdlib_wlauu2( uplo, n, a, lda, info ) + call stdlib_${ci}$lauu2( uplo, n, a, lda, info ) else ! use blocked code if( upper ) then ! compute the product u * u**h. do i = 1, n, nb ib = min( nb, n-i+1 ) - call stdlib_wtrmm( 'RIGHT', 'UPPER', 'CONJUGATE TRANSPOSE','NON-UNIT', i-1, & + call stdlib_${ci}$trmm( 'RIGHT', 'UPPER', 'CONJUGATE TRANSPOSE','NON-UNIT', i-1, & ib, cone, a( i, i ), lda,a( 1, i ), lda ) - call stdlib_wlauu2( 'UPPER', ib, a( i, i ), lda, info ) + call stdlib_${ci}$lauu2( 'UPPER', ib, a( i, i ), lda, info ) if( i+ib<=n ) then - call stdlib_wgemm( 'NO TRANSPOSE', 'CONJUGATE TRANSPOSE',i-1, ib, n-i-ib+1,& + call stdlib_${ci}$gemm( 'NO TRANSPOSE', 'CONJUGATE TRANSPOSE',i-1, ib, n-i-ib+1,& cone, a( 1, i+ib ),lda, a( i, i+ib ), lda, cone, a( 1, i ),lda ) - call stdlib_wherk( 'UPPER', 'NO TRANSPOSE', ib, n-i-ib+1,one, a( i, i+ib ),& + call stdlib_${ci}$herk( 'UPPER', 'NO TRANSPOSE', ib, n-i-ib+1,one, a( i, i+ib ),& lda, one, a( i, i ),lda ) end if end do @@ -56253,23 +56255,23 @@ module stdlib_linalg_lapack_w ! compute the product l**h * l. do i = 1, n, nb ib = min( nb, n-i+1 ) - call stdlib_wtrmm( 'LEFT', 'LOWER', 'CONJUGATE TRANSPOSE','NON-UNIT', ib, i-1,& + call stdlib_${ci}$trmm( 'LEFT', 'LOWER', 'CONJUGATE TRANSPOSE','NON-UNIT', ib, i-1,& cone, a( i, i ), lda,a( i, 1 ), lda ) - call stdlib_wlauu2( 'LOWER', ib, a( i, i ), lda, info ) + call stdlib_${ci}$lauu2( 'LOWER', ib, a( i, i ), lda, info ) if( i+ib<=n ) then - call stdlib_wgemm( 'CONJUGATE TRANSPOSE', 'NO TRANSPOSE', ib,i-1, n-i-ib+1,& + call stdlib_${ci}$gemm( 'CONJUGATE TRANSPOSE', 'NO TRANSPOSE', ib,i-1, n-i-ib+1,& cone, a( i+ib, i ), lda,a( i+ib, 1 ), lda, cone, a( i, 1 ), lda ) - call stdlib_wherk( 'LOWER', 'CONJUGATE TRANSPOSE', ib,n-i-ib+1, one, a( i+& + call stdlib_${ci}$herk( 'LOWER', 'CONJUGATE TRANSPOSE', ib,n-i-ib+1, one, a( i+& ib, i ), lda, one,a( i, i ), lda ) end if end do end if end if return - end subroutine stdlib_wlauum + end subroutine stdlib_${ci}$lauum - pure subroutine stdlib_wpbcon( uplo, n, kd, ab, ldab, anorm, rcond, work,rwork, info ) + pure subroutine stdlib_${ci}$pbcon( uplo, n, kd, ab, ldab, anorm, rcond, work,rwork, info ) !! ZPBCON: estimates the reciprocal of the condition number (in the !! 1-norm) of a complex Hermitian positive definite band matrix using !! the Cholesky factorization A = U**H*U or A = L*L**H computed by @@ -56284,28 +56286,28 @@ module stdlib_linalg_lapack_w character, intent(in) :: uplo integer(ilp), intent(out) :: info integer(ilp), intent(in) :: kd, ldab, n - real(qp), intent(in) :: anorm - real(qp), intent(out) :: rcond + real(${ck}$), intent(in) :: anorm + real(${ck}$), intent(out) :: rcond ! Array Arguments - real(qp), intent(out) :: rwork(*) - complex(qp), intent(in) :: ab(ldab,*) - complex(qp), intent(out) :: work(*) + real(${ck}$), intent(out) :: rwork(*) + complex(${ck}$), intent(in) :: ab(ldab,*) + complex(${ck}$), intent(out) :: work(*) ! ===================================================================== ! Local Scalars logical(lk) :: upper character :: normin integer(ilp) :: ix, kase - real(qp) :: ainvnm, scale, scalel, scaleu, smlnum - complex(qp) :: zdum + real(${ck}$) :: ainvnm, scale, scalel, scaleu, smlnum + complex(${ck}$) :: zdum ! Local Arrays integer(ilp) :: isave(3) ! Intrinsic Functions intrinsic :: abs,real,aimag ! Statement Functions - real(qp) :: cabs1 + real(${ck}$) :: cabs1 ! Statement Function Definitions - cabs1( zdum ) = abs( real( zdum,KIND=qp) ) + abs( aimag( zdum ) ) + cabs1( zdum ) = abs( real( zdum,KIND=${ck}$) ) + abs( aimag( zdum ) ) ! Executable Statements ! test the input parameters. info = 0 @@ -56333,36 +56335,36 @@ module stdlib_linalg_lapack_w else if( anorm==zero ) then return end if - smlnum = stdlib_qlamch( 'SAFE MINIMUM' ) + smlnum = stdlib_${c2ri(ci)}$lamch( 'SAFE MINIMUM' ) ! estimate the 1-norm of the inverse. kase = 0 normin = 'N' 10 continue - call stdlib_wlacn2( n, work( n+1 ), work, ainvnm, kase, isave ) + call stdlib_${ci}$lacn2( n, work( n+1 ), work, ainvnm, kase, isave ) if( kase/=0 ) then if( upper ) then ! multiply by inv(u**h). - call stdlib_wlatbs( 'UPPER', 'CONJUGATE TRANSPOSE', 'NON-UNIT',normin, n, kd, ab,& + call stdlib_${ci}$latbs( 'UPPER', 'CONJUGATE TRANSPOSE', 'NON-UNIT',normin, n, kd, ab,& ldab, work, scalel, rwork,info ) normin = 'Y' ! multiply by inv(u). - call stdlib_wlatbs( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', normin, n,kd, ab, ldab, & + call stdlib_${ci}$latbs( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', normin, n,kd, ab, ldab, & work, scaleu, rwork, info ) else ! multiply by inv(l). - call stdlib_wlatbs( 'LOWER', 'NO TRANSPOSE', 'NON-UNIT', normin, n,kd, ab, ldab, & + call stdlib_${ci}$latbs( 'LOWER', 'NO TRANSPOSE', 'NON-UNIT', normin, n,kd, ab, ldab, & work, scalel, rwork, info ) normin = 'Y' ! multiply by inv(l**h). - call stdlib_wlatbs( 'LOWER', 'CONJUGATE TRANSPOSE', 'NON-UNIT',normin, n, kd, ab,& + call stdlib_${ci}$latbs( 'LOWER', 'CONJUGATE TRANSPOSE', 'NON-UNIT',normin, n, kd, ab,& ldab, work, scaleu, rwork,info ) end if ! multiply by 1/scale if doing so will not cause overflow. scale = scalel*scaleu if( scale/=one ) then - ix = stdlib_iwamax( n, work, 1 ) + ix = stdlib_i${ci}$amax( n, work, 1 ) if( scaleeps .and. two*berr( j )<=lstres .and.count<=itmax ) then ! update solution and try again. - call stdlib_wpbtrs( uplo, n, kd, 1, afb, ldafb, work, n, info ) - call stdlib_waxpy( n, cone, work, 1, x( 1, j ), 1 ) + call stdlib_${ci}$pbtrs( uplo, n, kd, 1, afb, ldafb, work, n, info ) + call stdlib_${ci}$axpy( n, cone, work, 1, x( 1, j ), 1 ) lstres = berr( j ) count = count + 1 go to 20 @@ -56618,7 +56620,7 @@ module stdlib_linalg_lapack_w ! 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_wlacn2 to estimate the infinity-norm of the matrix + ! 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 @@ -56630,11 +56632,11 @@ module stdlib_linalg_lapack_w end do kase = 0 100 continue - call stdlib_wlacn2( n, work( n+1 ), work, ferr( j ), kase, isave ) + call stdlib_${ci}$lacn2( n, work( n+1 ), work, ferr( j ), kase, isave ) if( kase/=0 ) then if( kase==1 ) then ! multiply by diag(w)*inv(a**h). - call stdlib_wpbtrs( uplo, n, kd, 1, afb, ldafb, work, n, info ) + call stdlib_${ci}$pbtrs( uplo, n, kd, 1, afb, ldafb, work, n, info ) do i = 1, n work( i ) = rwork( i )*work( i ) end do @@ -56643,7 +56645,7 @@ module stdlib_linalg_lapack_w do i = 1, n work( i ) = rwork( i )*work( i ) end do - call stdlib_wpbtrs( uplo, n, kd, 1, afb, ldafb, work, n, info ) + call stdlib_${ci}$pbtrs( uplo, n, kd, 1, afb, ldafb, work, n, info ) end if go to 100 end if @@ -56655,10 +56657,10 @@ module stdlib_linalg_lapack_w if( lstres/=zero )ferr( j ) = ferr( j ) / lstres end do loop_140 return - end subroutine stdlib_wpbrfs + end subroutine stdlib_${ci}$pbrfs - pure subroutine stdlib_wpbstf( uplo, n, kd, ab, ldab, info ) + pure subroutine stdlib_${ci}$pbstf( uplo, n, kd, ab, ldab, info ) !! ZPBSTF: computes a split Cholesky factorization of a complex !! Hermitian positive definite band matrix A. !! This routine is designed to be used in conjunction with ZHBGST. @@ -56676,13 +56678,13 @@ module stdlib_linalg_lapack_w integer(ilp), intent(out) :: info integer(ilp), intent(in) :: kd, ldab, n ! Array Arguments - complex(qp), intent(inout) :: ab(ldab,*) + complex(${ck}$), intent(inout) :: ab(ldab,*) ! ===================================================================== ! Local Scalars logical(lk) :: upper integer(ilp) :: j, kld, km, m - real(qp) :: ajj + real(${ck}$) :: ajj ! Intrinsic Functions intrinsic :: real,max,min,sqrt ! Executable Statements @@ -56711,7 +56713,7 @@ module stdlib_linalg_lapack_w ! factorize a(m+1:n,m+1:n) as l**h*l, and update a(1:m,1:m). do j = n, m + 1, -1 ! compute s(j,j) and test for non-positive-definiteness. - ajj = real( ab( kd+1, j ),KIND=qp) + ajj = real( ab( kd+1, j ),KIND=${ck}$) if( ajj<=zero ) then ab( kd+1, j ) = ajj go to 50 @@ -56721,14 +56723,14 @@ module stdlib_linalg_lapack_w km = min( j-1, kd ) ! compute elements j-km:j-1 of the j-th column and update the ! the leading submatrix within the band. - call stdlib_wdscal( km, one / ajj, ab( kd+1-km, j ), 1 ) - call stdlib_wher( 'UPPER', km, -one, ab( kd+1-km, j ), 1,ab( kd+1, j-km ), kld ) + call stdlib_${ci}$dscal( km, one / ajj, ab( kd+1-km, j ), 1 ) + call stdlib_${ci}$her( 'UPPER', km, -one, ab( kd+1-km, j ), 1,ab( kd+1, j-km ), kld ) end do ! factorize the updated submatrix a(1:m,1:m) as u**h*u. do j = 1, m ! compute s(j,j) and test for non-positive-definiteness. - ajj = real( ab( kd+1, j ),KIND=qp) + ajj = real( ab( kd+1, j ),KIND=${ck}$) if( ajj<=zero ) then ab( kd+1, j ) = ajj go to 50 @@ -56739,18 +56741,18 @@ module stdlib_linalg_lapack_w ! compute elements j+1:j+km of the j-th row and update the ! trailing submatrix within the band. if( km>0 ) then - call stdlib_wdscal( km, one / ajj, ab( kd, j+1 ), kld ) - call stdlib_wlacgv( km, ab( kd, j+1 ), kld ) - call stdlib_wher( 'UPPER', km, -one, ab( kd, j+1 ), kld,ab( kd+1, j+1 ), kld ) + call stdlib_${ci}$dscal( km, one / ajj, ab( kd, j+1 ), kld ) + call stdlib_${ci}$lacgv( km, ab( kd, j+1 ), kld ) + call stdlib_${ci}$her( 'UPPER', km, -one, ab( kd, j+1 ), kld,ab( kd+1, j+1 ), kld ) - call stdlib_wlacgv( km, ab( kd, j+1 ), kld ) + call stdlib_${ci}$lacgv( km, ab( kd, j+1 ), kld ) end if end do else ! factorize a(m+1:n,m+1:n) as l**h*l, and update a(1:m,1:m). do j = n, m + 1, -1 ! compute s(j,j) and test for non-positive-definiteness. - ajj = real( ab( 1, j ),KIND=qp) + ajj = real( ab( 1, j ),KIND=${ck}$) if( ajj<=zero ) then ab( 1, j ) = ajj go to 50 @@ -56760,16 +56762,16 @@ module stdlib_linalg_lapack_w km = min( j-1, kd ) ! compute elements j-km:j-1 of the j-th row and update the ! trailing submatrix within the band. - call stdlib_wdscal( km, one / ajj, ab( km+1, j-km ), kld ) - call stdlib_wlacgv( km, ab( km+1, j-km ), kld ) - call stdlib_wher( 'LOWER', km, -one, ab( km+1, j-km ), kld,ab( 1, j-km ), kld ) + call stdlib_${ci}$dscal( km, one / ajj, ab( km+1, j-km ), kld ) + call stdlib_${ci}$lacgv( km, ab( km+1, j-km ), kld ) + call stdlib_${ci}$her( 'LOWER', km, -one, ab( km+1, j-km ), kld,ab( 1, j-km ), kld ) - call stdlib_wlacgv( km, ab( km+1, j-km ), kld ) + call stdlib_${ci}$lacgv( km, ab( km+1, j-km ), kld ) end do ! factorize the updated submatrix a(1:m,1:m) as u**h*u. do j = 1, m ! compute s(j,j) and test for non-positive-definiteness. - ajj = real( ab( 1, j ),KIND=qp) + ajj = real( ab( 1, j ),KIND=${ck}$) if( ajj<=zero ) then ab( 1, j ) = ajj go to 50 @@ -56780,8 +56782,8 @@ module stdlib_linalg_lapack_w ! compute elements j+1:j+km of the j-th column and update the ! trailing submatrix within the band. if( km>0 ) then - call stdlib_wdscal( km, one / ajj, ab( 2, j ), 1 ) - call stdlib_wher( 'LOWER', km, -one, ab( 2, j ), 1,ab( 1, j+1 ), kld ) + call stdlib_${ci}$dscal( km, one / ajj, ab( 2, j ), 1 ) + call stdlib_${ci}$her( 'LOWER', km, -one, ab( 2, j ), 1,ab( 1, j+1 ), kld ) end if end do end if @@ -56789,10 +56791,10 @@ module stdlib_linalg_lapack_w 50 continue info = j return - end subroutine stdlib_wpbstf + end subroutine stdlib_${ci}$pbstf - pure subroutine stdlib_wpbsv( uplo, n, kd, nrhs, ab, ldab, b, ldb, info ) + pure subroutine stdlib_${ci}$pbsv( uplo, n, kd, nrhs, ab, ldab, b, ldb, info ) !! ZPBSV: computes the solution to a complex system of linear equations !! A * X = B, !! where A is an N-by-N Hermitian positive definite band matrix and X @@ -56812,7 +56814,7 @@ module stdlib_linalg_lapack_w integer(ilp), intent(out) :: info integer(ilp), intent(in) :: kd, ldab, ldb, n, nrhs ! Array Arguments - complex(qp), intent(inout) :: ab(ldab,*), b(ldb,*) + complex(${ck}$), intent(inout) :: ab(ldab,*), b(ldb,*) ! ===================================================================== ! Intrinsic Functions intrinsic :: max @@ -56837,16 +56839,16 @@ module stdlib_linalg_lapack_w return end if ! compute the cholesky factorization a = u**h *u or a = l*l**h. - call stdlib_wpbtrf( uplo, n, kd, ab, ldab, info ) + call stdlib_${ci}$pbtrf( uplo, n, kd, ab, ldab, info ) if( info==0 ) then ! solve the system a*x = b, overwriting b with x. - call stdlib_wpbtrs( uplo, n, kd, nrhs, ab, ldab, b, ldb, info ) + call stdlib_${ci}$pbtrs( uplo, n, kd, nrhs, ab, ldab, b, ldb, info ) end if return - end subroutine stdlib_wpbsv + end subroutine stdlib_${ci}$pbsv - subroutine stdlib_wpbsvx( fact, uplo, n, kd, nrhs, ab, ldab, afb, ldafb,equed, s, b, ldb, x, & + subroutine stdlib_${ci}$pbsvx( fact, uplo, n, kd, nrhs, ab, ldab, afb, ldafb,equed, s, b, ldb, x, & !! ZPBSVX: uses the Cholesky factorization A = U**H*U or A = L*L**H to !! compute the solution to a complex system of linear equations !! A * X = B, @@ -56863,18 +56865,18 @@ module stdlib_linalg_lapack_w character, intent(in) :: fact, uplo integer(ilp), intent(out) :: info integer(ilp), intent(in) :: kd, ldab, ldafb, ldb, ldx, n, nrhs - real(qp), intent(out) :: rcond + real(${ck}$), intent(out) :: rcond ! Array Arguments - real(qp), intent(out) :: berr(*), ferr(*), rwork(*) - real(qp), intent(inout) :: s(*) - complex(qp), intent(inout) :: ab(ldab,*), afb(ldafb,*), b(ldb,*) - complex(qp), intent(out) :: work(*), x(ldx,*) + real(${ck}$), intent(out) :: berr(*), ferr(*), rwork(*) + real(${ck}$), intent(inout) :: s(*) + complex(${ck}$), intent(inout) :: ab(ldab,*), afb(ldafb,*), b(ldb,*) + complex(${ck}$), intent(out) :: work(*), x(ldx,*) ! ===================================================================== ! Local Scalars logical(lk) :: equil, nofact, rcequ, upper integer(ilp) :: i, infequ, j, j1, j2 - real(qp) :: amax, anorm, bignum, scond, smax, smin, smlnum + real(${ck}$) :: amax, anorm, bignum, scond, smax, smin, smlnum ! Intrinsic Functions intrinsic :: max,min ! Executable Statements @@ -56887,7 +56889,7 @@ module stdlib_linalg_lapack_w rcequ = .false. else rcequ = stdlib_lsame( equed, 'Y' ) - smlnum = stdlib_qlamch( 'SAFE MINIMUM' ) + smlnum = stdlib_${c2ri(ci)}$lamch( 'SAFE MINIMUM' ) bignum = one / smlnum end if ! test the input parameters. @@ -56938,10 +56940,10 @@ module stdlib_linalg_lapack_w end if if( equil ) then ! compute row and column scalings to equilibrate the matrix a. - call stdlib_wpbequ( uplo, n, kd, ab, ldab, s, scond, amax, infequ ) + call stdlib_${ci}$pbequ( uplo, n, kd, ab, ldab, s, scond, amax, infequ ) if( infequ==0 ) then ! equilibrate the matrix. - call stdlib_wlaqhb( uplo, n, kd, ab, ldab, s, scond, amax, equed ) + call stdlib_${ci}$laqhb( uplo, n, kd, ab, ldab, s, scond, amax, equed ) rcequ = stdlib_lsame( equed, 'Y' ) end if end if @@ -56958,16 +56960,16 @@ module stdlib_linalg_lapack_w if( upper ) then do j = 1, n j1 = max( j-kd, 1 ) - call stdlib_wcopy( j-j1+1, ab( kd+1-j+j1, j ), 1,afb( kd+1-j+j1, j ), 1 ) + call stdlib_${ci}$copy( j-j1+1, ab( kd+1-j+j1, j ), 1,afb( kd+1-j+j1, j ), 1 ) end do else do j = 1, n j2 = min( j+kd, n ) - call stdlib_wcopy( j2-j+1, ab( 1, j ), 1, afb( 1, j ), 1 ) + call stdlib_${ci}$copy( j2-j+1, ab( 1, j ), 1, afb( 1, j ), 1 ) end do end if - call stdlib_wpbtrf( uplo, n, kd, afb, ldafb, info ) + call stdlib_${ci}$pbtrf( uplo, n, kd, afb, ldafb, info ) ! return if info is non-zero. if( info>0 )then rcond = zero @@ -56975,15 +56977,15 @@ module stdlib_linalg_lapack_w end if end if ! compute the norm of the matrix a. - anorm = stdlib_wlanhb( '1', uplo, n, kd, ab, ldab, rwork ) + anorm = stdlib_${ci}$lanhb( '1', uplo, n, kd, ab, ldab, rwork ) ! compute the reciprocal of the condition number of a. - call stdlib_wpbcon( uplo, n, kd, afb, ldafb, anorm, rcond, work, rwork,info ) + call stdlib_${ci}$pbcon( uplo, n, kd, afb, ldafb, anorm, rcond, work, rwork,info ) ! compute the solution matrix x. - call stdlib_wlacpy( 'FULL', n, nrhs, b, ldb, x, ldx ) - call stdlib_wpbtrs( uplo, n, kd, nrhs, afb, ldafb, x, ldx, info ) + call stdlib_${ci}$lacpy( 'FULL', n, nrhs, b, ldb, x, ldx ) + call stdlib_${ci}$pbtrs( uplo, n, kd, nrhs, afb, ldafb, x, ldx, info ) ! use iterative refinement to improve the computed solution and ! compute error bounds and backward error estimates for it. - call stdlib_wpbrfs( uplo, n, kd, nrhs, ab, ldab, afb, ldafb, b, ldb, x,ldx, ferr, berr,& + call stdlib_${ci}$pbrfs( uplo, n, kd, nrhs, ab, ldab, afb, ldafb, b, ldb, x,ldx, ferr, berr,& work, rwork, info ) ! transform the solution matrix x to a solution of the original ! system. @@ -56998,12 +57000,12 @@ module stdlib_linalg_lapack_w end do end if ! set info = n+1 if the matrix is singular to working precision. - if( rcond0 ) then - call stdlib_wdscal( kn, one / ajj, ab( kd, j+1 ), kld ) - call stdlib_wlacgv( kn, ab( kd, j+1 ), kld ) - call stdlib_wher( 'UPPER', kn, -one, ab( kd, j+1 ), kld,ab( kd+1, j+1 ), kld ) + call stdlib_${ci}$dscal( kn, one / ajj, ab( kd, j+1 ), kld ) + call stdlib_${ci}$lacgv( kn, ab( kd, j+1 ), kld ) + call stdlib_${ci}$her( 'UPPER', kn, -one, ab( kd, j+1 ), kld,ab( kd+1, j+1 ), kld ) - call stdlib_wlacgv( kn, ab( kd, j+1 ), kld ) + call stdlib_${ci}$lacgv( kn, ab( kd, j+1 ), kld ) end if end do else ! compute the cholesky factorization a = l*l**h. do j = 1, n ! compute l(j,j) and test for non-positive-definiteness. - ajj = real( ab( 1, j ),KIND=qp) + ajj = real( ab( 1, j ),KIND=${ck}$) if( ajj<=zero ) then ab( 1, j ) = ajj go to 30 @@ -57086,8 +57088,8 @@ module stdlib_linalg_lapack_w ! trailing submatrix within the band. kn = min( kd, n-j ) if( kn>0 ) then - call stdlib_wdscal( kn, one / ajj, ab( 2, j ), 1 ) - call stdlib_wher( 'LOWER', kn, -one, ab( 2, j ), 1,ab( 1, j+1 ), kld ) + call stdlib_${ci}$dscal( kn, one / ajj, ab( 2, j ), 1 ) + call stdlib_${ci}$her( 'LOWER', kn, -one, ab( 2, j ), 1,ab( 1, j+1 ), kld ) end if end do end if @@ -57095,10 +57097,10 @@ module stdlib_linalg_lapack_w 30 continue info = j return - end subroutine stdlib_wpbtf2 + end subroutine stdlib_${ci}$pbtf2 - pure subroutine stdlib_wpbtrf( uplo, n, kd, ab, ldab, info ) + pure subroutine stdlib_${ci}$pbtrf( uplo, n, kd, ab, ldab, info ) !! ZPBTRF: computes the Cholesky factorization of a complex Hermitian !! positive definite band matrix A. !! The factorization has the form @@ -57113,7 +57115,7 @@ module stdlib_linalg_lapack_w integer(ilp), intent(out) :: info integer(ilp), intent(in) :: kd, ldab, n ! Array Arguments - complex(qp), intent(inout) :: ab(ldab,*) + complex(${ck}$), intent(inout) :: ab(ldab,*) ! ===================================================================== ! Parameters integer(ilp), parameter :: nbmax = 32 @@ -57124,7 +57126,7 @@ module stdlib_linalg_lapack_w ! Local Scalars integer(ilp) :: i, i2, i3, ib, ii, j, jj, nb ! Local Arrays - complex(qp) :: work(ldwork,nbmax) + complex(${ck}$) :: work(ldwork,nbmax) ! Intrinsic Functions intrinsic :: min ! Executable Statements @@ -57153,7 +57155,7 @@ module stdlib_linalg_lapack_w nb = min( nb, nbmax ) if( nb<=1 .or. nb>kd ) then ! use unblocked code - call stdlib_wpbtf2( uplo, n, kd, ab, ldab, info ) + call stdlib_${ci}$pbtf2( uplo, n, kd, ab, ldab, info ) else ! use blocked code if( stdlib_lsame( uplo, 'U' ) ) then @@ -57170,7 +57172,7 @@ module stdlib_linalg_lapack_w loop_70: do i = 1, n, nb ib = min( nb, n-i+1 ) ! factorize the diagonal block - call stdlib_wpotf2( uplo, ib, ab( kd+1, i ), ldab-1, ii ) + call stdlib_${ci}$potf2( uplo, ib, ab( kd+1, i ), ldab-1, ii ) if( ii/=0 ) then info = i + ii - 1 go to 150 @@ -57191,10 +57193,10 @@ module stdlib_linalg_lapack_w i3 = min( ib, n-i-kd+1 ) if( i2>0 ) then ! update a12 - call stdlib_wtrsm( 'LEFT', 'UPPER', 'CONJUGATE TRANSPOSE','NON-UNIT', & + call stdlib_${ci}$trsm( 'LEFT', 'UPPER', 'CONJUGATE TRANSPOSE','NON-UNIT', & ib, i2, cone,ab( kd+1, i ), ldab-1,ab( kd+1-ib, i+ib ), ldab-1 ) ! update a22 - call stdlib_wherk( 'UPPER', 'CONJUGATE TRANSPOSE', i2, ib,-one, ab( kd+& + call stdlib_${ci}$herk( 'UPPER', 'CONJUGATE TRANSPOSE', i2, ib,-one, ab( kd+& 1-ib, i+ib ), ldab-1, one,ab( kd+1, i+ib ), ldab-1 ) end if if( i3>0 ) then @@ -57205,14 +57207,14 @@ module stdlib_linalg_lapack_w end do end do ! update a13 (in the work array). - call stdlib_wtrsm( 'LEFT', 'UPPER', 'CONJUGATE TRANSPOSE','NON-UNIT', & + call stdlib_${ci}$trsm( 'LEFT', 'UPPER', 'CONJUGATE TRANSPOSE','NON-UNIT', & ib, i3, cone,ab( kd+1, i ), ldab-1, work, ldwork ) ! update a23 - if( i2>0 )call stdlib_wgemm( 'CONJUGATE TRANSPOSE','NO TRANSPOSE', i2, & + if( i2>0 )call stdlib_${ci}$gemm( 'CONJUGATE TRANSPOSE','NO TRANSPOSE', i2, & i3, ib, -cone,ab( kd+1-ib, i+ib ), ldab-1, work,ldwork, cone, ab( 1+ib, & i+kd ),ldab-1 ) ! update a33 - call stdlib_wherk( 'UPPER', 'CONJUGATE TRANSPOSE', i3, ib,-one, work, & + call stdlib_${ci}$herk( 'UPPER', 'CONJUGATE TRANSPOSE', i3, ib,-one, work, & ldwork, one,ab( kd+1, i+kd ), ldab-1 ) ! copy the lower triangle of a13 back into place. do jj = 1, i3 @@ -57237,7 +57239,7 @@ module stdlib_linalg_lapack_w loop_140: do i = 1, n, nb ib = min( nb, n-i+1 ) ! factorize the diagonal block - call stdlib_wpotf2( uplo, ib, ab( 1, i ), ldab-1, ii ) + call stdlib_${ci}$potf2( uplo, ib, ab( 1, i ), ldab-1, ii ) if( ii/=0 ) then info = i + ii - 1 go to 150 @@ -57258,10 +57260,10 @@ module stdlib_linalg_lapack_w i3 = min( ib, n-i-kd+1 ) if( i2>0 ) then ! update a21 - call stdlib_wtrsm( 'RIGHT', 'LOWER','CONJUGATE TRANSPOSE', 'NON-UNIT', & + call stdlib_${ci}$trsm( 'RIGHT', 'LOWER','CONJUGATE TRANSPOSE', 'NON-UNIT', & i2,ib, cone, ab( 1, i ), ldab-1,ab( 1+ib, i ), ldab-1 ) ! update a22 - call stdlib_wherk( 'LOWER', 'NO TRANSPOSE', i2, ib, -one,ab( 1+ib, i ), & + call stdlib_${ci}$herk( 'LOWER', 'NO TRANSPOSE', i2, ib, -one,ab( 1+ib, i ), & ldab-1, one,ab( 1, i+ib ), ldab-1 ) end if if( i3>0 ) then @@ -57272,14 +57274,14 @@ module stdlib_linalg_lapack_w end do end do ! update a31 (in the work array). - call stdlib_wtrsm( 'RIGHT', 'LOWER','CONJUGATE TRANSPOSE', 'NON-UNIT', & + call stdlib_${ci}$trsm( 'RIGHT', 'LOWER','CONJUGATE TRANSPOSE', 'NON-UNIT', & i3,ib, cone, ab( 1, i ), ldab-1, work,ldwork ) ! update a32 - if( i2>0 )call stdlib_wgemm( 'NO TRANSPOSE','CONJUGATE TRANSPOSE', i3, & + if( i2>0 )call stdlib_${ci}$gemm( 'NO TRANSPOSE','CONJUGATE TRANSPOSE', i3, & i2, ib,-cone, work, ldwork, ab( 1+ib, i ),ldab-1, cone, ab( 1+kd-ib, i+& ib ),ldab-1 ) ! update a33 - call stdlib_wherk( 'LOWER', 'NO TRANSPOSE', i3, ib, -one,work, ldwork, & + call stdlib_${ci}$herk( 'LOWER', 'NO TRANSPOSE', i3, ib, -one,work, ldwork, & one, ab( 1, i+kd ),ldab-1 ) ! copy the upper triangle of a31 back into place. do jj = 1, ib @@ -57295,10 +57297,10 @@ module stdlib_linalg_lapack_w return 150 continue return - end subroutine stdlib_wpbtrf + end subroutine stdlib_${ci}$pbtrf - pure subroutine stdlib_wpbtrs( uplo, n, kd, nrhs, ab, ldab, b, ldb, info ) + pure subroutine stdlib_${ci}$pbtrs( uplo, n, kd, nrhs, ab, ldab, b, ldb, info ) !! ZPBTRS: solves a system of linear equations A*X = B with a Hermitian !! positive definite band matrix A using the Cholesky factorization !! A = U**H *U or A = L*L**H computed by ZPBTRF. @@ -57310,8 +57312,8 @@ module stdlib_linalg_lapack_w integer(ilp), intent(out) :: info integer(ilp), intent(in) :: kd, ldab, ldb, n, nrhs ! Array Arguments - complex(qp), intent(in) :: ab(ldab,*) - complex(qp), intent(inout) :: b(ldb,*) + complex(${ck}$), intent(in) :: ab(ldab,*) + complex(${ck}$), intent(inout) :: b(ldb,*) ! ===================================================================== ! Local Scalars logical(lk) :: upper @@ -57345,28 +57347,28 @@ module stdlib_linalg_lapack_w ! solve a*x = b where a = u**h *u. do j = 1, nrhs ! solve u**h *x = b, overwriting b with x. - call stdlib_wtbsv( 'UPPER', 'CONJUGATE TRANSPOSE', 'NON-UNIT', n,kd, ab, ldab, b(& + call stdlib_${ci}$tbsv( 'UPPER', 'CONJUGATE TRANSPOSE', 'NON-UNIT', n,kd, ab, ldab, b(& 1, j ), 1 ) ! solve u*x = b, overwriting b with x. - call stdlib_wtbsv( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', n, kd, ab,ldab, b( 1, j )& + call stdlib_${ci}$tbsv( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', n, kd, ab,ldab, b( 1, j )& , 1 ) end do else ! solve a*x = b where a = l*l**h. do j = 1, nrhs ! solve l*x = b, overwriting b with x. - call stdlib_wtbsv( 'LOWER', 'NO TRANSPOSE', 'NON-UNIT', n, kd, ab,ldab, b( 1, j )& + call stdlib_${ci}$tbsv( 'LOWER', 'NO TRANSPOSE', 'NON-UNIT', n, kd, ab,ldab, b( 1, j )& , 1 ) ! solve l**h *x = b, overwriting b with x. - call stdlib_wtbsv( 'LOWER', 'CONJUGATE TRANSPOSE', 'NON-UNIT', n,kd, ab, ldab, b(& + call stdlib_${ci}$tbsv( 'LOWER', 'CONJUGATE TRANSPOSE', 'NON-UNIT', n,kd, ab, ldab, b(& 1, j ), 1 ) end do end if return - end subroutine stdlib_wpbtrs + end subroutine stdlib_${ci}$pbtrs - pure subroutine stdlib_wpftrf( transr, uplo, n, a, info ) + pure subroutine stdlib_${ci}$pftrf( transr, uplo, n, a, info ) !! ZPFTRF: computes the Cholesky factorization of a complex Hermitian !! positive definite matrix A. !! The factorization has the form @@ -57382,7 +57384,7 @@ module stdlib_linalg_lapack_w integer(ilp), intent(in) :: n integer(ilp), intent(out) :: info ! Array Arguments - complex(qp), intent(inout) :: a(0:*) + complex(${ck}$), intent(inout) :: a(0:*) ! ===================================================================== @@ -57434,23 +57436,23 @@ module stdlib_linalg_lapack_w ! srpa for lower, normal and n is odd ( a(0:n-1,0:n1-1) ) ! t1 -> a(0,0), t2 -> a(0,1), s -> a(n1,0) ! t1 -> a(0), t2 -> a(n), s -> a(n1) - call stdlib_wpotrf( 'L', n1, a( 0 ), n, info ) + call stdlib_${ci}$potrf( 'L', n1, a( 0 ), n, info ) if( info>0 )return - call stdlib_wtrsm( 'R', 'L', 'C', 'N', n2, n1, cone, a( 0 ), n,a( n1 ), n ) + call stdlib_${ci}$trsm( 'R', 'L', 'C', 'N', n2, n1, cone, a( 0 ), n,a( n1 ), n ) - call stdlib_wherk( 'U', 'N', n2, n1, -one, a( n1 ), n, one,a( n ), n ) - call stdlib_wpotrf( 'U', n2, a( n ), n, info ) + call stdlib_${ci}$herk( 'U', 'N', n2, n1, -one, a( n1 ), n, one,a( n ), n ) + call stdlib_${ci}$potrf( 'U', n2, a( n ), n, info ) if( info>0 )info = info + n1 else ! srpa for upper, normal and n is odd ( a(0:n-1,0:n2-1) ! t1 -> a(n1+1,0), t2 -> a(n1,0), s -> a(0,0) ! t1 -> a(n2), t2 -> a(n1), s -> a(0) - call stdlib_wpotrf( 'L', n1, a( n2 ), n, info ) + call stdlib_${ci}$potrf( 'L', n1, a( n2 ), n, info ) if( info>0 )return - call stdlib_wtrsm( 'L', 'L', 'N', 'N', n1, n2, cone, a( n2 ), n,a( 0 ), n ) + call stdlib_${ci}$trsm( 'L', 'L', 'N', 'N', n1, n2, cone, a( n2 ), n,a( 0 ), n ) - call stdlib_wherk( 'U', 'C', n2, n1, -one, a( 0 ), n, one,a( n1 ), n ) - call stdlib_wpotrf( 'U', n2, a( n1 ), n, info ) + call stdlib_${ci}$herk( 'U', 'C', n2, n1, -one, a( 0 ), n, one,a( n1 ), n ) + call stdlib_${ci}$potrf( 'U', n2, a( n1 ), n, info ) if( info>0 )info = info + n1 end if else @@ -57459,25 +57461,25 @@ module stdlib_linalg_lapack_w ! srpa for lower, transpose and n is odd ! t1 -> a(0,0) , t2 -> a(1,0) , s -> a(0,n1) ! t1 -> a(0+0) , t2 -> a(1+0) , s -> a(0+n1*n1); lda=n1 - call stdlib_wpotrf( 'U', n1, a( 0 ), n1, info ) + call stdlib_${ci}$potrf( 'U', n1, a( 0 ), n1, info ) if( info>0 )return - call stdlib_wtrsm( 'L', 'U', 'C', 'N', n1, n2, cone, a( 0 ), n1,a( n1*n1 ), & + call stdlib_${ci}$trsm( 'L', 'U', 'C', 'N', n1, n2, cone, a( 0 ), n1,a( n1*n1 ), & n1 ) - call stdlib_wherk( 'L', 'C', n2, n1, -one, a( n1*n1 ), n1, one,a( 1 ), n1 ) + call stdlib_${ci}$herk( 'L', 'C', n2, n1, -one, a( n1*n1 ), n1, one,a( 1 ), n1 ) - call stdlib_wpotrf( 'L', n2, a( 1 ), n1, info ) + call stdlib_${ci}$potrf( 'L', n2, a( 1 ), n1, info ) if( info>0 )info = info + n1 else ! srpa for upper, transpose and n is odd ! t1 -> a(0,n1+1), t2 -> a(0,n1), s -> a(0,0) ! t1 -> a(n2*n2), t2 -> a(n1*n2), s -> a(0); lda = n2 - call stdlib_wpotrf( 'U', n1, a( n2*n2 ), n2, info ) + call stdlib_${ci}$potrf( 'U', n1, a( n2*n2 ), n2, info ) if( info>0 )return - call stdlib_wtrsm( 'R', 'U', 'N', 'N', n2, n1, cone, a( n2*n2 ),n2, a( 0 ), & + call stdlib_${ci}$trsm( 'R', 'U', 'N', 'N', n2, n1, cone, a( n2*n2 ),n2, a( 0 ), & n2 ) - call stdlib_wherk( 'L', 'N', n2, n1, -one, a( 0 ), n2, one,a( n1*n2 ), n2 ) + call stdlib_${ci}$herk( 'L', 'N', n2, n1, -one, a( 0 ), n2, one,a( n1*n2 ), n2 ) - call stdlib_wpotrf( 'L', n2, a( n1*n2 ), n2, info ) + call stdlib_${ci}$potrf( 'L', n2, a( n1*n2 ), n2, info ) if( info>0 )info = info + n1 end if end if @@ -57489,25 +57491,25 @@ module stdlib_linalg_lapack_w ! srpa for lower, normal, and n is even ( a(0:n,0:k-1) ) ! t1 -> a(1,0), t2 -> a(0,0), s -> a(k+1,0) ! t1 -> a(1), t2 -> a(0), s -> a(k+1) - call stdlib_wpotrf( 'L', k, a( 1 ), n+1, info ) + call stdlib_${ci}$potrf( 'L', k, a( 1 ), n+1, info ) if( info>0 )return - call stdlib_wtrsm( 'R', 'L', 'C', 'N', k, k, cone, a( 1 ), n+1,a( k+1 ), n+1 ) + call stdlib_${ci}$trsm( 'R', 'L', 'C', 'N', k, k, cone, a( 1 ), n+1,a( k+1 ), n+1 ) - call stdlib_wherk( 'U', 'N', k, k, -one, a( k+1 ), n+1, one,a( 0 ), n+1 ) + call stdlib_${ci}$herk( 'U', 'N', k, k, -one, a( k+1 ), n+1, one,a( 0 ), n+1 ) - call stdlib_wpotrf( 'U', k, a( 0 ), n+1, info ) + call stdlib_${ci}$potrf( 'U', k, a( 0 ), n+1, info ) if( info>0 )info = info + k else ! srpa for upper, normal, and n is even ( a(0:n,0:k-1) ) ! t1 -> a(k+1,0) , t2 -> a(k,0), s -> a(0,0) ! t1 -> a(k+1), t2 -> a(k), s -> a(0) - call stdlib_wpotrf( 'L', k, a( k+1 ), n+1, info ) + call stdlib_${ci}$potrf( 'L', k, a( k+1 ), n+1, info ) if( info>0 )return - call stdlib_wtrsm( 'L', 'L', 'N', 'N', k, k, cone, a( k+1 ),n+1, a( 0 ), n+1 ) + call stdlib_${ci}$trsm( 'L', 'L', 'N', 'N', k, k, cone, a( k+1 ),n+1, a( 0 ), n+1 ) - call stdlib_wherk( 'U', 'C', k, k, -one, a( 0 ), n+1, one,a( k ), n+1 ) + call stdlib_${ci}$herk( 'U', 'C', k, k, -one, a( 0 ), n+1, one,a( k ), n+1 ) - call stdlib_wpotrf( 'U', k, a( k ), n+1, info ) + call stdlib_${ci}$potrf( 'U', k, a( k ), n+1, info ) if( info>0 )info = info + k end if else @@ -57516,33 +57518,33 @@ module stdlib_linalg_lapack_w ! srpa for lower, transpose and n is even (see paper) ! t1 -> b(0,1), t2 -> b(0,0), s -> b(0,k+1) ! t1 -> a(0+k), t2 -> a(0+0), s -> a(0+k*(k+1)); lda=k - call stdlib_wpotrf( 'U', k, a( 0+k ), k, info ) + call stdlib_${ci}$potrf( 'U', k, a( 0+k ), k, info ) if( info>0 )return - call stdlib_wtrsm( 'L', 'U', 'C', 'N', k, k, cone, a( k ), n1,a( k*( k+1 ) ), & + call stdlib_${ci}$trsm( 'L', 'U', 'C', 'N', k, k, cone, a( k ), n1,a( k*( k+1 ) ), & k ) - call stdlib_wherk( 'L', 'C', k, k, -one, a( k*( k+1 ) ), k, one,a( 0 ), k ) + call stdlib_${ci}$herk( 'L', 'C', k, k, -one, a( k*( k+1 ) ), k, one,a( 0 ), k ) - call stdlib_wpotrf( 'L', k, a( 0 ), k, info ) + call stdlib_${ci}$potrf( 'L', k, a( 0 ), k, info ) if( info>0 )info = info + k else ! srpa for upper, transpose and n is even (see paper) ! t1 -> b(0,k+1), t2 -> b(0,k), s -> b(0,0) ! t1 -> a(0+k*(k+1)), t2 -> a(0+k*k), s -> a(0+0)); lda=k - call stdlib_wpotrf( 'U', k, a( k*( k+1 ) ), k, info ) + call stdlib_${ci}$potrf( 'U', k, a( k*( k+1 ) ), k, info ) if( info>0 )return - call stdlib_wtrsm( 'R', 'U', 'N', 'N', k, k, cone,a( k*( k+1 ) ), k, a( 0 ), & + call stdlib_${ci}$trsm( 'R', 'U', 'N', 'N', k, k, cone,a( k*( k+1 ) ), k, a( 0 ), & k ) - call stdlib_wherk( 'L', 'N', k, k, -one, a( 0 ), k, one,a( k*k ), k ) - call stdlib_wpotrf( 'L', k, a( k*k ), k, info ) + call stdlib_${ci}$herk( 'L', 'N', k, k, -one, a( 0 ), k, one,a( k*k ), k ) + call stdlib_${ci}$potrf( 'L', k, a( k*k ), k, info ) if( info>0 )info = info + k end if end if end if return - end subroutine stdlib_wpftrf + end subroutine stdlib_${ci}$pftrf - pure subroutine stdlib_wpftri( transr, uplo, n, a, info ) + pure subroutine stdlib_${ci}$pftri( transr, uplo, n, a, info ) !! ZPFTRI: computes the inverse of a complex Hermitian positive definite !! matrix A using the Cholesky factorization A = U**H*U or A = L*L**H !! computed by ZPFTRF. @@ -57554,7 +57556,7 @@ module stdlib_linalg_lapack_w integer(ilp), intent(out) :: info integer(ilp), intent(in) :: n ! Array Arguments - complex(qp), intent(inout) :: a(0:*) + complex(${ck}$), intent(inout) :: a(0:*) ! ===================================================================== @@ -57582,7 +57584,7 @@ module stdlib_linalg_lapack_w ! quick return if possible if( n==0 )return ! invert the triangular cholesky factor u or l. - call stdlib_wtftri( transr, uplo, 'N', n, a, info ) + call stdlib_${ci}$tftri( transr, uplo, 'N', n, a, info ) if( info>0 )return ! if n is odd, set nisodd = .true. ! if n is even, set k = n/2 and nisodd = .false. @@ -57610,41 +57612,41 @@ module stdlib_linalg_lapack_w ! srpa for lower, normal and n is odd ( a(0:n-1,0:n1-1) ) ! t1 -> a(0,0), t2 -> a(0,1), s -> a(n1,0) ! t1 -> a(0), t2 -> a(n), s -> a(n1) - call stdlib_wlauum( 'L', n1, a( 0 ), n, info ) - call stdlib_wherk( 'L', 'C', n1, n2, one, a( n1 ), n, one,a( 0 ), n ) - call stdlib_wtrmm( 'L', 'U', 'N', 'N', n2, n1, cone, a( n ), n,a( n1 ), n ) + call stdlib_${ci}$lauum( 'L', n1, a( 0 ), n, info ) + call stdlib_${ci}$herk( 'L', 'C', n1, n2, one, a( n1 ), n, one,a( 0 ), n ) + call stdlib_${ci}$trmm( 'L', 'U', 'N', 'N', n2, n1, cone, a( n ), n,a( n1 ), n ) - call stdlib_wlauum( 'U', n2, a( n ), n, info ) + call stdlib_${ci}$lauum( 'U', n2, a( n ), n, info ) else ! srpa for upper, normal and n is odd ( a(0:n-1,0:n2-1) ! t1 -> a(n1+1,0), t2 -> a(n1,0), s -> a(0,0) ! t1 -> a(n2), t2 -> a(n1), s -> a(0) - call stdlib_wlauum( 'L', n1, a( n2 ), n, info ) - call stdlib_wherk( 'L', 'N', n1, n2, one, a( 0 ), n, one,a( n2 ), n ) - call stdlib_wtrmm( 'R', 'U', 'C', 'N', n1, n2, cone, a( n1 ), n,a( 0 ), n ) + call stdlib_${ci}$lauum( 'L', n1, a( n2 ), n, info ) + call stdlib_${ci}$herk( 'L', 'N', n1, n2, one, a( 0 ), n, one,a( n2 ), n ) + call stdlib_${ci}$trmm( 'R', 'U', 'C', 'N', n1, n2, cone, a( n1 ), n,a( 0 ), n ) - call stdlib_wlauum( 'U', n2, a( n1 ), n, info ) + call stdlib_${ci}$lauum( 'U', n2, a( n1 ), n, info ) end if else ! n is odd and transr = 'c' if( lower ) then ! srpa for lower, transpose, and n is odd ! t1 -> a(0), t2 -> a(1), s -> a(0+n1*n1) - call stdlib_wlauum( 'U', n1, a( 0 ), n1, info ) - call stdlib_wherk( 'U', 'N', n1, n2, one, a( n1*n1 ), n1, one,a( 0 ), n1 ) + call stdlib_${ci}$lauum( 'U', n1, a( 0 ), n1, info ) + call stdlib_${ci}$herk( 'U', 'N', n1, n2, one, a( n1*n1 ), n1, one,a( 0 ), n1 ) - call stdlib_wtrmm( 'R', 'L', 'N', 'N', n1, n2, cone, a( 1 ), n1,a( n1*n1 ), & + call stdlib_${ci}$trmm( 'R', 'L', 'N', 'N', n1, n2, cone, a( 1 ), n1,a( n1*n1 ), & n1 ) - call stdlib_wlauum( 'L', n2, a( 1 ), n1, info ) + call stdlib_${ci}$lauum( 'L', n2, a( 1 ), n1, info ) else ! srpa for upper, transpose, and n is odd ! t1 -> a(0+n2*n2), t2 -> a(0+n1*n2), s -> a(0) - call stdlib_wlauum( 'U', n1, a( n2*n2 ), n2, info ) - call stdlib_wherk( 'U', 'C', n1, n2, one, a( 0 ), n2, one,a( n2*n2 ), n2 ) + call stdlib_${ci}$lauum( 'U', n1, a( n2*n2 ), n2, info ) + call stdlib_${ci}$herk( 'U', 'C', n1, n2, one, a( 0 ), n2, one,a( n2*n2 ), n2 ) - call stdlib_wtrmm( 'L', 'L', 'C', 'N', n2, n1, cone, a( n1*n2 ),n2, a( 0 ), & + call stdlib_${ci}$trmm( 'L', 'L', 'C', 'N', n2, n1, cone, a( n1*n2 ),n2, a( 0 ), & n2 ) - call stdlib_wlauum( 'L', n2, a( n1*n2 ), n2, info ) + call stdlib_${ci}$lauum( 'L', n2, a( n1*n2 ), n2, info ) end if end if else @@ -57655,22 +57657,22 @@ module stdlib_linalg_lapack_w ! srpa for lower, normal, and n is even ( a(0:n,0:k-1) ) ! t1 -> a(1,0), t2 -> a(0,0), s -> a(k+1,0) ! t1 -> a(1), t2 -> a(0), s -> a(k+1) - call stdlib_wlauum( 'L', k, a( 1 ), n+1, info ) - call stdlib_wherk( 'L', 'C', k, k, one, a( k+1 ), n+1, one,a( 1 ), n+1 ) + call stdlib_${ci}$lauum( 'L', k, a( 1 ), n+1, info ) + call stdlib_${ci}$herk( 'L', 'C', k, k, one, a( k+1 ), n+1, one,a( 1 ), n+1 ) - call stdlib_wtrmm( 'L', 'U', 'N', 'N', k, k, cone, a( 0 ), n+1,a( k+1 ), n+1 ) + call stdlib_${ci}$trmm( 'L', 'U', 'N', 'N', k, k, cone, a( 0 ), n+1,a( k+1 ), n+1 ) - call stdlib_wlauum( 'U', k, a( 0 ), n+1, info ) + call stdlib_${ci}$lauum( 'U', k, a( 0 ), n+1, info ) else ! srpa for upper, normal, and n is even ( a(0:n,0:k-1) ) ! t1 -> a(k+1,0) , t2 -> a(k,0), s -> a(0,0) ! t1 -> a(k+1), t2 -> a(k), s -> a(0) - call stdlib_wlauum( 'L', k, a( k+1 ), n+1, info ) - call stdlib_wherk( 'L', 'N', k, k, one, a( 0 ), n+1, one,a( k+1 ), n+1 ) + call stdlib_${ci}$lauum( 'L', k, a( k+1 ), n+1, info ) + call stdlib_${ci}$herk( 'L', 'N', k, k, one, a( 0 ), n+1, one,a( k+1 ), n+1 ) - call stdlib_wtrmm( 'R', 'U', 'C', 'N', k, k, cone, a( k ), n+1,a( 0 ), n+1 ) + call stdlib_${ci}$trmm( 'R', 'U', 'C', 'N', k, k, cone, a( k ), n+1,a( 0 ), n+1 ) - call stdlib_wlauum( 'U', k, a( k ), n+1, info ) + call stdlib_${ci}$lauum( 'U', k, a( k ), n+1, info ) end if else ! n is even and transr = 'c' @@ -57678,30 +57680,30 @@ module stdlib_linalg_lapack_w ! srpa for lower, transpose, and n is even (see paper) ! t1 -> b(0,1), t2 -> b(0,0), s -> b(0,k+1), ! t1 -> a(0+k), t2 -> a(0+0), s -> a(0+k*(k+1)); lda=k - call stdlib_wlauum( 'U', k, a( k ), k, info ) - call stdlib_wherk( 'U', 'N', k, k, one, a( k*( k+1 ) ), k, one,a( k ), k ) + call stdlib_${ci}$lauum( 'U', k, a( k ), k, info ) + call stdlib_${ci}$herk( 'U', 'N', k, k, one, a( k*( k+1 ) ), k, one,a( k ), k ) - call stdlib_wtrmm( 'R', 'L', 'N', 'N', k, k, cone, a( 0 ), k,a( k*( k+1 ) ), & + call stdlib_${ci}$trmm( 'R', 'L', 'N', 'N', k, k, cone, a( 0 ), k,a( k*( k+1 ) ), & k ) - call stdlib_wlauum( 'L', k, a( 0 ), k, info ) + call stdlib_${ci}$lauum( 'L', k, a( 0 ), k, info ) else ! srpa for upper, transpose, and n is even (see paper) ! t1 -> b(0,k+1), t2 -> b(0,k), s -> b(0,0), ! t1 -> a(0+k*(k+1)), t2 -> a(0+k*k), s -> a(0+0)); lda=k - call stdlib_wlauum( 'U', k, a( k*( k+1 ) ), k, info ) - call stdlib_wherk( 'U', 'C', k, k, one, a( 0 ), k, one,a( k*( k+1 ) ), k ) + call stdlib_${ci}$lauum( 'U', k, a( k*( k+1 ) ), k, info ) + call stdlib_${ci}$herk( 'U', 'C', k, k, one, a( 0 ), k, one,a( k*( k+1 ) ), k ) - call stdlib_wtrmm( 'L', 'L', 'C', 'N', k, k, cone, a( k*k ), k,a( 0 ), k ) + call stdlib_${ci}$trmm( 'L', 'L', 'C', 'N', k, k, cone, a( k*k ), k,a( 0 ), k ) - call stdlib_wlauum( 'L', k, a( k*k ), k, info ) + call stdlib_${ci}$lauum( 'L', k, a( k*k ), k, info ) end if end if end if return - end subroutine stdlib_wpftri + end subroutine stdlib_${ci}$pftri - pure subroutine stdlib_wpftrs( transr, uplo, n, nrhs, a, b, ldb, info ) + pure subroutine stdlib_${ci}$pftrs( transr, uplo, n, nrhs, a, b, ldb, info ) !! ZPFTRS: solves a system of linear equations A*X = B with a Hermitian !! positive definite matrix A using the Cholesky factorization !! A = U**H*U or A = L*L**H computed by ZPFTRF. @@ -57713,8 +57715,8 @@ module stdlib_linalg_lapack_w integer(ilp), intent(out) :: info integer(ilp), intent(in) :: ldb, n, nrhs ! Array Arguments - complex(qp), intent(in) :: a(0:*) - complex(qp), intent(inout) :: b(ldb,*) + complex(${ck}$), intent(in) :: a(0:*) + complex(${ck}$), intent(inout) :: b(ldb,*) ! ===================================================================== ! Local Scalars @@ -57745,17 +57747,17 @@ module stdlib_linalg_lapack_w if( n==0 .or. nrhs==0 )return ! start execution: there are two triangular solves if( lower ) then - call stdlib_wtfsm( transr, 'L', uplo, 'N', 'N', n, nrhs, cone, a, b,ldb ) - call stdlib_wtfsm( transr, 'L', uplo, 'C', 'N', n, nrhs, cone, a, b,ldb ) + call stdlib_${ci}$tfsm( transr, 'L', uplo, 'N', 'N', n, nrhs, cone, a, b,ldb ) + call stdlib_${ci}$tfsm( transr, 'L', uplo, 'C', 'N', n, nrhs, cone, a, b,ldb ) else - call stdlib_wtfsm( transr, 'L', uplo, 'C', 'N', n, nrhs, cone, a, b,ldb ) - call stdlib_wtfsm( transr, 'L', uplo, 'N', 'N', n, nrhs, cone, a, b,ldb ) + call stdlib_${ci}$tfsm( transr, 'L', uplo, 'C', 'N', n, nrhs, cone, a, b,ldb ) + call stdlib_${ci}$tfsm( transr, 'L', uplo, 'N', 'N', n, nrhs, cone, a, b,ldb ) end if return - end subroutine stdlib_wpftrs + end subroutine stdlib_${ci}$pftrs - pure subroutine stdlib_wpocon( uplo, n, a, lda, anorm, rcond, work, rwork,info ) + pure subroutine stdlib_${ci}$pocon( uplo, n, a, lda, anorm, rcond, work, rwork,info ) !! ZPOCON: estimates the reciprocal of the condition number (in the !! 1-norm) of a complex Hermitian positive definite matrix using the !! Cholesky factorization A = U**H*U or A = L*L**H computed by ZPOTRF. @@ -57768,28 +57770,28 @@ module stdlib_linalg_lapack_w character, intent(in) :: uplo integer(ilp), intent(out) :: info integer(ilp), intent(in) :: lda, n - real(qp), intent(in) :: anorm - real(qp), intent(out) :: rcond + real(${ck}$), intent(in) :: anorm + real(${ck}$), intent(out) :: rcond ! Array Arguments - real(qp), intent(out) :: rwork(*) - complex(qp), intent(inout) :: a(lda,*) - complex(qp), intent(out) :: work(*) + real(${ck}$), intent(out) :: rwork(*) + complex(${ck}$), intent(inout) :: a(lda,*) + complex(${ck}$), intent(out) :: work(*) ! ===================================================================== ! Local Scalars logical(lk) :: upper character :: normin integer(ilp) :: ix, kase - real(qp) :: ainvnm, scale, scalel, scaleu, smlnum - complex(qp) :: zdum + real(${ck}$) :: ainvnm, scale, scalel, scaleu, smlnum + complex(${ck}$) :: zdum ! Local Arrays integer(ilp) :: isave(3) ! Intrinsic Functions intrinsic :: abs,real,aimag,max ! Statement Functions - real(qp) :: cabs1 + real(${ck}$) :: cabs1 ! Statement Function Definitions - cabs1( zdum ) = abs( real( zdum,KIND=qp) ) + abs( aimag( zdum ) ) + cabs1( zdum ) = abs( real( zdum,KIND=${ck}$) ) + abs( aimag( zdum ) ) ! Executable Statements ! test the input parameters. info = 0 @@ -57815,36 +57817,36 @@ module stdlib_linalg_lapack_w else if( anorm==zero ) then return end if - smlnum = stdlib_qlamch( 'SAFE MINIMUM' ) + smlnum = stdlib_${c2ri(ci)}$lamch( 'SAFE MINIMUM' ) ! estimate the 1-norm of inv(a). kase = 0 normin = 'N' 10 continue - call stdlib_wlacn2( n, work( n+1 ), work, ainvnm, kase, isave ) + call stdlib_${ci}$lacn2( n, work( n+1 ), work, ainvnm, kase, isave ) if( kase/=0 ) then if( upper ) then ! multiply by inv(u**h). - call stdlib_wlatrs( 'UPPER', 'CONJUGATE TRANSPOSE', 'NON-UNIT',normin, n, a, lda,& + call stdlib_${ci}$latrs( 'UPPER', 'CONJUGATE TRANSPOSE', 'NON-UNIT',normin, n, a, lda,& work, scalel, rwork, info ) normin = 'Y' ! multiply by inv(u). - call stdlib_wlatrs( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', normin, n,a, lda, work, & + call stdlib_${ci}$latrs( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', normin, n,a, lda, work, & scaleu, rwork, info ) else ! multiply by inv(l). - call stdlib_wlatrs( 'LOWER', 'NO TRANSPOSE', 'NON-UNIT', normin, n,a, lda, work, & + call stdlib_${ci}$latrs( 'LOWER', 'NO TRANSPOSE', 'NON-UNIT', normin, n,a, lda, work, & scalel, rwork, info ) normin = 'Y' ! multiply by inv(l**h). - call stdlib_wlatrs( 'LOWER', 'CONJUGATE TRANSPOSE', 'NON-UNIT',normin, n, a, lda,& + call stdlib_${ci}$latrs( 'LOWER', 'CONJUGATE TRANSPOSE', 'NON-UNIT',normin, n, a, lda,& work, scaleu, rwork, info ) end if ! multiply by 1/scale if doing so will not cause overflow. scale = scalel*scaleu if( scale/=one ) then - ix = stdlib_iwamax( n, work, 1 ) + ix = stdlib_i${ci}$amax( n, work, 1 ) if( scaleeps .and. two*berr( j )<=lstres .and.count<=itmax ) then ! update solution and try again. - call stdlib_wpotrs( uplo, n, 1, af, ldaf, work, n, info ) - call stdlib_waxpy( n, cone, work, 1, x( 1, j ), 1 ) + call stdlib_${ci}$potrs( uplo, n, 1, af, ldaf, work, n, info ) + call stdlib_${ci}$axpy( n, cone, work, 1, x( 1, j ), 1 ) lstres = berr( j ) count = count + 1 go to 20 @@ -58164,7 +58166,7 @@ module stdlib_linalg_lapack_w ! 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_wlacn2 to estimate the infinity-norm of the matrix + ! 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 @@ -58176,11 +58178,11 @@ module stdlib_linalg_lapack_w end do kase = 0 100 continue - call stdlib_wlacn2( n, work( n+1 ), work, ferr( j ), kase, isave ) + call stdlib_${ci}$lacn2( n, work( n+1 ), work, ferr( j ), kase, isave ) if( kase/=0 ) then if( kase==1 ) then ! multiply by diag(w)*inv(a**h). - call stdlib_wpotrs( uplo, n, 1, af, ldaf, work, n, info ) + call stdlib_${ci}$potrs( uplo, n, 1, af, ldaf, work, n, info ) do i = 1, n work( i ) = rwork( i )*work( i ) end do @@ -58189,7 +58191,7 @@ module stdlib_linalg_lapack_w do i = 1, n work( i ) = rwork( i )*work( i ) end do - call stdlib_wpotrs( uplo, n, 1, af, ldaf, work, n, info ) + call stdlib_${ci}$potrs( uplo, n, 1, af, ldaf, work, n, info ) end if go to 100 end if @@ -58201,10 +58203,10 @@ module stdlib_linalg_lapack_w if( lstres/=zero )ferr( j ) = ferr( j ) / lstres end do loop_140 return - end subroutine stdlib_wporfs + end subroutine stdlib_${ci}$porfs - pure subroutine stdlib_wposv( uplo, n, nrhs, a, lda, b, ldb, info ) + pure subroutine stdlib_${ci}$posv( uplo, n, nrhs, a, lda, b, ldb, info ) !! ZPOSV: computes the solution to a complex system of linear equations !! A * X = B, !! where A is an N-by-N Hermitian positive definite matrix and X and B @@ -58223,7 +58225,7 @@ module stdlib_linalg_lapack_w integer(ilp), intent(out) :: info integer(ilp), intent(in) :: lda, ldb, n, nrhs ! Array Arguments - complex(qp), intent(inout) :: a(lda,*), b(ldb,*) + complex(${ck}$), intent(inout) :: a(lda,*), b(ldb,*) ! ===================================================================== ! Intrinsic Functions intrinsic :: max @@ -58246,16 +58248,16 @@ module stdlib_linalg_lapack_w return end if ! compute the cholesky factorization a = u**h *u or a = l*l**h. - call stdlib_wpotrf( uplo, n, a, lda, info ) + call stdlib_${ci}$potrf( uplo, n, a, lda, info ) if( info==0 ) then ! solve the system a*x = b, overwriting b with x. - call stdlib_wpotrs( uplo, n, nrhs, a, lda, b, ldb, info ) + call stdlib_${ci}$potrs( uplo, n, nrhs, a, lda, b, ldb, info ) end if return - end subroutine stdlib_wposv + end subroutine stdlib_${ci}$posv - subroutine stdlib_wposvx( fact, uplo, n, nrhs, a, lda, af, ldaf, equed,s, b, ldb, x, ldx, & + subroutine stdlib_${ci}$posvx( fact, uplo, n, nrhs, a, lda, af, ldaf, equed,s, b, ldb, x, ldx, & !! ZPOSVX: uses the Cholesky factorization A = U**H*U or A = L*L**H to !! compute the solution to a complex system of linear equations !! A * X = B, @@ -58272,18 +58274,18 @@ module stdlib_linalg_lapack_w character, intent(in) :: fact, uplo integer(ilp), intent(out) :: info integer(ilp), intent(in) :: lda, ldaf, ldb, ldx, n, nrhs - real(qp), intent(out) :: rcond + real(${ck}$), intent(out) :: rcond ! Array Arguments - real(qp), intent(out) :: berr(*), ferr(*), rwork(*) - real(qp), intent(inout) :: s(*) - complex(qp), intent(inout) :: a(lda,*), af(ldaf,*), b(ldb,*) - complex(qp), intent(out) :: work(*), x(ldx,*) + real(${ck}$), intent(out) :: berr(*), ferr(*), rwork(*) + real(${ck}$), intent(inout) :: s(*) + complex(${ck}$), intent(inout) :: a(lda,*), af(ldaf,*), b(ldb,*) + complex(${ck}$), intent(out) :: work(*), x(ldx,*) ! ===================================================================== ! Local Scalars logical(lk) :: equil, nofact, rcequ integer(ilp) :: i, infequ, j - real(qp) :: amax, anorm, bignum, scond, smax, smin, smlnum + real(${ck}$) :: amax, anorm, bignum, scond, smax, smin, smlnum ! Intrinsic Functions intrinsic :: max,min ! Executable Statements @@ -58295,7 +58297,7 @@ module stdlib_linalg_lapack_w rcequ = .false. else rcequ = stdlib_lsame( equed, 'Y' ) - smlnum = stdlib_qlamch( 'SAFE MINIMUM' ) + smlnum = stdlib_${c2ri(ci)}$lamch( 'SAFE MINIMUM' ) bignum = one / smlnum end if ! test the input parameters. @@ -58345,10 +58347,10 @@ module stdlib_linalg_lapack_w end if if( equil ) then ! compute row and column scalings to equilibrate the matrix a. - call stdlib_wpoequ( n, a, lda, s, scond, amax, infequ ) + call stdlib_${ci}$poequ( n, a, lda, s, scond, amax, infequ ) if( infequ==0 ) then ! equilibrate the matrix. - call stdlib_wlaqhe( uplo, n, a, lda, s, scond, amax, equed ) + call stdlib_${ci}$laqhe( uplo, n, a, lda, s, scond, amax, equed ) rcequ = stdlib_lsame( equed, 'Y' ) end if end if @@ -58362,8 +58364,8 @@ module stdlib_linalg_lapack_w end if if( nofact .or. equil ) then ! compute the cholesky factorization a = u**h *u or a = l*l**h. - call stdlib_wlacpy( uplo, n, n, a, lda, af, ldaf ) - call stdlib_wpotrf( uplo, n, af, ldaf, info ) + call stdlib_${ci}$lacpy( uplo, n, n, a, lda, af, ldaf ) + call stdlib_${ci}$potrf( uplo, n, af, ldaf, info ) ! return if info is non-zero. if( info>0 )then rcond = zero @@ -58371,15 +58373,15 @@ module stdlib_linalg_lapack_w end if end if ! compute the norm of the matrix a. - anorm = stdlib_wlanhe( '1', uplo, n, a, lda, rwork ) + anorm = stdlib_${ci}$lanhe( '1', uplo, n, a, lda, rwork ) ! compute the reciprocal of the condition number of a. - call stdlib_wpocon( uplo, n, af, ldaf, anorm, rcond, work, rwork, info ) + call stdlib_${ci}$pocon( uplo, n, af, ldaf, anorm, rcond, work, rwork, info ) ! compute the solution matrix x. - call stdlib_wlacpy( 'FULL', n, nrhs, b, ldb, x, ldx ) - call stdlib_wpotrs( uplo, n, nrhs, af, ldaf, x, ldx, info ) + call stdlib_${ci}$lacpy( 'FULL', n, nrhs, b, ldb, x, ldx ) + call stdlib_${ci}$potrs( uplo, n, nrhs, af, ldaf, x, ldx, info ) ! use iterative refinement to improve the computed solution and ! compute error bounds and backward error estimates for it. - call stdlib_wporfs( uplo, n, nrhs, a, lda, af, ldaf, b, ldb, x, ldx,ferr, berr, work, & + call stdlib_${ci}$porfs( uplo, n, nrhs, a, lda, af, ldaf, b, ldb, x, ldx,ferr, berr, work, & rwork, info ) ! transform the solution matrix x to a solution of the original ! system. @@ -58394,12 +58396,12 @@ module stdlib_linalg_lapack_w end do end if ! set info = n+1 if the matrix is singular to working precision. - if( rcond=n ) then ! use unblocked code. - call stdlib_wpotrf2( uplo, n, a, lda, info ) + call stdlib_${ci}$potrf2( uplo, n, a, lda, info ) else ! use blocked code. if( upper ) then @@ -58548,15 +58550,15 @@ module stdlib_linalg_lapack_w ! update and factorize the current diagonal block and test ! for non-positive-definiteness. jb = min( nb, n-j+1 ) - call stdlib_wherk( 'UPPER', 'CONJUGATE TRANSPOSE', jb, j-1,-one, a( 1, j ), & + call stdlib_${ci}$herk( 'UPPER', 'CONJUGATE TRANSPOSE', jb, j-1,-one, a( 1, j ), & lda, one, a( j, j ), lda ) - call stdlib_wpotrf2( 'UPPER', jb, a( j, j ), lda, info ) + call stdlib_${ci}$potrf2( 'UPPER', jb, a( j, j ), lda, info ) if( info/=0 )go to 30 if( j+jb<=n ) then ! compute the current block row. - call stdlib_wgemm( 'CONJUGATE TRANSPOSE', 'NO TRANSPOSE', jb,n-j-jb+1, j-1,& + call stdlib_${ci}$gemm( 'CONJUGATE TRANSPOSE', 'NO TRANSPOSE', jb,n-j-jb+1, j-1,& -cone, a( 1, j ), lda,a( 1, j+jb ), lda, cone, a( j, j+jb ),lda ) - call stdlib_wtrsm( 'LEFT', 'UPPER', 'CONJUGATE TRANSPOSE','NON-UNIT', jb, & + call stdlib_${ci}$trsm( 'LEFT', 'UPPER', 'CONJUGATE TRANSPOSE','NON-UNIT', jb, & n-j-jb+1, cone, a( j, j ),lda, a( j, j+jb ), lda ) end if end do @@ -58566,15 +58568,15 @@ module stdlib_linalg_lapack_w ! update and factorize the current diagonal block and test ! for non-positive-definiteness. jb = min( nb, n-j+1 ) - call stdlib_wherk( 'LOWER', 'NO TRANSPOSE', jb, j-1, -one,a( j, 1 ), lda, one,& + call stdlib_${ci}$herk( 'LOWER', 'NO TRANSPOSE', jb, j-1, -one,a( j, 1 ), lda, one,& a( j, j ), lda ) - call stdlib_wpotrf2( 'LOWER', jb, a( j, j ), lda, info ) + call stdlib_${ci}$potrf2( 'LOWER', jb, a( j, j ), lda, info ) if( info/=0 )go to 30 if( j+jb<=n ) then ! compute the current block column. - call stdlib_wgemm( 'NO TRANSPOSE', 'CONJUGATE TRANSPOSE',n-j-jb+1, jb, j-1,& + call stdlib_${ci}$gemm( 'NO TRANSPOSE', 'CONJUGATE TRANSPOSE',n-j-jb+1, jb, j-1,& -cone, a( j+jb, 1 ),lda, a( j, 1 ), lda, cone, a( j+jb, j ),lda ) - call stdlib_wtrsm( 'RIGHT', 'LOWER', 'CONJUGATE TRANSPOSE','NON-UNIT', n-j-& + call stdlib_${ci}$trsm( 'RIGHT', 'LOWER', 'CONJUGATE TRANSPOSE','NON-UNIT', n-j-& jb+1, jb, cone, a( j, j ),lda, a( j+jb, j ), lda ) end if end do @@ -58585,10 +58587,10 @@ module stdlib_linalg_lapack_w info = info + j - 1 40 continue return - end subroutine stdlib_wpotrf + end subroutine stdlib_${ci}$potrf - pure recursive subroutine stdlib_wpotrf2( uplo, n, a, lda, info ) + pure recursive subroutine stdlib_${ci}$potrf2( uplo, n, a, lda, info ) !! ZPOTRF2: computes the Cholesky factorization of a Hermitian !! positive definite matrix A using the recursive algorithm. !! The factorization has the form @@ -58610,14 +58612,14 @@ module stdlib_linalg_lapack_w integer(ilp), intent(out) :: info integer(ilp), intent(in) :: lda, n ! Array Arguments - complex(qp), intent(inout) :: a(lda,*) + complex(${ck}$), intent(inout) :: a(lda,*) ! ===================================================================== ! Local Scalars logical(lk) :: upper integer(ilp) :: n1, n2, iinfo - real(qp) :: ajj + real(${ck}$) :: ajj ! Intrinsic Functions intrinsic :: max,real,sqrt ! Executable Statements @@ -58640,8 +58642,8 @@ module stdlib_linalg_lapack_w ! n=1 case if( n==1 ) then ! test for non-positive-definiteness - ajj = real( a( 1, 1 ),KIND=qp) - if( ajj<=zero.or.stdlib_qisnan( ajj ) ) then + ajj = real( a( 1, 1 ),KIND=${ck}$) + if( ajj<=zero.or.stdlib_${c2ri(ci)}$isnan( ajj ) ) then info = 1 return end if @@ -58652,7 +58654,7 @@ module stdlib_linalg_lapack_w n1 = n/2 n2 = n-n1 ! factor a11 - call stdlib_wpotrf2( uplo, n1, a( 1, 1 ), lda, iinfo ) + call stdlib_${ci}$potrf2( uplo, n1, a( 1, 1 ), lda, iinfo ) if ( iinfo/=0 ) then info = iinfo return @@ -58660,12 +58662,12 @@ module stdlib_linalg_lapack_w ! compute the cholesky factorization a = u**h*u if( upper ) then ! update and scale a12 - call stdlib_wtrsm( 'L', 'U', 'C', 'N', n1, n2, cone,a( 1, 1 ), lda, a( 1, n1+1 ),& + call stdlib_${ci}$trsm( 'L', 'U', 'C', 'N', n1, n2, cone,a( 1, 1 ), lda, a( 1, n1+1 ),& lda ) ! update and factor a22 - call stdlib_wherk( uplo, 'C', n2, n1, -one, a( 1, n1+1 ), lda,one, a( n1+1, n1+1 & + call stdlib_${ci}$herk( uplo, 'C', n2, n1, -one, a( 1, n1+1 ), lda,one, a( n1+1, n1+1 & ), lda ) - call stdlib_wpotrf2( uplo, n2, a( n1+1, n1+1 ), lda, iinfo ) + call stdlib_${ci}$potrf2( uplo, n2, a( n1+1, n1+1 ), lda, iinfo ) if ( iinfo/=0 ) then info = iinfo + n1 return @@ -58673,12 +58675,12 @@ module stdlib_linalg_lapack_w ! compute the cholesky factorization a = l*l**h else ! update and scale a21 - call stdlib_wtrsm( 'R', 'L', 'C', 'N', n2, n1, cone,a( 1, 1 ), lda, a( n1+1, 1 ),& + call stdlib_${ci}$trsm( 'R', 'L', 'C', 'N', n2, n1, cone,a( 1, 1 ), lda, a( n1+1, 1 ),& lda ) ! update and factor a22 - call stdlib_wherk( uplo, 'N', n2, n1, -one, a( n1+1, 1 ), lda,one, a( n1+1, n1+1 & + call stdlib_${ci}$herk( uplo, 'N', n2, n1, -one, a( n1+1, 1 ), lda,one, a( n1+1, n1+1 & ), lda ) - call stdlib_wpotrf2( uplo, n2, a( n1+1, n1+1 ), lda, iinfo ) + call stdlib_${ci}$potrf2( uplo, n2, a( n1+1, n1+1 ), lda, iinfo ) if ( iinfo/=0 ) then info = iinfo + n1 return @@ -58686,10 +58688,10 @@ module stdlib_linalg_lapack_w end if end if return - end subroutine stdlib_wpotrf2 + end subroutine stdlib_${ci}$potrf2 - pure subroutine stdlib_wpotri( uplo, n, a, lda, info ) + pure subroutine stdlib_${ci}$potri( uplo, n, a, lda, info ) !! ZPOTRI: computes the inverse of a complex Hermitian positive definite !! matrix A using the Cholesky factorization A = U**H*U or A = L*L**H !! computed by ZPOTRF. @@ -58701,7 +58703,7 @@ module stdlib_linalg_lapack_w integer(ilp), intent(out) :: info integer(ilp), intent(in) :: lda, n ! Array Arguments - complex(qp), intent(inout) :: a(lda,*) + complex(${ck}$), intent(inout) :: a(lda,*) ! ===================================================================== ! Intrinsic Functions intrinsic :: max @@ -58722,15 +58724,15 @@ module stdlib_linalg_lapack_w ! quick return if possible if( n==0 )return ! invert the triangular cholesky factor u or l. - call stdlib_wtrtri( uplo, 'NON-UNIT', n, a, lda, info ) + call stdlib_${ci}$trtri( uplo, 'NON-UNIT', n, a, lda, info ) if( info>0 )return ! form inv(u) * inv(u)**h or inv(l)**h * inv(l). - call stdlib_wlauum( uplo, n, a, lda, info ) + call stdlib_${ci}$lauum( uplo, n, a, lda, info ) return - end subroutine stdlib_wpotri + end subroutine stdlib_${ci}$potri - pure subroutine stdlib_wpotrs( uplo, n, nrhs, a, lda, b, ldb, info ) + pure subroutine stdlib_${ci}$potrs( uplo, n, nrhs, a, lda, b, ldb, info ) !! ZPOTRS: solves a system of linear equations A*X = B with a Hermitian !! positive definite matrix A using the Cholesky factorization !! A = U**H * U or A = L * L**H computed by ZPOTRF. @@ -58742,8 +58744,8 @@ module stdlib_linalg_lapack_w integer(ilp), intent(out) :: info integer(ilp), intent(in) :: lda, ldb, n, nrhs ! Array Arguments - complex(qp), intent(in) :: a(lda,*) - complex(qp), intent(inout) :: b(ldb,*) + complex(${ck}$), intent(in) :: a(lda,*) + complex(${ck}$), intent(inout) :: b(ldb,*) ! ===================================================================== ! Local Scalars @@ -58774,25 +58776,25 @@ module stdlib_linalg_lapack_w if( upper ) then ! solve a*x = b where a = u**h *u. ! solve u**h *x = b, overwriting b with x. - call stdlib_wtrsm( 'LEFT', 'UPPER', 'CONJUGATE TRANSPOSE', 'NON-UNIT',n, nrhs, cone,& + call stdlib_${ci}$trsm( 'LEFT', 'UPPER', 'CONJUGATE TRANSPOSE', 'NON-UNIT',n, nrhs, cone,& a, lda, b, ldb ) ! solve u*x = b, overwriting b with x. - call stdlib_wtrsm( 'LEFT', 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', n,nrhs, cone, a, & + call stdlib_${ci}$trsm( 'LEFT', 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', n,nrhs, cone, a, & lda, b, ldb ) else ! solve a*x = b where a = l*l**h. ! solve l*x = b, overwriting b with x. - call stdlib_wtrsm( 'LEFT', 'LOWER', 'NO TRANSPOSE', 'NON-UNIT', n,nrhs, cone, a, & + call stdlib_${ci}$trsm( 'LEFT', 'LOWER', 'NO TRANSPOSE', 'NON-UNIT', n,nrhs, cone, a, & lda, b, ldb ) ! solve l**h *x = b, overwriting b with x. - call stdlib_wtrsm( 'LEFT', 'LOWER', 'CONJUGATE TRANSPOSE', 'NON-UNIT',n, nrhs, cone,& + call stdlib_${ci}$trsm( 'LEFT', 'LOWER', 'CONJUGATE TRANSPOSE', 'NON-UNIT',n, nrhs, cone,& a, lda, b, ldb ) end if return - end subroutine stdlib_wpotrs + end subroutine stdlib_${ci}$potrs - pure subroutine stdlib_wppcon( uplo, n, ap, anorm, rcond, work, rwork, info ) + pure subroutine stdlib_${ci}$ppcon( uplo, n, ap, anorm, rcond, work, rwork, info ) !! ZPPCON: estimates the reciprocal of the condition number (in the !! 1-norm) of a complex Hermitian positive definite packed matrix using !! the Cholesky factorization A = U**H*U or A = L*L**H computed by @@ -58806,28 +58808,28 @@ module stdlib_linalg_lapack_w character, intent(in) :: uplo integer(ilp), intent(out) :: info integer(ilp), intent(in) :: n - real(qp), intent(in) :: anorm - real(qp), intent(out) :: rcond + real(${ck}$), intent(in) :: anorm + real(${ck}$), intent(out) :: rcond ! Array Arguments - real(qp), intent(out) :: rwork(*) - complex(qp), intent(in) :: ap(*) - complex(qp), intent(out) :: work(*) + real(${ck}$), intent(out) :: rwork(*) + complex(${ck}$), intent(in) :: ap(*) + complex(${ck}$), intent(out) :: work(*) ! ===================================================================== ! Local Scalars logical(lk) :: upper character :: normin integer(ilp) :: ix, kase - real(qp) :: ainvnm, scale, scalel, scaleu, smlnum - complex(qp) :: zdum + real(${ck}$) :: ainvnm, scale, scalel, scaleu, smlnum + complex(${ck}$) :: zdum ! Local Arrays integer(ilp) :: isave(3) ! Intrinsic Functions intrinsic :: abs,real,aimag ! Statement Functions - real(qp) :: cabs1 + real(${ck}$) :: cabs1 ! Statement Function Definitions - cabs1( zdum ) = abs( real( zdum,KIND=qp) ) + abs( aimag( zdum ) ) + cabs1( zdum ) = abs( real( zdum,KIND=${ck}$) ) + abs( aimag( zdum ) ) ! Executable Statements ! test the input parameters. info = 0 @@ -58851,36 +58853,36 @@ module stdlib_linalg_lapack_w else if( anorm==zero ) then return end if - smlnum = stdlib_qlamch( 'SAFE MINIMUM' ) + smlnum = stdlib_${c2ri(ci)}$lamch( 'SAFE MINIMUM' ) ! estimate the 1-norm of the inverse. kase = 0 normin = 'N' 10 continue - call stdlib_wlacn2( n, work( n+1 ), work, ainvnm, kase, isave ) + call stdlib_${ci}$lacn2( n, work( n+1 ), work, ainvnm, kase, isave ) if( kase/=0 ) then if( upper ) then ! multiply by inv(u**h). - call stdlib_wlatps( 'UPPER', 'CONJUGATE TRANSPOSE', 'NON-UNIT',normin, n, ap, & + call stdlib_${ci}$latps( 'UPPER', 'CONJUGATE TRANSPOSE', 'NON-UNIT',normin, n, ap, & work, scalel, rwork, info ) normin = 'Y' ! multiply by inv(u). - call stdlib_wlatps( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', normin, n,ap, work, & + call stdlib_${ci}$latps( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', normin, n,ap, work, & scaleu, rwork, info ) else ! multiply by inv(l). - call stdlib_wlatps( 'LOWER', 'NO TRANSPOSE', 'NON-UNIT', normin, n,ap, work, & + call stdlib_${ci}$latps( 'LOWER', 'NO TRANSPOSE', 'NON-UNIT', normin, n,ap, work, & scalel, rwork, info ) normin = 'Y' ! multiply by inv(l**h). - call stdlib_wlatps( 'LOWER', 'CONJUGATE TRANSPOSE', 'NON-UNIT',normin, n, ap, & + call stdlib_${ci}$latps( 'LOWER', 'CONJUGATE TRANSPOSE', 'NON-UNIT',normin, n, ap, & work, scaleu, rwork, info ) end if ! multiply by 1/scale if doing so will not cause overflow. scale = scalel*scaleu if( scale/=one ) then - ix = stdlib_iwamax( n, work, 1 ) + ix = stdlib_i${ci}$amax( n, work, 1 ) if( scaleeps .and. two*berr( j )<=lstres .and.count<=itmax ) then ! update solution and try again. - call stdlib_wpptrs( uplo, n, 1, afp, work, n, info ) - call stdlib_waxpy( n, cone, work, 1, x( 1, j ), 1 ) + call stdlib_${ci}$pptrs( uplo, n, 1, afp, work, n, info ) + call stdlib_${ci}$axpy( n, cone, work, 1, x( 1, j ), 1 ) lstres = berr( j ) count = count + 1 go to 20 @@ -59140,7 +59142,7 @@ module stdlib_linalg_lapack_w ! 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_wlacn2 to estimate the infinity-norm of the matrix + ! 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 @@ -59152,11 +59154,11 @@ module stdlib_linalg_lapack_w end do kase = 0 100 continue - call stdlib_wlacn2( n, work( n+1 ), work, ferr( j ), kase, isave ) + call stdlib_${ci}$lacn2( n, work( n+1 ), work, ferr( j ), kase, isave ) if( kase/=0 ) then if( kase==1 ) then ! multiply by diag(w)*inv(a**h). - call stdlib_wpptrs( uplo, n, 1, afp, work, n, info ) + call stdlib_${ci}$pptrs( uplo, n, 1, afp, work, n, info ) do i = 1, n work( i ) = rwork( i )*work( i ) end do @@ -59165,7 +59167,7 @@ module stdlib_linalg_lapack_w do i = 1, n work( i ) = rwork( i )*work( i ) end do - call stdlib_wpptrs( uplo, n, 1, afp, work, n, info ) + call stdlib_${ci}$pptrs( uplo, n, 1, afp, work, n, info ) end if go to 100 end if @@ -59177,10 +59179,10 @@ module stdlib_linalg_lapack_w if( lstres/=zero )ferr( j ) = ferr( j ) / lstres end do loop_140 return - end subroutine stdlib_wpprfs + end subroutine stdlib_${ci}$pprfs - pure subroutine stdlib_wppsv( uplo, n, nrhs, ap, b, ldb, info ) + pure subroutine stdlib_${ci}$ppsv( uplo, n, nrhs, ap, b, ldb, info ) !! ZPPSV: computes the solution to a complex system of linear equations !! A * X = B, !! where A is an N-by-N Hermitian positive definite matrix stored in @@ -59199,7 +59201,7 @@ module stdlib_linalg_lapack_w integer(ilp), intent(out) :: info integer(ilp), intent(in) :: ldb, n, nrhs ! Array Arguments - complex(qp), intent(inout) :: ap(*), b(ldb,*) + complex(${ck}$), intent(inout) :: ap(*), b(ldb,*) ! ===================================================================== ! Intrinsic Functions intrinsic :: max @@ -59220,16 +59222,16 @@ module stdlib_linalg_lapack_w return end if ! compute the cholesky factorization a = u**h *u or a = l*l**h. - call stdlib_wpptrf( uplo, n, ap, info ) + call stdlib_${ci}$pptrf( uplo, n, ap, info ) if( info==0 ) then ! solve the system a*x = b, overwriting b with x. - call stdlib_wpptrs( uplo, n, nrhs, ap, b, ldb, info ) + call stdlib_${ci}$pptrs( uplo, n, nrhs, ap, b, ldb, info ) end if return - end subroutine stdlib_wppsv + end subroutine stdlib_${ci}$ppsv - subroutine stdlib_wppsvx( fact, uplo, n, nrhs, ap, afp, equed, s, b, ldb,x, ldx, rcond, ferr,& + subroutine stdlib_${ci}$ppsvx( fact, uplo, n, nrhs, ap, afp, equed, s, b, ldb,x, ldx, rcond, ferr,& !! ZPPSVX: uses the Cholesky factorization A = U**H * U or A = L * L**H to !! compute the solution to a complex system of linear equations !! A * X = B, @@ -59246,18 +59248,18 @@ module stdlib_linalg_lapack_w character, intent(in) :: fact, uplo integer(ilp), intent(out) :: info integer(ilp), intent(in) :: ldb, ldx, n, nrhs - real(qp), intent(out) :: rcond + real(${ck}$), intent(out) :: rcond ! Array Arguments - real(qp), intent(out) :: berr(*), ferr(*), rwork(*) - real(qp), intent(inout) :: s(*) - complex(qp), intent(inout) :: afp(*), ap(*), b(ldb,*) - complex(qp), intent(out) :: work(*), x(ldx,*) + real(${ck}$), intent(out) :: berr(*), ferr(*), rwork(*) + real(${ck}$), intent(inout) :: s(*) + complex(${ck}$), intent(inout) :: afp(*), ap(*), b(ldb,*) + complex(${ck}$), intent(out) :: work(*), x(ldx,*) ! ===================================================================== ! Local Scalars logical(lk) :: equil, nofact, rcequ integer(ilp) :: i, infequ, j - real(qp) :: amax, anorm, bignum, scond, smax, smin, smlnum + real(${ck}$) :: amax, anorm, bignum, scond, smax, smin, smlnum ! Intrinsic Functions intrinsic :: max,min ! Executable Statements @@ -59269,7 +59271,7 @@ module stdlib_linalg_lapack_w rcequ = .false. else rcequ = stdlib_lsame( equed, 'Y' ) - smlnum = stdlib_qlamch( 'SAFE MINIMUM' ) + smlnum = stdlib_${c2ri(ci)}$lamch( 'SAFE MINIMUM' ) bignum = one / smlnum end if ! test the input parameters. @@ -59315,10 +59317,10 @@ module stdlib_linalg_lapack_w end if if( equil ) then ! compute row and column scalings to equilibrate the matrix a. - call stdlib_wppequ( uplo, n, ap, s, scond, amax, infequ ) + call stdlib_${ci}$ppequ( uplo, n, ap, s, scond, amax, infequ ) if( infequ==0 ) then ! equilibrate the matrix. - call stdlib_wlaqhp( uplo, n, ap, s, scond, amax, equed ) + call stdlib_${ci}$laqhp( uplo, n, ap, s, scond, amax, equed ) rcequ = stdlib_lsame( equed, 'Y' ) end if end if @@ -59332,8 +59334,8 @@ module stdlib_linalg_lapack_w end if if( nofact .or. equil ) then ! compute the cholesky factorization a = u**h * u or a = l * l**h. - call stdlib_wcopy( n*( n+1 ) / 2, ap, 1, afp, 1 ) - call stdlib_wpptrf( uplo, n, afp, info ) + call stdlib_${ci}$copy( n*( n+1 ) / 2, ap, 1, afp, 1 ) + call stdlib_${ci}$pptrf( uplo, n, afp, info ) ! return if info is non-zero. if( info>0 )then rcond = zero @@ -59341,15 +59343,15 @@ module stdlib_linalg_lapack_w end if end if ! compute the norm of the matrix a. - anorm = stdlib_wlanhp( 'I', uplo, n, ap, rwork ) + anorm = stdlib_${ci}$lanhp( 'I', uplo, n, ap, rwork ) ! compute the reciprocal of the condition number of a. - call stdlib_wppcon( uplo, n, afp, anorm, rcond, work, rwork, info ) + call stdlib_${ci}$ppcon( uplo, n, afp, anorm, rcond, work, rwork, info ) ! compute the solution matrix x. - call stdlib_wlacpy( 'FULL', n, nrhs, b, ldb, x, ldx ) - call stdlib_wpptrs( uplo, n, nrhs, afp, x, ldx, info ) + call stdlib_${ci}$lacpy( 'FULL', n, nrhs, b, ldb, x, ldx ) + call stdlib_${ci}$pptrs( uplo, n, nrhs, afp, x, ldx, info ) ! use iterative refinement to improve the computed solution and ! compute error bounds and backward error estimates for it. - call stdlib_wpprfs( uplo, n, nrhs, ap, afp, b, ldb, x, ldx, ferr, berr,work, rwork, & + call stdlib_${ci}$pprfs( uplo, n, nrhs, ap, afp, b, ldb, x, ldx, ferr, berr,work, rwork, & info ) ! transform the solution matrix x to a solution of the original ! system. @@ -59364,12 +59366,12 @@ module stdlib_linalg_lapack_w end do end if ! set info = n+1 if the matrix is singular to working precision. - if( rcond1 )call stdlib_wtpsv( 'UPPER', 'CONJUGATE TRANSPOSE', 'NON-UNIT',j-1, ap, & + if( j>1 )call stdlib_${ci}$tpsv( 'UPPER', 'CONJUGATE TRANSPOSE', 'NON-UNIT',j-1, ap, & ap( jc ), 1 ) ! compute u(j,j) and test for non-positive-definiteness. - ajj = real( ap( jj ),KIND=qp) - real( stdlib_wdotc( j-1,ap( jc ), 1, ap( jc ), 1 & - ),KIND=qp) + ajj = real( ap( jj ),KIND=${ck}$) - real( stdlib_${ci}$dotc( j-1,ap( jc ), 1, ap( jc ), 1 & + ),KIND=${ck}$) if( ajj<=zero ) then ap( jj ) = ajj go to 30 @@ -59431,7 +59433,7 @@ module stdlib_linalg_lapack_w jj = 1 do j = 1, n ! compute l(j,j) and test for non-positive-definiteness. - ajj = real( ap( jj ),KIND=qp) + ajj = real( ap( jj ),KIND=${ck}$) if( ajj<=zero ) then ap( jj ) = ajj go to 30 @@ -59441,8 +59443,8 @@ module stdlib_linalg_lapack_w ! compute elements j+1:n of column j and update the trailing ! submatrix. if( j0 )return if( upper ) then ! compute the product inv(u) * inv(u)**h. @@ -59500,26 +59502,26 @@ module stdlib_linalg_lapack_w do j = 1, n jc = jj + 1 jj = jj + j - if( j>1 )call stdlib_whpr( 'UPPER', j-1, one, ap( jc ), 1, ap ) - ajj = real( ap( jj ),KIND=qp) - call stdlib_wdscal( j, ajj, ap( jc ), 1 ) + if( j>1 )call stdlib_${ci}$hpr( 'UPPER', j-1, one, ap( jc ), 1, ap ) + ajj = real( ap( jj ),KIND=${ck}$) + call stdlib_${ci}$dscal( j, ajj, ap( jc ), 1 ) end do else ! compute the product inv(l)**h * inv(l). jj = 1 do j = 1, n jjn = jj + n - j + 1 - ap( jj ) = real( stdlib_wdotc( n-j+1, ap( jj ), 1, ap( jj ), 1 ),KIND=qp) - if( j1 ) then - work( i ) = work( i ) +real( conjg( a( j-1, i ) )*a( j-1, i ),KIND=qp) + work( i ) = work( i ) +real( conjg( a( j-1, i ) )*a( j-1, i ),KIND=${ck}$) end if - work( n+i ) = real( a( i, i ),KIND=qp) - work( i ) + work( n+i ) = real( a( i, i ),KIND=${ck}$) - work( i ) end do if( j>1 ) then itemp = maxloc( work( (n+j):(2*n) ), 1 ) pvt = itemp + j - 1 ajj = work( n+pvt ) - if( ajj<=dstop.or.stdlib_qisnan( ajj ) ) then + if( ajj<=dstop.or.stdlib_${c2ri(ci)}$isnan( ajj ) ) then a( j, j ) = ajj go to 190 end if @@ -59682,8 +59684,8 @@ module stdlib_linalg_lapack_w if( j/=pvt ) then ! pivot ok, so can now swap pivot rows and columns a( pvt, pvt ) = a( j, j ) - call stdlib_wswap( j-1, a( 1, j ), 1, a( 1, pvt ), 1 ) - if( pvt1 ) then - work( i ) = work( i ) +real( conjg( a( i, j-1 ) )*a( i, j-1 ),KIND=qp) + work( i ) = work( i ) +real( conjg( a( i, j-1 ) )*a( i, j-1 ),KIND=${ck}$) end if - work( n+i ) = real( a( i, i ),KIND=qp) - work( i ) + work( n+i ) = real( a( i, i ),KIND=${ck}$) - work( i ) end do if( j>1 ) then itemp = maxloc( work( (n+j):(2*n) ), 1 ) pvt = itemp + j - 1 ajj = work( n+pvt ) - if( ajj<=dstop.or.stdlib_qisnan( ajj ) ) then + if( ajj<=dstop.or.stdlib_${c2ri(ci)}$isnan( ajj ) ) then a( j, j ) = ajj go to 190 end if @@ -59735,8 +59737,8 @@ module stdlib_linalg_lapack_w if( j/=pvt ) then ! pivot ok, so can now swap pivot rows and columns a( pvt, pvt ) = a( j, j ) - call stdlib_wswap( j-1, a( j, 1 ), lda, a( pvt, 1 ), lda ) - if( pvt=n ) then ! use unblocked code - call stdlib_wpstf2( uplo, n, a( 1, 1 ), lda, piv, rank, tol, work,info ) + call stdlib_${ci}$pstf2( uplo, n, a( 1, 1 ), lda, piv, rank, tol, work,info ) go to 230 else ! initialize piv @@ -59839,18 +59841,18 @@ module stdlib_linalg_lapack_w end do ! compute stopping value do i = 1, n - work( i ) = real( a( i, i ),KIND=qp) + work( i ) = real( a( i, i ),KIND=${ck}$) end do pvt = maxloc( work( 1:n ), 1 ) - ajj = real( a( pvt, pvt ),KIND=qp) - if( ajj<=zero.or.stdlib_qisnan( ajj ) ) then + ajj = real( a( pvt, pvt ),KIND=${ck}$) + if( ajj<=zero.or.stdlib_${c2ri(ci)}$isnan( ajj ) ) then rank = 0 info = 1 go to 230 end if ! compute stopping value if not supplied if( tolk ) then work( i ) = work( i ) +real( conjg( a( j-1, i ) )*a( j-1, i ),& - KIND=qp) + KIND=${ck}$) end if - work( n+i ) = real( a( i, i ),KIND=qp) - work( i ) + work( n+i ) = real( a( i, i ),KIND=${ck}$) - work( i ) end do if( j>1 ) then itemp = maxloc( work( (n+j):(2*n) ), 1 ) pvt = itemp + j - 1 ajj = work( n+pvt ) - if( ajj<=dstop.or.stdlib_qisnan( ajj ) ) then + if( ajj<=dstop.or.stdlib_${c2ri(ci)}$isnan( ajj ) ) then a( j, j ) = ajj go to 220 end if @@ -59887,8 +59889,8 @@ module stdlib_linalg_lapack_w if( j/=pvt ) then ! pivot ok, so can now swap pivot rows and columns a( pvt, pvt ) = a( j, j ) - call stdlib_wswap( j-1, a( 1, j ), 1, a( 1, pvt ), 1 ) - if( pvtk ) then work( i ) = work( i ) +real( conjg( a( i, j-1 ) )*a( i, j-1 ),& - KIND=qp) + KIND=${ck}$) end if - work( n+i ) = real( a( i, i ),KIND=qp) - work( i ) + work( n+i ) = real( a( i, i ),KIND=${ck}$) - work( i ) end do if( j>1 ) then itemp = maxloc( work( (n+j):(2*n) ), 1 ) pvt = itemp + j - 1 ajj = work( n+pvt ) - if( ajj<=dstop.or.stdlib_qisnan( ajj ) ) then + if( ajj<=dstop.or.stdlib_${c2ri(ci)}$isnan( ajj ) ) then a( j, j ) = ajj go to 220 end if @@ -59954,8 +59956,8 @@ module stdlib_linalg_lapack_w if( j/=pvt ) then ! pivot ok, so can now swap pivot rows and columns a( pvt, pvt ) = a( j, j ) - call stdlib_wswap( j-1, a( j, 1 ), lda, a( pvt, 1 ), lda ) - if( pvt0 )z( 1, 1 ) = cone return end if - if( icompz==2 )call stdlib_wlaset( 'FULL', n, n, czero, cone, z, ldz ) - ! call stdlib_qpttrf to factor the matrix. - call stdlib_qpttrf( n, d, e, info ) + if( icompz==2 )call stdlib_${ci}$laset( 'FULL', n, n, czero, cone, z, ldz ) + ! call stdlib_${c2ri(ci)}$pttrf to factor the matrix. + call stdlib_${c2ri(ci)}$pttrf( n, d, e, info ) if( info/=0 )return do i = 1, n d( i ) = sqrt( d( i ) ) @@ -60151,14 +60153,14 @@ module stdlib_linalg_lapack_w do i = 1, n - 1 e( i ) = e( i )*d( i ) end do - ! call stdlib_wbdsqr to compute the singular values/vectors of the + ! call stdlib_${ci}$bdsqr to compute the singular values/vectors of the ! bidiagonal factor. if( icompz>0 ) then nru = n else nru = 0 end if - call stdlib_wbdsqr( 'LOWER', n, 0, nru, 0, d, e, vt, 1, z, ldz, c, 1,work, info ) + call stdlib_${ci}$bdsqr( 'LOWER', n, 0, nru, 0, d, e, vt, 1, z, ldz, c, 1,work, info ) ! square the singular values. if( info==0 ) then @@ -60169,10 +60171,10 @@ module stdlib_linalg_lapack_w info = n + info end if return - end subroutine stdlib_wpteqr + end subroutine stdlib_${ci}$pteqr - pure subroutine stdlib_wptrfs( uplo, n, nrhs, d, e, df, ef, b, ldb, x, ldx,ferr, berr, work, & + pure subroutine stdlib_${ci}$ptrfs( uplo, n, nrhs, d, e, df, ef, b, ldb, x, ldx,ferr, berr, work, & !! ZPTRFS: improves the computed solution to a system of linear !! equations when the coefficient matrix is Hermitian positive definite !! and tridiagonal, and provides error bounds and backward error @@ -60186,11 +60188,11 @@ module stdlib_linalg_lapack_w integer(ilp), intent(out) :: info integer(ilp), intent(in) :: ldb, ldx, n, nrhs ! Array Arguments - real(qp), intent(out) :: berr(*), ferr(*), rwork(*) - real(qp), intent(in) :: d(*), df(*) - complex(qp), intent(in) :: b(ldb,*), e(*), ef(*) - complex(qp), intent(out) :: work(*) - complex(qp), intent(inout) :: x(ldx,*) + real(${ck}$), intent(out) :: berr(*), ferr(*), rwork(*) + real(${ck}$), intent(in) :: d(*), df(*) + complex(${ck}$), intent(in) :: b(ldb,*), e(*), ef(*) + complex(${ck}$), intent(out) :: work(*) + complex(${ck}$), intent(inout) :: x(ldx,*) ! ===================================================================== ! Parameters integer(ilp), parameter :: itmax = 5 @@ -60202,14 +60204,14 @@ module stdlib_linalg_lapack_w ! Local Scalars logical(lk) :: upper integer(ilp) :: count, i, ix, j, nz - real(qp) :: eps, lstres, s, safe1, safe2, safmin - complex(qp) :: bi, cx, dx, ex, zdum + real(${ck}$) :: eps, lstres, s, safe1, safe2, safmin + complex(${ck}$) :: bi, cx, dx, ex, zdum ! Intrinsic Functions intrinsic :: abs,real,cmplx,conjg,aimag,max ! Statement Functions - real(qp) :: cabs1 + real(${ck}$) :: cabs1 ! Statement Function Definitions - cabs1( zdum ) = abs( real( zdum,KIND=qp) ) + abs( aimag( zdum ) ) + cabs1( zdum ) = abs( real( zdum,KIND=${ck}$) ) + abs( aimag( zdum ) ) ! Executable Statements ! test the input parameters. info = 0 @@ -60239,8 +60241,8 @@ module stdlib_linalg_lapack_w end if ! nz = maximum number of nonzero elements in each row of a, plus 1 nz = 4 - eps = stdlib_qlamch( 'EPSILON' ) - safmin = stdlib_qlamch( 'SAFE MINIMUM' ) + eps = stdlib_${c2ri(ci)}$lamch( 'EPSILON' ) + safmin = stdlib_${c2ri(ci)}$lamch( 'SAFE MINIMUM' ) safe1 = nz*safmin safe2 = safe1 / eps ! do for each right hand side @@ -60332,8 +60334,8 @@ module stdlib_linalg_lapack_w ! 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_wpttrs( uplo, n, 1, df, ef, work, n, info ) - call stdlib_waxpy( n, cmplx( one,KIND=qp), work, 1, x( 1, j ), 1 ) + call stdlib_${ci}$pttrs( uplo, n, 1, df, ef, work, n, info ) + call stdlib_${ci}$axpy( n, cmplx( one,KIND=${ck}$), work, 1, x( 1, j ), 1 ) lstres = berr( j ) count = count + 1 go to 20 @@ -60359,7 +60361,7 @@ module stdlib_linalg_lapack_w rwork( i ) = cabs1( work( i ) ) + nz*eps*rwork( i ) +safe1 end if end do - ix = stdlib_iqamax( n, rwork, 1 ) + ix = stdlib_i${c2ri(ci)}$amax( n, rwork, 1 ) ferr( j ) = rwork( ix ) ! estimate the norm of inv(a). ! solve m(a) * x = e, where m(a) = (m(i,j)) is given by @@ -60377,7 +60379,7 @@ module stdlib_linalg_lapack_w rwork( i ) = rwork( i ) / df( i ) +rwork( i+1 )*abs( ef( i ) ) end do ! compute norm(inv(a)) = max(x(i)), 1<=i<=n. - ix = stdlib_iqamax( n, rwork, 1 ) + ix = stdlib_i${c2ri(ci)}$amax( n, rwork, 1 ) ferr( j ) = ferr( j )*abs( rwork( ix ) ) ! normalize error. lstres = zero @@ -60387,10 +60389,10 @@ module stdlib_linalg_lapack_w if( lstres/=zero )ferr( j ) = ferr( j ) / lstres end do loop_100 return - end subroutine stdlib_wptrfs + end subroutine stdlib_${ci}$ptrfs - pure subroutine stdlib_wptsv( n, nrhs, d, e, b, ldb, info ) + pure subroutine stdlib_${ci}$ptsv( n, nrhs, d, e, b, ldb, info ) !! ZPTSV: computes the solution to a complex system of linear equations !! A*X = B, where A is an N-by-N Hermitian positive definite tridiagonal !! matrix, and X and B are N-by-NRHS matrices. @@ -60403,8 +60405,8 @@ module stdlib_linalg_lapack_w integer(ilp), intent(out) :: info integer(ilp), intent(in) :: ldb, n, nrhs ! Array Arguments - real(qp), intent(inout) :: d(*) - complex(qp), intent(inout) :: b(ldb,*), e(*) + real(${ck}$), intent(inout) :: d(*) + complex(${ck}$), intent(inout) :: b(ldb,*), e(*) ! ===================================================================== ! Intrinsic Functions intrinsic :: max @@ -60423,16 +60425,16 @@ module stdlib_linalg_lapack_w return end if ! compute the l*d*l**h (or u**h*d*u) factorization of a. - call stdlib_wpttrf( n, d, e, info ) + call stdlib_${ci}$pttrf( n, d, e, info ) if( info==0 ) then ! solve the system a*x = b, overwriting b with x. - call stdlib_wpttrs( 'LOWER', n, nrhs, d, e, b, ldb, info ) + call stdlib_${ci}$pttrs( 'LOWER', n, nrhs, d, e, b, ldb, info ) end if return - end subroutine stdlib_wptsv + end subroutine stdlib_${ci}$ptsv - pure subroutine stdlib_wptsvx( fact, n, nrhs, d, e, df, ef, b, ldb, x, ldx,rcond, ferr, berr,& + pure subroutine stdlib_${ci}$ptsvx( fact, n, nrhs, d, e, df, ef, b, ldb, x, ldx,rcond, ferr, berr,& !! ZPTSVX: uses the factorization A = L*D*L**H to compute the solution !! to a complex system of linear equations A*X = B, where A is an !! N-by-N Hermitian positive definite tridiagonal matrix and X and B @@ -60447,19 +60449,19 @@ module stdlib_linalg_lapack_w character, intent(in) :: fact integer(ilp), intent(out) :: info integer(ilp), intent(in) :: ldb, ldx, n, nrhs - real(qp), intent(out) :: rcond + real(${ck}$), intent(out) :: rcond ! Array Arguments - real(qp), intent(out) :: berr(*), ferr(*), rwork(*) - real(qp), intent(in) :: d(*) - real(qp), intent(inout) :: df(*) - complex(qp), intent(in) :: b(ldb,*), e(*) - complex(qp), intent(inout) :: ef(*) - complex(qp), intent(out) :: work(*), x(ldx,*) + real(${ck}$), intent(out) :: berr(*), ferr(*), rwork(*) + real(${ck}$), intent(in) :: d(*) + real(${ck}$), intent(inout) :: df(*) + complex(${ck}$), intent(in) :: b(ldb,*), e(*) + complex(${ck}$), intent(inout) :: ef(*) + complex(${ck}$), intent(out) :: work(*), x(ldx,*) ! ===================================================================== ! Local Scalars logical(lk) :: nofact - real(qp) :: anorm + real(${ck}$) :: anorm ! Intrinsic Functions intrinsic :: max ! Executable Statements @@ -60483,9 +60485,9 @@ module stdlib_linalg_lapack_w end if if( nofact ) then ! compute the l*d*l**h (or u**h*d*u) factorization of a. - call stdlib_qcopy( n, d, 1, df, 1 ) - if( n>1 )call stdlib_wcopy( n-1, e, 1, ef, 1 ) - call stdlib_wpttrf( n, df, ef, info ) + call stdlib_${c2ri(ci)}$copy( n, d, 1, df, 1 ) + if( n>1 )call stdlib_${ci}$copy( n-1, e, 1, ef, 1 ) + call stdlib_${ci}$pttrf( n, df, ef, info ) ! return if info is non-zero. if( info>0 )then rcond = zero @@ -60493,23 +60495,23 @@ module stdlib_linalg_lapack_w end if end if ! compute the norm of the matrix a. - anorm = stdlib_wlanht( '1', n, d, e ) + anorm = stdlib_${ci}$lanht( '1', n, d, e ) ! compute the reciprocal of the condition number of a. - call stdlib_wptcon( n, df, ef, anorm, rcond, rwork, info ) + call stdlib_${ci}$ptcon( n, df, ef, anorm, rcond, rwork, info ) ! compute the solution vectors x. - call stdlib_wlacpy( 'FULL', n, nrhs, b, ldb, x, ldx ) - call stdlib_wpttrs( 'LOWER', n, nrhs, df, ef, x, ldx, info ) + call stdlib_${ci}$lacpy( 'FULL', n, nrhs, b, ldb, x, ldx ) + call stdlib_${ci}$pttrs( 'LOWER', n, nrhs, df, ef, x, ldx, info ) ! use iterative refinement to improve the computed solutions and ! compute error bounds and backward error estimates for them. - call stdlib_wptrfs( 'LOWER', n, nrhs, d, e, df, ef, b, ldb, x, ldx, ferr,berr, work, & + call stdlib_${ci}$ptrfs( 'LOWER', n, nrhs, d, e, df, ef, b, ldb, x, ldx, ferr,berr, work, & rwork, info ) ! set info = n+1 if the matrix is singular to working precision. - if( rcond=nrhs ) then - call stdlib_wptts2( iuplo, n, nrhs, d, e, b, ldb ) + call stdlib_${ci}$ptts2( iuplo, n, nrhs, d, e, b, ldb ) else do j = 1, nrhs, nb jb = min( nrhs-j+1, nb ) - call stdlib_wptts2( iuplo, n, jb, d, e, b( 1, j ), ldb ) + call stdlib_${ci}$ptts2( iuplo, n, jb, d, e, b( 1, j ), ldb ) end do end if return - end subroutine stdlib_wpttrs + end subroutine stdlib_${ci}$pttrs - pure subroutine stdlib_wptts2( iuplo, n, nrhs, d, e, b, ldb ) + pure subroutine stdlib_${ci}$ptts2( iuplo, n, nrhs, d, e, b, ldb ) !! ZPTTS2: solves a tridiagonal system of the form !! A * X = B !! using the factorization A = U**H *D*U or A = L*D*L**H computed by ZPTTRF. @@ -60688,9 +60690,9 @@ module stdlib_linalg_lapack_w ! Scalar Arguments integer(ilp), intent(in) :: iuplo, ldb, n, nrhs ! Array Arguments - real(qp), intent(in) :: d(*) - complex(qp), intent(inout) :: b(ldb,*) - complex(qp), intent(in) :: e(*) + real(${ck}$), intent(in) :: d(*) + complex(${ck}$), intent(inout) :: b(ldb,*) + complex(${ck}$), intent(in) :: e(*) ! ===================================================================== ! Local Scalars integer(ilp) :: i, j @@ -60699,7 +60701,7 @@ module stdlib_linalg_lapack_w ! Executable Statements ! quick return if possible if( n<=1 ) then - if( n==1 )call stdlib_wdscal( nrhs, 1._qp / d( 1 ), b, ldb ) + if( n==1 )call stdlib_${ci}$dscal( nrhs, 1._${ck}$ / d( 1 ), b, ldb ) return end if if( iuplo==1 ) then @@ -60772,10 +60774,10 @@ module stdlib_linalg_lapack_w end if end if return - end subroutine stdlib_wptts2 + end subroutine stdlib_${ci}$ptts2 - pure subroutine stdlib_wrot( n, cx, incx, cy, incy, c, s ) + pure subroutine stdlib_${ci}$rot( n, cx, incx, cy, incy, c, s ) !! ZROT: applies a plane rotation, where the cos (C) is real and the !! sin (S) is complex, and the vectors CX and CY are complex. ! -- lapack auxiliary routine -- @@ -60783,14 +60785,14 @@ module stdlib_linalg_lapack_w ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments integer(ilp), intent(in) :: incx, incy, n - real(qp), intent(in) :: c - complex(qp), intent(in) :: s + real(${ck}$), intent(in) :: c + complex(${ck}$), intent(in) :: s ! Array Arguments - complex(qp), intent(inout) :: cx(*), cy(*) + complex(${ck}$), intent(inout) :: cx(*), cy(*) ! ===================================================================== ! Local Scalars integer(ilp) :: i, ix, iy - complex(qp) :: stemp + complex(${ck}$) :: stemp ! Intrinsic Functions intrinsic :: conjg ! Executable Statements @@ -60817,10 +60819,10 @@ module stdlib_linalg_lapack_w cx( i ) = stemp end do return - end subroutine stdlib_wrot + end subroutine stdlib_${ci}$rot - pure subroutine stdlib_wspcon( uplo, n, ap, ipiv, anorm, rcond, work, info ) + pure subroutine stdlib_${ci}$spcon( uplo, n, ap, ipiv, anorm, rcond, work, info ) !! ZSPCON: estimates the reciprocal of the condition number (in the !! 1-norm) of a complex symmetric packed matrix A using the !! factorization A = U*D*U**T or A = L*D*L**T computed by ZSPTRF. @@ -60833,18 +60835,18 @@ module stdlib_linalg_lapack_w character, intent(in) :: uplo integer(ilp), intent(out) :: info integer(ilp), intent(in) :: n - real(qp), intent(in) :: anorm - real(qp), intent(out) :: rcond + real(${ck}$), intent(in) :: anorm + real(${ck}$), intent(out) :: rcond ! Array Arguments integer(ilp), intent(in) :: ipiv(*) - complex(qp), intent(in) :: ap(*) - complex(qp), intent(out) :: work(*) + complex(${ck}$), intent(in) :: ap(*) + complex(${ck}$), intent(out) :: work(*) ! ===================================================================== ! Local Scalars logical(lk) :: upper integer(ilp) :: i, ip, kase - real(qp) :: ainvnm + real(${ck}$) :: ainvnm ! Local Arrays integer(ilp) :: isave(3) ! Executable Statements @@ -60889,19 +60891,19 @@ module stdlib_linalg_lapack_w ! estimate the 1-norm of the inverse. kase = 0 30 continue - call stdlib_wlacn2( n, work( n+1 ), work, ainvnm, kase, isave ) + call stdlib_${ci}$lacn2( n, work( n+1 ), work, ainvnm, kase, isave ) if( kase/=0 ) then ! multiply by inv(l*d*l**t) or inv(u*d*u**t). - call stdlib_wsptrs( uplo, n, 1, ap, ipiv, work, n, info ) + call stdlib_${ci}$sptrs( uplo, n, 1, ap, 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_wspcon + end subroutine stdlib_${ci}$spcon - pure subroutine stdlib_wspmv( uplo, n, alpha, ap, x, incx, beta, y, incy ) + pure subroutine stdlib_${ci}$spmv( uplo, n, alpha, ap, x, incx, beta, y, incy ) !! ZSPMV: performs the matrix-vector operation !! y := alpha*A*x + beta*y, !! where alpha and beta are scalars, x and y are n element vectors and @@ -60912,16 +60914,16 @@ module stdlib_linalg_lapack_w ! Scalar Arguments character, intent(in) :: uplo integer(ilp), intent(in) :: incx, incy, n - complex(qp), intent(in) :: alpha, beta + complex(${ck}$), intent(in) :: alpha, beta ! Array Arguments - complex(qp), intent(in) :: ap(*), x(*) - complex(qp), intent(inout) :: y(*) + complex(${ck}$), intent(in) :: ap(*), x(*) + complex(${ck}$), intent(inout) :: y(*) ! ===================================================================== ! Local Scalars integer(ilp) :: i, info, ix, iy, j, jx, jy, k, kk, kx, ky - complex(qp) :: temp1, temp2 + complex(${ck}$) :: temp1, temp2 ! Executable Statements ! test the input parameters. info = 0 @@ -61056,10 +61058,10 @@ module stdlib_linalg_lapack_w end if end if return - end subroutine stdlib_wspmv + end subroutine stdlib_${ci}$spmv - pure subroutine stdlib_wspr( uplo, n, alpha, x, incx, ap ) + pure subroutine stdlib_${ci}$spr( uplo, n, alpha, x, incx, ap ) !! ZSPR: performs the symmetric rank 1 operation !! A := alpha*x*x**H + A, !! where alpha is a complex scalar, x is an n element vector and A is an @@ -61070,15 +61072,15 @@ module stdlib_linalg_lapack_w ! Scalar Arguments character, intent(in) :: uplo integer(ilp), intent(in) :: incx, n - complex(qp), intent(in) :: alpha + complex(${ck}$), intent(in) :: alpha ! Array Arguments - complex(qp), intent(inout) :: ap(*) - complex(qp), intent(in) :: x(*) + complex(${ck}$), intent(inout) :: ap(*) + complex(${ck}$), intent(in) :: x(*) ! ===================================================================== ! Local Scalars integer(ilp) :: i, info, ix, j, jx, k, kk, kx - complex(qp) :: temp + complex(${ck}$) :: temp ! Executable Statements ! test the input parameters. info = 0 @@ -61176,10 +61178,10 @@ module stdlib_linalg_lapack_w end if end if return - end subroutine stdlib_wspr + end subroutine stdlib_${ci}$spr - pure subroutine stdlib_wsprfs( uplo, n, nrhs, ap, afp, ipiv, b, ldb, x, ldx,ferr, berr, work,& + pure subroutine stdlib_${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 @@ -61194,10 +61196,10 @@ module stdlib_linalg_lapack_w integer(ilp), intent(in) :: ldb, ldx, n, nrhs ! Array Arguments integer(ilp), intent(in) :: ipiv(*) - real(qp), intent(out) :: berr(*), ferr(*), rwork(*) - complex(qp), intent(in) :: afp(*), ap(*), b(ldb,*) - complex(qp), intent(out) :: work(*) - complex(qp), intent(inout) :: x(ldx,*) + 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(ilp), parameter :: itmax = 5 @@ -61209,16 +61211,16 @@ module stdlib_linalg_lapack_w ! Local Scalars logical(lk) :: upper integer(ilp) :: count, i, ik, j, k, kase, kk, nz - real(qp) :: eps, lstres, s, safe1, safe2, safmin, xk - complex(qp) :: zdum + real(${ck}$) :: eps, lstres, s, safe1, safe2, safmin, xk + complex(${ck}$) :: zdum ! Local Arrays integer(ilp) :: isave(3) ! Intrinsic Functions intrinsic :: abs,real,aimag,max ! Statement Functions - real(qp) :: cabs1 + real(${ck}$) :: cabs1 ! Statement Function Definitions - cabs1( zdum ) = abs( real( zdum,KIND=qp) ) + abs( aimag( zdum ) ) + cabs1( zdum ) = abs( real( zdum,KIND=${ck}$) ) + abs( aimag( zdum ) ) ! Executable Statements ! test the input parameters. info = 0 @@ -61248,8 +61250,8 @@ module stdlib_linalg_lapack_w end if ! nz = maximum number of nonzero elements in each row of a, plus 1 nz = n + 1 - eps = stdlib_qlamch( 'EPSILON' ) - safmin = stdlib_qlamch( 'SAFE MINIMUM' ) + eps = stdlib_${c2ri(ci)}$lamch( 'EPSILON' ) + safmin = stdlib_${c2ri(ci)}$lamch( 'SAFE MINIMUM' ) safe1 = nz*safmin safe2 = safe1 / eps ! do for each right hand side @@ -61259,8 +61261,8 @@ module stdlib_linalg_lapack_w 20 continue ! loop until stopping criterion is satisfied. ! compute residual r = b - a * x - call stdlib_wcopy( n, b( 1, j ), 1, work, 1 ) - call stdlib_wspmv( uplo, n, -cone, ap, x( 1, j ), 1, cone, work, 1 ) + call stdlib_${ci}$copy( n, b( 1, j ), 1, work, 1 ) + call stdlib_${ci}$spmv( uplo, n, -cone, ap, x( 1, j ), 1, cone, work, 1 ) ! 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 @@ -61316,8 +61318,8 @@ module stdlib_linalg_lapack_w ! 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_wsptrs( uplo, n, 1, afp, ipiv, work, n, info ) - call stdlib_waxpy( n, cone, work, 1, x( 1, j ), 1 ) + call stdlib_${ci}$sptrs( uplo, n, 1, afp, ipiv, work, n, info ) + call stdlib_${ci}$axpy( n, cone, work, 1, x( 1, j ), 1 ) lstres = berr( j ) count = count + 1 go to 20 @@ -61336,7 +61338,7 @@ module stdlib_linalg_lapack_w ! 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_wlacn2 to estimate the infinity-norm of the matrix + ! 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 @@ -61348,11 +61350,11 @@ module stdlib_linalg_lapack_w end do kase = 0 100 continue - call stdlib_wlacn2( n, work( n+1 ), work, ferr( j ), kase, isave ) + call stdlib_${ci}$lacn2( n, work( n+1 ), work, ferr( j ), kase, isave ) if( kase/=0 ) then if( kase==1 ) then ! multiply by diag(w)*inv(a**t). - call stdlib_wsptrs( uplo, n, 1, afp, ipiv, work, n, info ) + call stdlib_${ci}$sptrs( uplo, n, 1, afp, ipiv, work, n, info ) do i = 1, n work( i ) = rwork( i )*work( i ) end do @@ -61361,7 +61363,7 @@ module stdlib_linalg_lapack_w do i = 1, n work( i ) = rwork( i )*work( i ) end do - call stdlib_wsptrs( uplo, n, 1, afp, ipiv, work, n, info ) + call stdlib_${ci}$sptrs( uplo, n, 1, afp, ipiv, work, n, info ) end if go to 100 end if @@ -61373,10 +61375,10 @@ module stdlib_linalg_lapack_w if( lstres/=zero )ferr( j ) = ferr( j ) / lstres end do loop_140 return - end subroutine stdlib_wsprfs + end subroutine stdlib_${ci}$sprfs - pure subroutine stdlib_wspsv( uplo, n, nrhs, ap, ipiv, b, ldb, info ) + pure subroutine stdlib_${ci}$spsv( uplo, n, nrhs, ap, ipiv, b, ldb, info ) !! ZSPSV: computes the solution to a complex system of linear equations !! A * X = B, !! where A is an N-by-N symmetric matrix stored in packed format and X @@ -61397,7 +61399,7 @@ module stdlib_linalg_lapack_w integer(ilp), intent(in) :: ldb, n, nrhs ! Array Arguments integer(ilp), intent(out) :: ipiv(*) - complex(qp), intent(inout) :: ap(*), b(ldb,*) + complex(${ck}$), intent(inout) :: ap(*), b(ldb,*) ! ===================================================================== ! Intrinsic Functions intrinsic :: max @@ -61418,16 +61420,16 @@ module stdlib_linalg_lapack_w return end if ! compute the factorization a = u*d*u**t or a = l*d*l**t. - call stdlib_wsptrf( uplo, n, ap, ipiv, info ) + call stdlib_${ci}$sptrf( uplo, n, ap, ipiv, info ) if( info==0 ) then ! solve the system a*x = b, overwriting b with x. - call stdlib_wsptrs( uplo, n, nrhs, ap, ipiv, b, ldb, info ) + call stdlib_${ci}$sptrs( uplo, n, nrhs, ap, ipiv, b, ldb, info ) end if return - end subroutine stdlib_wspsv + end subroutine stdlib_${ci}$spsv - subroutine stdlib_wspsvx( fact, uplo, n, nrhs, ap, afp, ipiv, b, ldb, x,ldx, rcond, ferr, & + subroutine stdlib_${ci}$spsvx( fact, uplo, n, nrhs, ap, afp, ipiv, b, ldb, x,ldx, rcond, ferr, & !! ZSPSVX: uses the diagonal pivoting factorization A = U*D*U**T or !! A = L*D*L**T to compute the solution to a complex system of linear !! equations A * X = B, where A is an N-by-N symmetric matrix stored @@ -61442,18 +61444,18 @@ module stdlib_linalg_lapack_w character, intent(in) :: fact, uplo integer(ilp), intent(out) :: info integer(ilp), intent(in) :: ldb, ldx, n, nrhs - real(qp), intent(out) :: rcond + real(${ck}$), intent(out) :: rcond ! Array Arguments integer(ilp), intent(inout) :: ipiv(*) - real(qp), intent(out) :: berr(*), ferr(*), rwork(*) - complex(qp), intent(inout) :: afp(*) - complex(qp), intent(in) :: ap(*), b(ldb,*) - complex(qp), intent(out) :: work(*), x(ldx,*) + real(${ck}$), intent(out) :: berr(*), ferr(*), rwork(*) + complex(${ck}$), intent(inout) :: afp(*) + complex(${ck}$), intent(in) :: ap(*), b(ldb,*) + complex(${ck}$), intent(out) :: work(*), x(ldx,*) ! ===================================================================== ! Local Scalars logical(lk) :: nofact - real(qp) :: anorm + real(${ck}$) :: anorm ! Intrinsic Functions intrinsic :: max ! Executable Statements @@ -61480,8 +61482,8 @@ module stdlib_linalg_lapack_w end if if( nofact ) then ! compute the factorization a = u*d*u**t or a = l*d*l**t. - call stdlib_wcopy( n*( n+1 ) / 2, ap, 1, afp, 1 ) - call stdlib_wsptrf( uplo, n, afp, ipiv, info ) + call stdlib_${ci}$copy( n*( n+1 ) / 2, ap, 1, afp, 1 ) + call stdlib_${ci}$sptrf( uplo, n, afp, ipiv, info ) ! return if info is non-zero. if( info>0 )then rcond = zero @@ -61489,23 +61491,23 @@ module stdlib_linalg_lapack_w end if end if ! compute the norm of the matrix a. - anorm = stdlib_wlansp( 'I', uplo, n, ap, rwork ) + anorm = stdlib_${ci}$lansp( 'I', uplo, n, ap, rwork ) ! compute the reciprocal of the condition number of a. - call stdlib_wspcon( uplo, n, afp, ipiv, anorm, rcond, work, info ) + call stdlib_${ci}$spcon( uplo, n, afp, ipiv, anorm, rcond, work, info ) ! compute the solution vectors x. - call stdlib_wlacpy( 'FULL', n, nrhs, b, ldb, x, ldx ) - call stdlib_wsptrs( uplo, n, nrhs, afp, ipiv, x, ldx, info ) + call stdlib_${ci}$lacpy( 'FULL', n, nrhs, b, ldb, x, ldx ) + call stdlib_${ci}$sptrs( uplo, n, nrhs, afp, ipiv, x, ldx, info ) ! use iterative refinement to improve the computed solutions and ! compute error bounds and backward error estimates for them. - call stdlib_wsprfs( uplo, n, nrhs, ap, afp, ipiv, b, ldb, x, ldx, ferr,berr, work, & + call stdlib_${ci}$sprfs( uplo, n, nrhs, ap, afp, ipiv, b, ldb, x, ldx, ferr,berr, work, & rwork, info ) ! set info = n+1 if the matrix is singular to working precision. - if( rcond1 ) then - imax = stdlib_iwamax( k-1, ap( kc ), 1 ) + imax = stdlib_i${ci}$amax( k-1, ap( kc ), 1 ) colmax = cabs1( ap( kc+imax-1 ) ) else colmax = zero @@ -61598,7 +61600,7 @@ module stdlib_linalg_lapack_w end do kpc = ( imax-1 )*imax / 2 + 1 if( imax>1 ) then - jmax = stdlib_iwamax( imax-1, ap( kpc ), 1 ) + jmax = stdlib_i${ci}$amax( imax-1, ap( kpc ), 1 ) rowmax = max( rowmax, cabs1( ap( kpc+jmax-1 ) ) ) end if if( absakk>=alpha*colmax*( colmax / rowmax ) ) then @@ -61620,7 +61622,7 @@ module stdlib_linalg_lapack_w if( kp/=kk ) then ! interchange rows and columns kk and kp in the leading ! submatrix a(1:k,1:k) - call stdlib_wswap( kp-1, ap( knc ), 1, ap( kpc ), 1 ) + call stdlib_${ci}$swap( kp-1, ap( knc ), 1, ap( kpc ), 1 ) kx = kpc + kp - 1 do j = kp + 1, kk - 1 kx = kx + j - 1 @@ -61645,9 +61647,9 @@ module stdlib_linalg_lapack_w ! 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 r1 = cone / ap( kc+k-1 ) - call stdlib_wspr( uplo, k-1, -r1, ap( kc ), 1, ap ) + call stdlib_${ci}$spr( uplo, k-1, -r1, ap( kc ), 1, ap ) ! store u(k) in column k - call stdlib_wscal( k-1, r1, ap( kc ), 1 ) + call stdlib_${ci}$scal( k-1, r1, ap( kc ), 1 ) 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) @@ -61706,7 +61708,7 @@ module stdlib_linalg_lapack_w ! imax is the row-index of the largest off-diagonal element in ! column k, and colmax is its absolute value if( k=alpha*colmax*( colmax / rowmax ) ) then @@ -61755,7 +61757,7 @@ module stdlib_linalg_lapack_w if( kp/=kk ) then ! interchange rows and columns kk and kp in the trailing ! submatrix a(k:n,k:n) - if( kp1 ) then - call stdlib_wcopy( k-1, ap( kc ), 1, work, 1 ) - call stdlib_wspmv( uplo, k-1, -cone, ap, work, 1, czero, ap( kc ),1 ) - ap( kc+k-1 ) = ap( kc+k-1 ) -stdlib_wdotu( k-1, work, 1, ap( kc ), 1 ) + call stdlib_${ci}$copy( k-1, ap( kc ), 1, work, 1 ) + call stdlib_${ci}$spmv( uplo, k-1, -cone, ap, work, 1, czero, ap( kc ),1 ) + ap( kc+k-1 ) = ap( kc+k-1 ) -stdlib_${ci}$dotu( k-1, work, 1, ap( kc ), 1 ) end if kstep = 1 else @@ -61923,15 +61925,15 @@ module stdlib_linalg_lapack_w ap( kcnext+k-1 ) = -akkp1 / d ! compute columns k and k+1 of the inverse. if( k>1 ) then - call stdlib_wcopy( k-1, ap( kc ), 1, work, 1 ) - call stdlib_wspmv( uplo, k-1, -cone, ap, work, 1, czero, ap( kc ),1 ) - ap( kc+k-1 ) = ap( kc+k-1 ) -stdlib_wdotu( k-1, work, 1, ap( kc ), 1 ) - ap( kcnext+k-1 ) = ap( kcnext+k-1 ) -stdlib_wdotu( k-1, ap( kc ), 1, ap( & + call stdlib_${ci}$copy( k-1, ap( kc ), 1, work, 1 ) + call stdlib_${ci}$spmv( uplo, k-1, -cone, ap, work, 1, czero, ap( kc ),1 ) + ap( kc+k-1 ) = ap( kc+k-1 ) -stdlib_${ci}$dotu( k-1, work, 1, ap( kc ), 1 ) + ap( kcnext+k-1 ) = ap( kcnext+k-1 ) -stdlib_${ci}$dotu( k-1, ap( kc ), 1, ap( & kcnext ),1 ) - call stdlib_wcopy( k-1, ap( kcnext ), 1, work, 1 ) - call stdlib_wspmv( uplo, k-1, -cone, ap, work, 1, czero,ap( kcnext ), 1 ) + call stdlib_${ci}$copy( k-1, ap( kcnext ), 1, work, 1 ) + call stdlib_${ci}$spmv( uplo, k-1, -cone, ap, work, 1, czero,ap( kcnext ), 1 ) - ap( kcnext+k ) = ap( kcnext+k ) -stdlib_wdotu( k-1, work, 1, ap( kcnext ), 1 ) + ap( kcnext+k ) = ap( kcnext+k ) -stdlib_${ci}$dotu( k-1, work, 1, ap( kcnext ), 1 ) end if kstep = 2 @@ -61942,7 +61944,7 @@ module stdlib_linalg_lapack_w ! interchange rows and columns k and kp in the leading ! submatrix a(1:k+1,1:k+1) kpc = ( kp-1 )*kp / 2 + 1 - call stdlib_wswap( kp-1, ap( kc ), 1, ap( kpc ), 1 ) + call stdlib_${ci}$swap( kp-1, ap( kc ), 1, ap( kpc ), 1 ) kx = kpc + kp - 1 do j = kp + 1, k - 1 kx = kx + j - 1 @@ -61980,10 +61982,10 @@ module stdlib_linalg_lapack_w ap( kc ) = cone / ap( kc ) ! compute column k of the inverse. if( ksmlsiz ) then ! scale. - orgnrm = stdlib_qlanst( 'M', m, d( start ), e( start ) ) - call stdlib_qlascl( 'G', 0, 0, orgnrm, one, m, 1, d( start ), m,info ) - call stdlib_qlascl( 'G', 0, 0, orgnrm, one, m-1, 1, e( start ),m-1, info ) + orgnrm = stdlib_${c2ri(ci)}$lanst( 'M', m, d( start ), e( start ) ) + call stdlib_${c2ri(ci)}$lascl( 'G', 0, 0, orgnrm, one, m, 1, d( start ), m,info ) + call stdlib_${c2ri(ci)}$lascl( 'G', 0, 0, orgnrm, one, m-1, 1, e( start ),m-1, info ) - call stdlib_wlaed0( n, m, d( start ), e( start ), z( 1, start ),ldz, work, n, & + call stdlib_${ci}$laed0( n, m, d( start ), e( start ), z( 1, start ),ldz, work, n, & rwork, iwork, info ) if( info>0 ) then info = ( info / ( m+1 )+start-1 )*( n+1 ) +mod( info, ( m+1 ) ) + start - & @@ -62437,13 +62439,13 @@ module stdlib_linalg_lapack_w go to 70 end if ! scale back. - call stdlib_qlascl( 'G', 0, 0, one, orgnrm, m, 1, d( start ), m,info ) + call stdlib_${c2ri(ci)}$lascl( 'G', 0, 0, one, orgnrm, m, 1, d( start ), m,info ) else - call stdlib_qsteqr( 'I', m, d( start ), e( start ), rwork, m,rwork( m*m+1 ), & + call stdlib_${c2ri(ci)}$steqr( 'I', m, d( start ), e( start ), rwork, m,rwork( m*m+1 ), & info ) - call stdlib_wlacrm( n, m, z( 1, start ), ldz, rwork, m, work, n,rwork( m*m+1 )& + call stdlib_${ci}$lacrm( n, m, z( 1, start ), ldz, rwork, m, work, n,rwork( m*m+1 )& ) - call stdlib_wlacpy( 'A', n, m, work, n, z( 1, start ), ldz ) + call stdlib_${ci}$lacpy( 'A', n, m, work, n, z( 1, start ), ldz ) if( info>0 ) then info = start*( n+1 ) + finish go to 70 @@ -62467,7 +62469,7 @@ module stdlib_linalg_lapack_w if( k/=i ) then d( k ) = d( i ) d( i ) = p - call stdlib_wswap( n, z( 1, i ), 1, z( 1, k ), 1 ) + call stdlib_${ci}$swap( n, z( 1, i ), 1, z( 1, k ), 1 ) end if end do end if @@ -62476,10 +62478,10 @@ module stdlib_linalg_lapack_w rwork( 1 ) = lrwmin iwork( 1 ) = liwmin return - end subroutine stdlib_wstedc + end subroutine stdlib_${ci}$stedc - pure subroutine stdlib_wstegr( jobz, range, n, d, e, vl, vu, il, iu,abstol, m, w, z, ldz, & + pure subroutine stdlib_${ci}$stegr( jobz, range, n, d, e, vl, vu, il, iu,abstol, m, w, z, ldz, & !! ZSTEGR: computes selected eigenvalues and, optionally, eigenvectors !! of a real symmetric tridiagonal matrix T. Any such unreduced matrix has !! a well defined set of pairwise different real eigenvalues, the corresponding @@ -62504,24 +62506,24 @@ module stdlib_linalg_lapack_w character, intent(in) :: jobz, range integer(ilp), intent(in) :: il, iu, ldz, liwork, lwork, n integer(ilp), intent(out) :: info, m - real(qp), intent(in) :: abstol, vl, vu + real(${ck}$), intent(in) :: abstol, vl, vu ! Array Arguments integer(ilp), intent(out) :: isuppz(*), iwork(*) - real(qp), intent(inout) :: d(*), e(*) - real(qp), intent(out) :: w(*), work(*) - complex(qp), intent(out) :: z(ldz,*) + real(${ck}$), intent(inout) :: d(*), e(*) + real(${ck}$), intent(out) :: w(*), work(*) + complex(${ck}$), intent(out) :: z(ldz,*) ! ===================================================================== ! Local Scalars logical(lk) :: tryrac ! Executable Statements info = 0 tryrac = .false. - call stdlib_wstemr( jobz, range, n, d, e, vl, vu, il, iu,m, w, z, ldz, n, isuppz, & + call stdlib_${ci}$stemr( jobz, range, n, d, e, vl, vu, il, iu,m, w, z, ldz, n, isuppz, & tryrac, work, lwork,iwork, liwork, info ) - end subroutine stdlib_wstegr + end subroutine stdlib_${ci}$stegr - pure subroutine stdlib_wstein( n, d, e, m, w, iblock, isplit, z, ldz, work,iwork, ifail, & + pure subroutine stdlib_${ci}$stein( n, d, e, m, w, iblock, isplit, z, ldz, work,iwork, ifail, & !! ZSTEIN: computes the eigenvectors of a real symmetric tridiagonal !! matrix T corresponding to specified eigenvalues, using inverse !! iteration. @@ -62541,13 +62543,13 @@ module stdlib_linalg_lapack_w ! Array Arguments integer(ilp), intent(in) :: iblock(*), isplit(*) integer(ilp), intent(out) :: ifail(*), iwork(*) - real(qp), intent(in) :: d(*), e(*), w(*) - real(qp), intent(out) :: work(*) - complex(qp), intent(out) :: z(ldz,*) + real(${ck}$), intent(in) :: d(*), e(*), w(*) + real(${ck}$), intent(out) :: work(*) + complex(${ck}$), intent(out) :: z(ldz,*) ! ===================================================================== ! Parameters - real(qp), parameter :: odm3 = 1.0e-3_qp - real(qp), parameter :: odm1 = 1.0e-1_qp + real(${ck}$), parameter :: odm3 = 1.0e-3_${ck}$ + real(${ck}$), parameter :: odm1 = 1.0e-1_${ck}$ integer(ilp), parameter :: maxits = 5 integer(ilp), parameter :: extra = 2 @@ -62556,7 +62558,7 @@ module stdlib_linalg_lapack_w ! Local Scalars integer(ilp) :: b1, blksiz, bn, gpind, i, iinfo, indrv1, indrv2, indrv3, indrv4, & indrv5, its, j, j1, jblk, jmax, jr, nblk, nrmchk - real(qp) :: dtpcrt, eps, eps1, nrm, onenrm, ortol, pertol, scl, sep, tol, xj, xjm, & + real(${ck}$) :: dtpcrt, eps, eps1, nrm, onenrm, ortol, pertol, scl, sep, tol, xj, xjm, & ztr ! Local Arrays integer(ilp) :: iseed(4) @@ -62599,8 +62601,8 @@ module stdlib_linalg_lapack_w return end if ! get machine constants. - eps = stdlib_qlamch( 'PRECISION' ) - ! initialize seed for random number generator stdlib_qlarnv. + eps = stdlib_${c2ri(ci)}$lamch( 'PRECISION' ) + ! initialize seed for random number generator stdlib_${c2ri(ci)}$larnv. do i = 1, 4 iseed( i ) = 1 end do @@ -62657,26 +62659,26 @@ module stdlib_linalg_lapack_w its = 0 nrmchk = 0 ! get random starting vector. - call stdlib_qlarnv( 2, iseed, blksiz, work( indrv1+1 ) ) + call stdlib_${c2ri(ci)}$larnv( 2, iseed, blksiz, work( indrv1+1 ) ) ! copy the matrix t so it won't be destroyed in factorization. - call stdlib_qcopy( blksiz, d( b1 ), 1, work( indrv4+1 ), 1 ) - call stdlib_qcopy( blksiz-1, e( b1 ), 1, work( indrv2+2 ), 1 ) - call stdlib_qcopy( blksiz-1, e( b1 ), 1, work( indrv3+1 ), 1 ) + call stdlib_${c2ri(ci)}$copy( blksiz, d( b1 ), 1, work( indrv4+1 ), 1 ) + call stdlib_${c2ri(ci)}$copy( blksiz-1, e( b1 ), 1, work( indrv2+2 ), 1 ) + call stdlib_${c2ri(ci)}$copy( blksiz-1, e( b1 ), 1, work( indrv3+1 ), 1 ) ! compute lu factors with partial pivoting ( pt = lu ) tol = zero - call stdlib_qlagtf( blksiz, work( indrv4+1 ), xj, work( indrv2+2 ),work( indrv3+& + call stdlib_${c2ri(ci)}$lagtf( blksiz, work( indrv4+1 ), xj, work( indrv2+2 ),work( indrv3+& 1 ), tol, work( indrv5+1 ), iwork,iinfo ) ! update iteration count. 70 continue its = its + 1 if( its>maxits )go to 120 ! normalize and scale the righthand side vector pb. - jmax = stdlib_iqamax( blksiz, work( indrv1+1 ), 1 ) + jmax = stdlib_i${c2ri(ci)}$amax( blksiz, work( indrv1+1 ), 1 ) scl = blksiz*onenrm*max( eps,abs( work( indrv4+blksiz ) ) ) /abs( work( indrv1+& jmax ) ) - call stdlib_qscal( blksiz, scl, work( indrv1+1 ), 1 ) + call stdlib_${c2ri(ci)}$scal( blksiz, scl, work( indrv1+1 ), 1 ) ! solve the system lu = pb. - call stdlib_qlagts( -1, blksiz, work( indrv4+1 ), work( indrv2+2 ),work( indrv3+& + call stdlib_${c2ri(ci)}$lagts( -1, blksiz, work( indrv4+1 ), work( indrv2+2 ),work( indrv3+& 1 ), work( indrv5+1 ), iwork,work( indrv1+1 ), tol, iinfo ) ! reorthogonalize by modified gram-schmidt if eigenvalues are ! close enough. @@ -62686,17 +62688,17 @@ module stdlib_linalg_lapack_w do i = gpind, j - 1 ztr = zero do jr = 1, blksiz - ztr = ztr + work( indrv1+jr )*real( z( b1-1+jr, i ),KIND=qp) + ztr = ztr + work( indrv1+jr )*real( z( b1-1+jr, i ),KIND=${ck}$) end do do jr = 1, blksiz work( indrv1+jr ) = work( indrv1+jr ) -ztr*real( z( b1-1+jr, i ),& - KIND=qp) + KIND=${ck}$) end do end do end if ! check the infinity norm of the iterate. 110 continue - jmax = stdlib_iqamax( blksiz, work( indrv1+1 ), 1 ) + jmax = stdlib_i${c2ri(ci)}$amax( blksiz, work( indrv1+1 ), 1 ) nrm = abs( work( indrv1+jmax ) ) ! continue for additional iterations after norm reaches ! stopping criterion. @@ -62711,16 +62713,16 @@ module stdlib_linalg_lapack_w ifail( info ) = j ! accept iterate as jth eigenvector. 130 continue - scl = one / stdlib_qnrm2( blksiz, work( indrv1+1 ), 1 ) - jmax = stdlib_iqamax( blksiz, work( indrv1+1 ), 1 ) + scl = one / stdlib_${c2ri(ci)}$nrm2( blksiz, work( indrv1+1 ), 1 ) + jmax = stdlib_i${c2ri(ci)}$amax( blksiz, work( indrv1+1 ), 1 ) if( work( indrv1+jmax )wl).and.(r2<=wu)).or.(indeig.and.(iil==1)) ) & then @@ -62991,19 +62993,19 @@ module stdlib_linalg_lapack_w iindwk = 3*n + 1 ! scale matrix to allowable range, if necessary. ! the allowable range is related to the pivmin parameter; see the - ! comments in stdlib_qlarrd. the preference for scaling small values + ! comments in stdlib_${c2ri(ci)}$larrd. the preference for scaling small values ! up is heuristic; we expect users' matrices not to be close to the ! rmax threshold. scale = one - tnrm = stdlib_qlanst( 'M', n, d, e ) + tnrm = stdlib_${c2ri(ci)}$lanst( 'M', n, d, e ) if( tnrm>zero .and. tnrmrmax ) then scale = rmax / tnrm end if if( scale/=one ) then - call stdlib_qscal( n, scale, d, 1 ) - call stdlib_qscal( n-1, scale, e, 1 ) + call stdlib_${c2ri(ci)}$scal( n, scale, d, 1 ) + call stdlib_${c2ri(ci)}$scal( n-1, scale, e, 1 ) tnrm = tnrm*scale if( valeig ) then ! if eigenvalues in interval have to be found, @@ -63015,13 +63017,13 @@ module stdlib_linalg_lapack_w ! compute the desired eigenvalues of the tridiagonal after splitting ! into smaller subblocks if the corresponding off-diagonal elements ! are small - ! thresh is the splitting parameter for stdlib_qlarre + ! thresh is the splitting parameter for stdlib_${c2ri(ci)}$larre ! a negative thresh forces the old splitting criterion based on the ! size of the off-diagonal. a positive thresh switches to splitting ! which preserves relative accuracy. if( tryrac ) then ! test whether the matrix warrants the more expensive relative approach. - call stdlib_qlarrr( n, d, e, iinfo ) + call stdlib_${c2ri(ci)}$larrr( n, d, e, iinfo ) else ! the user does not care about relative accurately eigenvalues iinfo = -1 @@ -63036,7 +63038,7 @@ module stdlib_linalg_lapack_w endif if( tryrac ) then ! copy original diagonal, needed to guarantee relative accuracy - call stdlib_qcopy(n,d,1,work(indd),1) + call stdlib_${c2ri(ci)}$copy(n,d,1,work(indd),1) endif ! store the squares of the offdiagonal values of t do j = 1, n-1 @@ -63044,18 +63046,18 @@ module stdlib_linalg_lapack_w end do ! set the tolerance parameters for bisection if( .not.wantz ) then - ! stdlib_qlarre computes the eigenvalues to full precision. + ! stdlib_${c2ri(ci)}$larre computes the eigenvalues to full precision. rtol1 = four * eps rtol2 = four * eps else - ! stdlib_qlarre computes the eigenvalues to less than full precision. - ! stdlib_wlarrv will refine the eigenvalue approximations, and we only - ! need less accurate initial bisection in stdlib_qlarre. - ! note: these settings do only affect the subset case and stdlib_qlarre + ! stdlib_${c2ri(ci)}$larre computes the eigenvalues to less than full precision. + ! stdlib_${ci}$larrv will refine the eigenvalue approximations, and we only + ! need less accurate initial bisection in stdlib_${c2ri(ci)}$larre. + ! note: these settings do only affect the subset case and stdlib_${c2ri(ci)}$larre rtol1 = sqrt(eps) - rtol2 = max( sqrt(eps)*5.0e-3_qp, four * eps ) + rtol2 = max( sqrt(eps)*5.0e-3_${ck}$, four * eps ) endif - call stdlib_qlarre( range, n, wl, wu, iil, iiu, d, e,work(inde2), rtol1, rtol2, & + call stdlib_${c2ri(ci)}$larre( range, n, wl, wu, iil, iiu, d, e,work(inde2), rtol1, rtol2, & thresh, nsplit,iwork( iinspl ), m, w, work( inderr ),work( indgp ), iwork( iindbl ),& iwork( iindw ), work( indgrs ), pivmin,work( indwrk ), iwork( iindwk ), iinfo ) @@ -63063,13 +63065,13 @@ module stdlib_linalg_lapack_w info = 10 + abs( iinfo ) return end if - ! note that if range /= 'v', stdlib_qlarre computes bounds on the desired + ! note that if range /= 'v', stdlib_${c2ri(ci)}$larre computes bounds on the desired ! part of the spectrum. all desired eigenvalues are contained in ! (wl,wu] if( wantz ) then ! compute the desired eigenvectors corresponding to the computed ! eigenvalues - call stdlib_wlarrv( n, wl, wu, d, e,pivmin, iwork( iinspl ), m,1, m, minrgp, & + call stdlib_${ci}$larrv( n, wl, wu, d, e,pivmin, iwork( iinspl ), m,1, m, minrgp, & rtol1, rtol2,w, work( inderr ), work( indgp ), iwork( iindbl ),iwork( iindw ), & work( indgrs ), z, ldz,isuppz, work( indwrk ), iwork( iindwk ), iinfo ) if( iinfo/=0 ) then @@ -63077,10 +63079,10 @@ module stdlib_linalg_lapack_w return end if else - ! stdlib_qlarre computes eigenvalues of the (shifted) root representation - ! stdlib_wlarrv returns the eigenvalues of the unshifted matrix. + ! stdlib_${c2ri(ci)}$larre computes eigenvalues of the (shifted) root representation + ! stdlib_${ci}$larrv returns the eigenvalues of the unshifted matrix. ! however, if the eigenvectors are not desired by the user, we need - ! to apply the corresponding shifts from stdlib_qlarre to obtain the + ! to apply the corresponding shifts from stdlib_${c2ri(ci)}$larre to obtain the ! eigenvalues of the original matrix. do j = 1, m itmp = iwork( iindbl+j-1 ) @@ -63112,7 +63114,7 @@ module stdlib_linalg_lapack_w ifirst = iwork(iindw+wbegin-1) ilast = iwork(iindw+wend-1) rtol2 = four * eps - call stdlib_qlarrj( in,work(indd+ibegin-1), work(inde2+ibegin-1),ifirst, & + call stdlib_${c2ri(ci)}$larrj( in,work(indd+ibegin-1), work(inde2+ibegin-1),ifirst, & ilast, rtol2, offset, w(wbegin),work( inderr+wbegin-1 ),work( indwrk ), iwork(& iindwk ), pivmin,tnrm, iinfo ) ibegin = iend + 1 @@ -63121,14 +63123,14 @@ module stdlib_linalg_lapack_w endif ! if matrix was scaled, then rescale eigenvalues appropriately. if( scale/=one ) then - call stdlib_qscal( m, one / scale, w, 1 ) + call stdlib_${c2ri(ci)}$scal( m, one / scale, w, 1 ) end if end if ! if eigenvalues are not in increasing order, then sort them, ! possibly along with eigenvectors. if( nsplit>1 .or. n==2 ) then if( .not. wantz ) then - call stdlib_qlasrt( 'I', m, w, iinfo ) + call stdlib_${c2ri(ci)}$lasrt( 'I', m, w, iinfo ) if( iinfo/=0 ) then info = 3 return @@ -63147,7 +63149,7 @@ module stdlib_linalg_lapack_w w( i ) = w( j ) w( j ) = tmp if( wantz ) then - call stdlib_wswap( n, z( 1, i ), 1, z( 1, j ), 1 ) + call stdlib_${ci}$swap( n, z( 1, i ), 1, z( 1, j ), 1 ) itmp = isuppz( 2*i-1 ) isuppz( 2*i-1 ) = isuppz( 2*j-1 ) isuppz( 2*j-1 ) = itmp @@ -63162,10 +63164,10 @@ module stdlib_linalg_lapack_w work( 1 ) = lwmin iwork( 1 ) = liwmin return - end subroutine stdlib_wstemr + end subroutine stdlib_${ci}$stemr - pure subroutine stdlib_wsteqr( compz, n, d, e, z, ldz, work, info ) + pure subroutine stdlib_${ci}$steqr( compz, n, d, e, z, ldz, work, info ) !! ZSTEQR: computes all eigenvalues and, optionally, eigenvectors of a !! symmetric tridiagonal matrix using the implicit QL or QR method. !! The eigenvectors of a full or band complex Hermitian matrix can also @@ -63179,9 +63181,9 @@ module stdlib_linalg_lapack_w integer(ilp), intent(out) :: info integer(ilp), intent(in) :: ldz, n ! Array Arguments - real(qp), intent(inout) :: d(*), e(*) - real(qp), intent(out) :: work(*) - complex(qp), intent(inout) :: z(ldz,*) + real(${ck}$), intent(inout) :: d(*), e(*) + real(${ck}$), intent(out) :: work(*) + complex(${ck}$), intent(inout) :: z(ldz,*) ! ===================================================================== ! Parameters integer(ilp), parameter :: maxit = 30 @@ -63191,7 +63193,7 @@ module stdlib_linalg_lapack_w ! Local Scalars integer(ilp) :: i, icompz, ii, iscale, j, jtot, k, l, l1, lend, lendm1, lendp1, lendsv,& lm1, lsv, m, mm, mm1, nm1, nmaxit - real(qp) :: anorm, b, c, eps, eps2, f, g, p, r, rt1, rt2, s, safmax, safmin, ssfmax, & + real(${ck}$) :: anorm, b, c, eps, eps2, f, g, p, r, rt1, rt2, s, safmax, safmin, ssfmax, & ssfmin, tst ! Intrinsic Functions intrinsic :: abs,max,sign,sqrt @@ -63225,15 +63227,15 @@ module stdlib_linalg_lapack_w return end if ! determine the unit roundoff and over/underflow thresholds. - eps = stdlib_qlamch( 'E' ) + eps = stdlib_${c2ri(ci)}$lamch( 'E' ) eps2 = eps**2 - safmin = stdlib_qlamch( 'S' ) + safmin = stdlib_${c2ri(ci)}$lamch( 'S' ) safmax = one / safmin ssfmax = sqrt( safmax ) / three ssfmin = sqrt( safmin ) / eps2 ! compute the eigenvalues and eigenvectors of the tridiagonal ! matrix. - if( icompz==2 )call stdlib_wlaset( 'FULL', n, n, czero, cone, z, ldz ) + if( icompz==2 )call stdlib_${ci}$laset( 'FULL', n, n, czero, cone, z, ldz ) nmaxit = n*maxit jtot = 0 ! determine where the matrix splits and choose ql or qr iteration @@ -63263,17 +63265,17 @@ module stdlib_linalg_lapack_w l1 = m + 1 if( lend==l )go to 10 ! scale submatrix in rows and columns l to lend - anorm = stdlib_qlanst( 'I', lend-l+1, d( l ), e( l ) ) + anorm = stdlib_${c2ri(ci)}$lanst( 'I', lend-l+1, d( l ), e( l ) ) iscale = 0 if( anorm==zero )go to 10 if( anorm>ssfmax ) then iscale = 1 - call stdlib_qlascl( 'G', 0, 0, anorm, ssfmax, lend-l+1, 1, d( l ), n,info ) - call stdlib_qlascl( 'G', 0, 0, anorm, ssfmax, lend-l, 1, e( l ), n,info ) + call stdlib_${c2ri(ci)}$lascl( 'G', 0, 0, anorm, ssfmax, lend-l+1, 1, d( l ), n,info ) + call stdlib_${c2ri(ci)}$lascl( 'G', 0, 0, anorm, ssfmax, lend-l, 1, e( l ), n,info ) else if( anorm0 ) then - call stdlib_qlaev2( d( l ), e( l ), d( l+1 ), rt1, rt2, c, s ) + call stdlib_${c2ri(ci)}$laev2( d( l ), e( l ), d( l+1 ), rt1, rt2, c, s ) work( l ) = c work( n-1+l ) = s - call stdlib_wlasr( 'R', 'V', 'B', n, 2, work( l ),work( n-1+l ), z( 1, l ), & + call stdlib_${ci}$lasr( 'R', 'V', 'B', n, 2, work( l ),work( n-1+l ), z( 1, l ), & ldz ) else - call stdlib_qlae2( d( l ), e( l ), d( l+1 ), rt1, rt2 ) + call stdlib_${c2ri(ci)}$lae2( d( l ), e( l ), d( l+1 ), rt1, rt2 ) end if d( l ) = rt1 d( l+1 ) = rt2 @@ -63319,7 +63321,7 @@ module stdlib_linalg_lapack_w jtot = jtot + 1 ! form shift. g = ( d( l+1 )-p ) / ( two*e( l ) ) - r = stdlib_qlapy2( g, one ) + r = stdlib_${c2ri(ci)}$lapy2( g, one ) g = d( m ) - p + ( e( l ) / ( g+sign( r, g ) ) ) s = one c = one @@ -63329,7 +63331,7 @@ module stdlib_linalg_lapack_w do i = mm1, l, -1 f = s*e( i ) b = c*e( i ) - call stdlib_qlartg( g, f, c, s, r ) + call stdlib_${c2ri(ci)}$lartg( g, f, c, s, r ) if( i/=m-1 )e( i+1 ) = r g = d( i+1 ) - p r = ( d( i )-g )*s + two*c*b @@ -63345,7 +63347,7 @@ module stdlib_linalg_lapack_w ! if eigenvectors are desired, then apply saved rotations. if( icompz>0 ) then mm = m - l + 1 - call stdlib_wlasr( 'R', 'V', 'B', n, mm, work( l ), work( n-1+l ),z( 1, l ), ldz & + call stdlib_${ci}$lasr( 'R', 'V', 'B', n, mm, work( l ), work( n-1+l ),z( 1, l ), ldz & ) end if d( l ) = d( l ) - p @@ -63373,17 +63375,17 @@ module stdlib_linalg_lapack_w if( m>lend )e( m-1 ) = zero p = d( l ) if( m==l )go to 130 - ! if remaining matrix is 2-by-2, use stdlib_qlae2 or stdlib_dlaev2 + ! if remaining matrix is 2-by-2, use stdlib_${c2ri(ci)}$lae2 or stdlib_dlaev2 ! to compute its eigensystem. if( m==l-1 ) then if( icompz>0 ) then - call stdlib_qlaev2( d( l-1 ), e( l-1 ), d( l ), rt1, rt2, c, s ) + call stdlib_${c2ri(ci)}$laev2( d( l-1 ), e( l-1 ), d( l ), rt1, rt2, c, s ) work( m ) = c work( n-1+m ) = s - call stdlib_wlasr( 'R', 'V', 'F', n, 2, work( m ),work( n-1+m ), z( 1, l-1 ), & + call stdlib_${ci}$lasr( 'R', 'V', 'F', n, 2, work( m ),work( n-1+m ), z( 1, l-1 ), & ldz ) else - call stdlib_qlae2( d( l-1 ), e( l-1 ), d( l ), rt1, rt2 ) + call stdlib_${c2ri(ci)}$lae2( d( l-1 ), e( l-1 ), d( l ), rt1, rt2 ) end if d( l-1 ) = rt1 d( l ) = rt2 @@ -63396,7 +63398,7 @@ module stdlib_linalg_lapack_w jtot = jtot + 1 ! form shift. g = ( d( l-1 )-p ) / ( two*e( l-1 ) ) - r = stdlib_qlapy2( g, one ) + r = stdlib_${c2ri(ci)}$lapy2( g, one ) g = d( m ) - p + ( e( l-1 ) / ( g+sign( r, g ) ) ) s = one c = one @@ -63406,7 +63408,7 @@ module stdlib_linalg_lapack_w do i = m, lm1 f = s*e( i ) b = c*e( i ) - call stdlib_qlartg( g, f, c, s, r ) + call stdlib_${c2ri(ci)}$lartg( g, f, c, s, r ) if( i/=m )e( i-1 ) = r g = d( i ) - p r = ( d( i+1 )-g )*s + two*c*b @@ -63422,7 +63424,7 @@ module stdlib_linalg_lapack_w ! if eigenvectors are desired, then apply saved rotations. if( icompz>0 ) then mm = l - m + 1 - call stdlib_wlasr( 'R', 'V', 'F', n, mm, work( m ), work( n-1+m ),z( 1, m ), ldz & + call stdlib_${ci}$lasr( 'R', 'V', 'F', n, mm, work( m ), work( n-1+m ),z( 1, m ), ldz & ) end if d( l ) = d( l ) - p @@ -63438,14 +63440,14 @@ module stdlib_linalg_lapack_w ! undo scaling if necessary 140 continue if( iscale==1 ) then - call stdlib_qlascl( 'G', 0, 0, ssfmax, anorm, lendsv-lsv+1, 1,d( lsv ), n, info ) + call stdlib_${c2ri(ci)}$lascl( 'G', 0, 0, ssfmax, anorm, lendsv-lsv+1, 1,d( lsv ), n, info ) - call stdlib_qlascl( 'G', 0, 0, ssfmax, anorm, lendsv-lsv, 1, e( lsv ),n, info ) + call stdlib_${c2ri(ci)}$lascl( 'G', 0, 0, ssfmax, anorm, lendsv-lsv, 1, e( lsv ),n, info ) else if( iscale==2 ) then - call stdlib_qlascl( 'G', 0, 0, ssfmin, anorm, lendsv-lsv+1, 1,d( lsv ), n, info ) + call stdlib_${c2ri(ci)}$lascl( 'G', 0, 0, ssfmin, anorm, lendsv-lsv+1, 1,d( lsv ), n, info ) - call stdlib_qlascl( 'G', 0, 0, ssfmin, anorm, lendsv-lsv, 1, e( lsv ),n, info ) + call stdlib_${c2ri(ci)}$lascl( 'G', 0, 0, ssfmin, anorm, lendsv-lsv, 1, e( lsv ),n, info ) end if ! check for no convergence to an eigenvalue after a total @@ -63461,7 +63463,7 @@ module stdlib_linalg_lapack_w 160 continue if( icompz==0 ) then ! use quick sort - call stdlib_qlasrt( 'I', n, d, info ) + call stdlib_${c2ri(ci)}$lasrt( 'I', n, d, info ) else ! use selection sort to minimize swaps of eigenvectors do ii = 2, n @@ -63477,15 +63479,15 @@ module stdlib_linalg_lapack_w if( k/=i ) then d( k ) = d( i ) d( i ) = p - call stdlib_wswap( n, z( 1, i ), 1, z( 1, k ), 1 ) + call stdlib_${ci}$swap( n, z( 1, i ), 1, z( 1, k ), 1 ) end if end do end if return - end subroutine stdlib_wsteqr + end subroutine stdlib_${ci}$steqr - pure subroutine stdlib_wsycon( uplo, n, a, lda, ipiv, anorm, rcond, work,info ) + pure subroutine stdlib_${ci}$sycon( uplo, n, a, lda, ipiv, anorm, rcond, work,info ) !! ZSYCON: 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. @@ -63498,18 +63500,18 @@ module stdlib_linalg_lapack_w character, intent(in) :: uplo integer(ilp), intent(out) :: info integer(ilp), intent(in) :: lda, n - real(qp), intent(in) :: anorm - real(qp), intent(out) :: rcond + real(${ck}$), intent(in) :: anorm + real(${ck}$), intent(out) :: rcond ! Array Arguments integer(ilp), intent(in) :: ipiv(*) - complex(qp), intent(in) :: a(lda,*) - complex(qp), intent(out) :: work(*) + complex(${ck}$), intent(in) :: a(lda,*) + complex(${ck}$), intent(out) :: work(*) ! ===================================================================== ! Local Scalars logical(lk) :: upper integer(ilp) :: i, kase - real(qp) :: ainvnm + real(${ck}$) :: ainvnm ! Local Arrays integer(ilp) :: isave(3) ! Intrinsic Functions @@ -63554,19 +63556,19 @@ module stdlib_linalg_lapack_w ! estimate the 1-norm of the inverse. kase = 0 30 continue - call stdlib_wlacn2( n, work( n+1 ), work, ainvnm, kase, isave ) + call stdlib_${ci}$lacn2( n, work( n+1 ), work, ainvnm, kase, isave ) if( kase/=0 ) then ! multiply by inv(l*d*l**t) or inv(u*d*u**t). - call stdlib_wsytrs( uplo, n, 1, a, lda, ipiv, work, n, info ) + call stdlib_${ci}$sytrs( uplo, n, 1, 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_wsycon + end subroutine stdlib_${ci}$sycon - pure subroutine stdlib_wsycon_rook( uplo, n, a, lda, ipiv, anorm, rcond, work,info ) + pure subroutine stdlib_${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. @@ -63579,19 +63581,19 @@ module stdlib_linalg_lapack_w character, intent(in) :: uplo integer(ilp), intent(out) :: info integer(ilp), intent(in) :: lda, n - real(qp), intent(in) :: anorm - real(qp), intent(out) :: rcond + real(${ck}$), intent(in) :: anorm + real(${ck}$), intent(out) :: rcond ! Array Arguments integer(ilp), intent(in) :: ipiv(*) - complex(qp), intent(in) :: a(lda,*) - complex(qp), intent(out) :: work(*) + complex(${ck}$), intent(in) :: a(lda,*) + complex(${ck}$), intent(out) :: work(*) ! ===================================================================== ! Local Scalars logical(lk) :: upper integer(ilp) :: i, kase - real(qp) :: ainvnm + real(${ck}$) :: ainvnm ! Local Arrays integer(ilp) :: isave(3) ! Intrinsic Functions @@ -63636,19 +63638,19 @@ module stdlib_linalg_lapack_w ! estimate the 1-norm of the inverse. kase = 0 30 continue - call stdlib_wlacn2( n, work( n+1 ), work, ainvnm, kase, isave ) + call stdlib_${ci}$lacn2( n, work( n+1 ), work, ainvnm, kase, isave ) if( kase/=0 ) then ! multiply by inv(l*d*l**t) or inv(u*d*u**t). - call stdlib_wsytrs_rook( uplo, n, 1, a, lda, ipiv, work, n, info ) + call stdlib_${ci}$sytrs_rook( uplo, n, 1, 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_wsycon_rook + end subroutine stdlib_${ci}$sycon_rook - pure subroutine stdlib_wsyconv( uplo, way, n, a, lda, ipiv, e, info ) + pure subroutine stdlib_${ci}$syconv( uplo, way, n, a, lda, ipiv, e, info ) !! ZSYCONV: converts A given by ZHETRF into L and D or vice-versa. !! Get nondiagonal elements of D (returned in workspace) and !! apply or reverse permutation done in TRF. @@ -63661,14 +63663,14 @@ module stdlib_linalg_lapack_w integer(ilp), intent(in) :: lda, n ! Array Arguments integer(ilp), intent(in) :: ipiv(*) - complex(qp), intent(inout) :: a(lda,*) - complex(qp), intent(out) :: e(*) + complex(${ck}$), intent(inout) :: a(lda,*) + complex(${ck}$), intent(out) :: e(*) ! ===================================================================== ! External Subroutines logical(lk) :: upper, convert integer(ilp) :: i, ip, j - complex(qp) :: temp + complex(${ck}$) :: temp ! Executable Statements info = 0 upper = stdlib_lsame( uplo, 'U' ) @@ -63850,10 +63852,10 @@ module stdlib_linalg_lapack_w end if end if return - end subroutine stdlib_wsyconv + end subroutine stdlib_${ci}$syconv - pure subroutine stdlib_wsyconvf( uplo, way, n, a, lda, e, ipiv, info ) + pure subroutine stdlib_${ci}$syconvf( uplo, way, n, a, lda, e, ipiv, info ) !! If parameter WAY = 'C': !! ZSYCONVF: converts the factorization output format used in !! ZSYTRF provided on entry in parameter A into the factorization @@ -63880,7 +63882,7 @@ module stdlib_linalg_lapack_w integer(ilp), intent(in) :: lda, n ! Array Arguments integer(ilp), intent(inout) :: ipiv(*) - complex(qp), intent(inout) :: a(lda,*), e(*) + complex(${ck}$), intent(inout) :: a(lda,*), e(*) ! ===================================================================== ! External Subroutines @@ -63936,7 +63938,7 @@ module stdlib_linalg_lapack_w ip = ipiv( i ) if( i1 ) then if( ip/=i ) then - call stdlib_wswap( i-1, a( i, 1 ), lda,a( ip, 1 ), lda ) + call stdlib_${ci}$swap( i-1, a( i, 1 ), lda,a( ip, 1 ), lda ) end if end if else @@ -64046,7 +64048,7 @@ module stdlib_linalg_lapack_w ip = -ipiv( i ) if ( i>1 ) then if( ip/=(i+1) ) then - call stdlib_wswap( i-1, a( i+1, 1 ), lda,a( ip, 1 ), lda ) + call stdlib_${ci}$swap( i-1, a( i+1, 1 ), lda,a( ip, 1 ), lda ) end if end if ! convert ipiv @@ -64071,7 +64073,7 @@ module stdlib_linalg_lapack_w ip = ipiv( i ) if ( i>1 ) then if( ip/=i ) then - call stdlib_wswap( i-1, a( ip, 1 ), lda,a( i, 1 ), lda ) + call stdlib_${ci}$swap( i-1, a( ip, 1 ), lda,a( i, 1 ), lda ) end if end if else @@ -64081,7 +64083,7 @@ module stdlib_linalg_lapack_w ip = -ipiv( i ) if ( i>1 ) then if( ip/=(i+1) ) then - call stdlib_wswap( i-1, a( ip, 1 ), lda,a( i+1, 1 ), lda ) + call stdlib_${ci}$swap( i-1, a( ip, 1 ), lda,a( i+1, 1 ), lda ) end if end if ! convert ipiv @@ -64107,10 +64109,10 @@ module stdlib_linalg_lapack_w ! end a is lower end if return - end subroutine stdlib_wsyconvf + end subroutine stdlib_${ci}$syconvf - pure subroutine stdlib_wsyconvf_rook( uplo, way, n, a, lda, e, ipiv, info ) + pure subroutine stdlib_${ci}$syconvf_rook( uplo, way, n, a, lda, e, ipiv, info ) !! If parameter WAY = 'C': !! ZSYCONVF_ROOK: converts the factorization output format used in !! ZSYTRF_ROOK provided on entry in parameter A into the factorization @@ -64135,7 +64137,7 @@ module stdlib_linalg_lapack_w integer(ilp), intent(in) :: lda, n ! Array Arguments integer(ilp), intent(in) :: ipiv(*) - complex(qp), intent(inout) :: a(lda,*), e(*) + complex(${ck}$), intent(inout) :: a(lda,*), e(*) ! ===================================================================== ! External Subroutines @@ -64191,7 +64193,7 @@ module stdlib_linalg_lapack_w ip = ipiv( i ) if( i1 ) then if( ip/=i ) then - call stdlib_wswap( i-1, a( i, 1 ), lda,a( ip, 1 ), lda ) + call stdlib_${ci}$swap( i-1, a( i, 1 ), lda,a( ip, 1 ), lda ) end if end if else @@ -64303,10 +64305,10 @@ module stdlib_linalg_lapack_w ip2 = -ipiv( i+1 ) if ( i>1 ) then if( ip/=i ) then - call stdlib_wswap( i-1, a( i, 1 ), lda,a( ip, 1 ), lda ) + call stdlib_${ci}$swap( i-1, a( i, 1 ), lda,a( ip, 1 ), lda ) end if if( ip2/=(i+1) ) then - call stdlib_wswap( i-1, a( i+1, 1 ), lda,a( ip2, 1 ), lda ) + call stdlib_${ci}$swap( i-1, a( i+1, 1 ), lda,a( ip2, 1 ), lda ) end if end if i = i + 1 @@ -64326,7 +64328,7 @@ module stdlib_linalg_lapack_w ip = ipiv( i ) if ( i>1 ) then if( ip/=i ) then - call stdlib_wswap( i-1, a( ip, 1 ), lda,a( i, 1 ), lda ) + call stdlib_${ci}$swap( i-1, a( ip, 1 ), lda,a( i, 1 ), lda ) end if end if else @@ -64338,10 +64340,10 @@ module stdlib_linalg_lapack_w ip2 = -ipiv( i+1 ) if ( i>1 ) then if( ip2/=(i+1) ) then - call stdlib_wswap( i-1, a( ip2, 1 ), lda,a( i+1, 1 ), lda ) + call stdlib_${ci}$swap( i-1, a( ip2, 1 ), lda,a( i+1, 1 ), lda ) end if if( ip/=i ) then - call stdlib_wswap( i-1, a( ip, 1 ), lda,a( i, 1 ), lda ) + call stdlib_${ci}$swap( i-1, a( ip, 1 ), lda,a( i, 1 ), lda ) end if end if end if @@ -64362,10 +64364,10 @@ module stdlib_linalg_lapack_w ! end a is lower end if return - end subroutine stdlib_wsyconvf_rook + end subroutine stdlib_${ci}$syconvf_rook - pure subroutine stdlib_wsyequb( uplo, n, a, lda, s, scond, amax, work, info ) + pure subroutine stdlib_${ci}$syequb( uplo, n, a, lda, s, scond, amax, work, info ) !! ZSYEQUB: computes row and column scalings intended to equilibrate a !! symmetric matrix A (with respect to the Euclidean norm) and reduce !! its condition number. The scale factors S are computed by the BIN @@ -64379,12 +64381,12 @@ module stdlib_linalg_lapack_w ! Scalar Arguments integer(ilp), intent(out) :: info integer(ilp), intent(in) :: lda, n - real(qp), intent(out) :: amax, scond + real(${ck}$), intent(out) :: amax, scond character, intent(in) :: uplo ! Array Arguments - complex(qp), intent(in) :: a(lda,*) - complex(qp), intent(out) :: work(*) - real(qp), intent(out) :: s(*) + complex(${ck}$), intent(in) :: a(lda,*) + complex(${ck}$), intent(out) :: work(*) + real(${ck}$), intent(out) :: s(*) ! ===================================================================== ! Parameters integer(ilp), parameter :: max_iter = 100 @@ -64392,16 +64394,16 @@ module stdlib_linalg_lapack_w ! Local Scalars integer(ilp) :: i, j, iter - real(qp) :: avg, std, tol, c0, c1, c2, t, u, si, d, base, smin, smax, smlnum, bignum, & + real(${ck}$) :: avg, std, tol, c0, c1, c2, t, u, si, d, base, smin, smax, smlnum, bignum, & scale, sumsq logical(lk) :: up - complex(qp) :: zdum + complex(${ck}$) :: zdum ! Intrinsic Functions intrinsic :: abs,real,aimag,int,log,max,min,sqrt ! Statement Functions - real(qp) :: cabs1 + real(${ck}$) :: cabs1 ! Statement Function Definitions - cabs1( zdum ) = abs( real( zdum,KIND=qp) ) + abs( aimag( zdum ) ) + cabs1( zdum ) = abs( real( zdum,KIND=${ck}$) ) + abs( aimag( zdum ) ) ! Executable Statements ! test the input parameters. info = 0 @@ -64449,9 +64451,9 @@ module stdlib_linalg_lapack_w end do end if do j = 1, n - s( j ) = 1.0_qp / s( j ) + s( j ) = 1.0_${ck}$ / s( j ) end do - tol = one / sqrt( 2.0_qp * n ) + tol = one / sqrt( 2.0_${ck}$ * n ) do iter = 1, max_iter scale = zero sumsq = zero @@ -64479,22 +64481,22 @@ module stdlib_linalg_lapack_w ! avg = s^t beta / n avg = zero do i = 1, n - avg = avg + s( i ) * real( work( i ),KIND=qp) + avg = avg + s( i ) * real( work( i ),KIND=${ck}$) end do avg = avg / n std = zero do i = n+1, 2*n work( i ) = s( i-n ) * work( i-n ) - avg end do - call stdlib_wlassq( n, work( n+1 ), 1, scale, sumsq ) + call stdlib_${ci}$lassq( n, work( n+1 ), 1, scale, sumsq ) std = scale * sqrt( sumsq / n ) if ( std < tol * avg ) goto 999 do i = 1, n t = cabs1( a( i, i ) ) si = s( i ) c2 = ( n-1 ) * t - c1 = ( n-2 ) * ( real( work( i ),KIND=qp) - t*si ) - c0 = -(t*si)*si + 2 * real( work( i ),KIND=qp) * si - n*avg + c1 = ( n-2 ) * ( real( work( i ),KIND=${ck}$) - t*si ) + c0 = -(t*si)*si + 2 * real( work( i ),KIND=${ck}$) * si - n*avg d = c1*c1 - 4*c0*c2 if ( d <= 0 ) then info = -1 @@ -64526,17 +64528,17 @@ module stdlib_linalg_lapack_w work( j ) = work( j ) + d*t end do end if - avg = avg + ( u + real( work( i ),KIND=qp) ) * d / n + avg = avg + ( u + real( work( i ),KIND=${ck}$) ) * d / n s( i ) = si end do end do 999 continue - smlnum = stdlib_qlamch( 'SAFEMIN' ) + smlnum = stdlib_${c2ri(ci)}$lamch( 'SAFEMIN' ) bignum = one / smlnum smin = bignum smax = zero t = one / sqrt( avg ) - base = stdlib_qlamch( 'B' ) + base = stdlib_${c2ri(ci)}$lamch( 'B' ) u = one / log( base ) do i = 1, n s( i ) = base ** int( u * log( s( i ) * t ),KIND=ilp) @@ -64544,10 +64546,10 @@ module stdlib_linalg_lapack_w smax = max( smax, s( i ) ) end do scond = max( smin, smlnum ) / min( smax, bignum ) - end subroutine stdlib_wsyequb + end subroutine stdlib_${ci}$syequb - pure subroutine stdlib_wsymv( uplo, n, alpha, a, lda, x, incx, beta, y, incy ) + pure subroutine stdlib_${ci}$symv( uplo, n, alpha, a, lda, x, incx, beta, y, incy ) !! ZSYMV: performs the matrix-vector operation !! y := alpha*A*x + beta*y, !! where alpha and beta are scalars, x and y are n element vectors and @@ -64558,16 +64560,16 @@ module stdlib_linalg_lapack_w ! Scalar Arguments character, intent(in) :: uplo integer(ilp), intent(in) :: incx, incy, lda, n - complex(qp), intent(in) :: alpha, beta + complex(${ck}$), intent(in) :: alpha, beta ! Array Arguments - complex(qp), intent(in) :: a(lda,*), x(*) - complex(qp), intent(inout) :: y(*) + complex(${ck}$), intent(in) :: a(lda,*), x(*) + complex(${ck}$), intent(inout) :: y(*) ! ===================================================================== ! Local Scalars integer(ilp) :: i, info, ix, iy, j, jx, jy, kx, ky - complex(qp) :: temp1, temp2 + complex(${ck}$) :: temp1, temp2 ! Intrinsic Functions intrinsic :: max ! Executable Statements @@ -64698,10 +64700,10 @@ module stdlib_linalg_lapack_w end if end if return - end subroutine stdlib_wsymv + end subroutine stdlib_${ci}$symv - pure subroutine stdlib_wsyr( uplo, n, alpha, x, incx, a, lda ) + pure subroutine stdlib_${ci}$syr( uplo, n, alpha, x, incx, a, lda ) !! ZSYR: performs the symmetric rank 1 operation !! A := alpha*x*x**H + A, !! where alpha is a complex scalar, x is an n element vector and A is an @@ -64712,15 +64714,15 @@ module stdlib_linalg_lapack_w ! Scalar Arguments character, intent(in) :: uplo integer(ilp), intent(in) :: incx, lda, n - complex(qp), intent(in) :: alpha + complex(${ck}$), intent(in) :: alpha ! Array Arguments - complex(qp), intent(inout) :: a(lda,*) - complex(qp), intent(in) :: x(*) + complex(${ck}$), intent(inout) :: a(lda,*) + complex(${ck}$), intent(in) :: x(*) ! ===================================================================== ! Local Scalars integer(ilp) :: i, info, ix, j, jx, kx - complex(qp) :: temp + complex(${ck}$) :: temp ! Intrinsic Functions intrinsic :: max ! Executable Statements @@ -64802,10 +64804,10 @@ module stdlib_linalg_lapack_w end if end if return - end subroutine stdlib_wsyr + end subroutine stdlib_${ci}$syr - pure subroutine stdlib_wsyrfs( uplo, n, nrhs, a, lda, af, ldaf, ipiv, b, ldb,x, ldx, ferr, & + pure subroutine stdlib_${ci}$syrfs( uplo, n, nrhs, a, lda, af, ldaf, ipiv, b, ldb,x, ldx, ferr, & !! ZSYRFS: improves the computed solution to a system of linear !! equations when the coefficient matrix is symmetric indefinite, and !! provides error bounds and backward error estimates for the solution. @@ -64819,10 +64821,10 @@ module stdlib_linalg_lapack_w integer(ilp), intent(in) :: lda, ldaf, ldb, ldx, n, nrhs ! Array Arguments integer(ilp), intent(in) :: ipiv(*) - real(qp), intent(out) :: berr(*), ferr(*), rwork(*) - complex(qp), intent(in) :: a(lda,*), af(ldaf,*), b(ldb,*) - complex(qp), intent(out) :: work(*) - complex(qp), intent(inout) :: x(ldx,*) + real(${ck}$), intent(out) :: berr(*), ferr(*), rwork(*) + complex(${ck}$), intent(in) :: a(lda,*), af(ldaf,*), b(ldb,*) + complex(${ck}$), intent(out) :: work(*) + complex(${ck}$), intent(inout) :: x(ldx,*) ! ===================================================================== ! Parameters integer(ilp), parameter :: itmax = 5 @@ -64834,16 +64836,16 @@ module stdlib_linalg_lapack_w ! Local Scalars logical(lk) :: upper integer(ilp) :: count, i, j, k, kase, nz - real(qp) :: eps, lstres, s, safe1, safe2, safmin, xk - complex(qp) :: zdum + real(${ck}$) :: eps, lstres, s, safe1, safe2, safmin, xk + complex(${ck}$) :: zdum ! Local Arrays integer(ilp) :: isave(3) ! Intrinsic Functions intrinsic :: abs,real,aimag,max ! Statement Functions - real(qp) :: cabs1 + real(${ck}$) :: cabs1 ! Statement Function Definitions - cabs1( zdum ) = abs( real( zdum,KIND=qp) ) + abs( aimag( zdum ) ) + cabs1( zdum ) = abs( real( zdum,KIND=${ck}$) ) + abs( aimag( zdum ) ) ! Executable Statements ! test the input parameters. info = 0 @@ -64877,8 +64879,8 @@ module stdlib_linalg_lapack_w end if ! nz = maximum number of nonzero elements in each row of a, plus 1 nz = n + 1 - eps = stdlib_qlamch( 'EPSILON' ) - safmin = stdlib_qlamch( 'SAFE MINIMUM' ) + eps = stdlib_${c2ri(ci)}$lamch( 'EPSILON' ) + safmin = stdlib_${c2ri(ci)}$lamch( 'SAFE MINIMUM' ) safe1 = nz*safmin safe2 = safe1 / eps ! do for each right hand side @@ -64888,8 +64890,8 @@ module stdlib_linalg_lapack_w 20 continue ! loop until stopping criterion is satisfied. ! compute residual r = b - a * x - call stdlib_wcopy( n, b( 1, j ), 1, work, 1 ) - call stdlib_wsymv( uplo, n, -cone, a, lda, x( 1, j ), 1, cone, work, 1 ) + call stdlib_${ci}$copy( n, b( 1, j ), 1, work, 1 ) + call stdlib_${ci}$symv( uplo, n, -cone, a, lda, x( 1, j ), 1, cone, work, 1 ) ! 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 @@ -64938,8 +64940,8 @@ module stdlib_linalg_lapack_w ! 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_wsytrs( uplo, n, 1, af, ldaf, ipiv, work, n, info ) - call stdlib_waxpy( n, cone, work, 1, x( 1, j ), 1 ) + call stdlib_${ci}$sytrs( uplo, n, 1, af, ldaf, ipiv, work, n, info ) + call stdlib_${ci}$axpy( n, cone, work, 1, x( 1, j ), 1 ) lstres = berr( j ) count = count + 1 go to 20 @@ -64958,7 +64960,7 @@ module stdlib_linalg_lapack_w ! 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_wlacn2 to estimate the infinity-norm of the matrix + ! 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 @@ -64970,11 +64972,11 @@ module stdlib_linalg_lapack_w end do kase = 0 100 continue - call stdlib_wlacn2( n, work( n+1 ), work, ferr( j ), kase, isave ) + call stdlib_${ci}$lacn2( n, work( n+1 ), work, ferr( j ), kase, isave ) if( kase/=0 ) then if( kase==1 ) then ! multiply by diag(w)*inv(a**t). - call stdlib_wsytrs( uplo, n, 1, af, ldaf, ipiv, work, n, info ) + call stdlib_${ci}$sytrs( uplo, n, 1, af, ldaf, ipiv, work, n, info ) do i = 1, n work( i ) = rwork( i )*work( i ) end do @@ -64983,7 +64985,7 @@ module stdlib_linalg_lapack_w do i = 1, n work( i ) = rwork( i )*work( i ) end do - call stdlib_wsytrs( uplo, n, 1, af, ldaf, ipiv, work, n, info ) + call stdlib_${ci}$sytrs( uplo, n, 1, af, ldaf, ipiv, work, n, info ) end if go to 100 end if @@ -64995,10 +64997,10 @@ module stdlib_linalg_lapack_w if( lstres/=zero )ferr( j ) = ferr( j ) / lstres end do loop_140 return - end subroutine stdlib_wsyrfs + end subroutine stdlib_${ci}$syrfs - pure subroutine stdlib_wsysv( uplo, n, nrhs, a, lda, ipiv, b, ldb, work,lwork, info ) + pure subroutine stdlib_${ci}$sysv( uplo, n, nrhs, a, lda, ipiv, b, ldb, work,lwork, info ) !! ZSYSV: computes the solution to a complex system of linear equations !! A * X = B, !! where A is an N-by-N symmetric matrix and X and B are N-by-NRHS @@ -65019,8 +65021,8 @@ module stdlib_linalg_lapack_w integer(ilp), intent(in) :: lda, ldb, lwork, n, nrhs ! Array Arguments integer(ilp), intent(out) :: ipiv(*) - complex(qp), intent(inout) :: a(lda,*), b(ldb,*) - complex(qp), intent(out) :: work(*) + complex(${ck}$), intent(inout) :: a(lda,*), b(ldb,*) + complex(${ck}$), intent(out) :: work(*) ! ===================================================================== ! Local Scalars logical(lk) :: lquery @@ -65048,8 +65050,8 @@ module stdlib_linalg_lapack_w if( n==0 ) then lwkopt = 1 else - call stdlib_wsytrf( uplo, n, a, lda, ipiv, work, -1, info ) - lwkopt = real( work(1),KIND=qp) + call stdlib_${ci}$sytrf( uplo, n, a, lda, ipiv, work, -1, info ) + lwkopt = real( work(1),KIND=${ck}$) end if work( 1 ) = lwkopt end if @@ -65060,23 +65062,23 @@ module stdlib_linalg_lapack_w return end if ! compute the factorization a = u*d*u**t or a = l*d*l**t. - call stdlib_wsytrf( uplo, n, a, lda, ipiv, work, lwork, info ) + call stdlib_${ci}$sytrf( uplo, n, a, lda, ipiv, work, lwork, info ) if( info==0 ) then ! solve the system a*x = b, overwriting b with x. if ( lwork0 )then rcond = zero @@ -65384,24 +65386,24 @@ module stdlib_linalg_lapack_w end if end if ! compute the norm of the matrix a. - anorm = stdlib_wlansy( 'I', uplo, n, a, lda, rwork ) + anorm = stdlib_${ci}$lansy( 'I', uplo, n, a, lda, rwork ) ! compute the reciprocal of the condition number of a. - call stdlib_wsycon( uplo, n, af, ldaf, ipiv, anorm, rcond, work, info ) + call stdlib_${ci}$sycon( uplo, n, af, ldaf, ipiv, anorm, rcond, work, info ) ! compute the solution vectors x. - call stdlib_wlacpy( 'FULL', n, nrhs, b, ldb, x, ldx ) - call stdlib_wsytrs( uplo, n, nrhs, af, ldaf, ipiv, x, ldx, info ) + call stdlib_${ci}$lacpy( 'FULL', n, nrhs, b, ldb, x, ldx ) + call stdlib_${ci}$sytrs( uplo, n, nrhs, af, ldaf, ipiv, x, ldx, info ) ! use iterative refinement to improve the computed solutions and ! compute error bounds and backward error estimates for them. - call stdlib_wsyrfs( uplo, n, nrhs, a, lda, af, ldaf, ipiv, b, ldb, x,ldx, ferr, berr, & + call stdlib_${ci}$syrfs( uplo, n, nrhs, a, lda, af, ldaf, ipiv, b, ldb, x,ldx, ferr, berr, & work, rwork, info ) ! set info = n+1 if the matrix is singular to working precision. - if( rcond1 ) then - imax = stdlib_iwamax( k-1, a( 1, k ), 1 ) + imax = stdlib_i${ci}$amax( k-1, a( 1, k ), 1 ) colmax = cabs1( a( imax, k ) ) else colmax = zero end if - if( max( absakk, colmax )==zero .or. stdlib_qisnan(absakk) ) then + if( max( absakk, colmax )==zero .or. stdlib_${c2ri(ci)}$isnan(absakk) ) then ! column k is zero or underflow, or contains a nan: ! set info and continue if( info==0 )info = k @@ -65554,10 +65556,10 @@ module stdlib_linalg_lapack_w else ! jmax is the column-index of the largest off-diagonal ! element in row imax, and rowmax is its absolute value - jmax = imax + stdlib_iwamax( k-imax, a( imax, imax+1 ), lda ) + jmax = imax + stdlib_i${ci}$amax( k-imax, a( imax, imax+1 ), lda ) rowmax = cabs1( a( imax, jmax ) ) if( imax>1 ) then - jmax = stdlib_iwamax( imax-1, a( 1, imax ), 1 ) + jmax = stdlib_i${ci}$amax( imax-1, a( 1, imax ), 1 ) rowmax = max( rowmax, cabs1( a( jmax, imax ) ) ) end if if( absakk>=alpha*colmax*( colmax / rowmax ) ) then @@ -65578,8 +65580,8 @@ module stdlib_linalg_lapack_w if( kp/=kk ) then ! interchange rows and columns kk and kp in the leading ! submatrix a(1:k,1:k) - call stdlib_wswap( kp-1, a( 1, kk ), 1, a( 1, kp ), 1 ) - call stdlib_wswap( kk-kp-1, a( kp+1, kk ), 1, a( kp, kp+1 ),lda ) + call stdlib_${ci}$swap( kp-1, a( 1, kk ), 1, a( 1, kp ), 1 ) + call stdlib_${ci}$swap( kk-kp-1, a( kp+1, kk ), 1, a( kp, kp+1 ),lda ) t = a( kk, kk ) a( kk, kk ) = a( kp, kp ) a( kp, kp ) = t @@ -65597,9 +65599,9 @@ module stdlib_linalg_lapack_w ! 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 r1 = cone / a( k, k ) - call stdlib_wsyr( uplo, k-1, -r1, a( 1, k ), 1, a, lda ) + call stdlib_${ci}$syr( uplo, k-1, -r1, a( 1, k ), 1, a, lda ) ! store u(k) in column k - call stdlib_wscal( k-1, r1, a( 1, k ), 1 ) + call stdlib_${ci}$scal( k-1, r1, a( 1, k ), 1 ) 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) @@ -65652,12 +65654,12 @@ module stdlib_linalg_lapack_w ! column k, and colmax is its absolute value. ! determine both colmax and imax. if( k=alpha*colmax*( colmax / rowmax ) ) then @@ -65693,9 +65695,9 @@ module stdlib_linalg_lapack_w if( kp/=kk ) then ! interchange rows and columns kk and kp in the trailing ! submatrix a(k:n,k:n) - if( kp1 ) then - imax = stdlib_iwamax( k-1, a( 1, k ), 1 ) + imax = stdlib_i${ci}$amax( k-1, a( 1, k ), 1 ) colmax = cabs1( a( imax, k ) ) else colmax = zero @@ -65865,13 +65867,13 @@ module stdlib_linalg_lapack_w ! element in row imax, and rowmax is its absolute value. ! determine both rowmax and jmax. if( imax/=k ) then - jmax = imax + stdlib_iwamax( k-imax, a( imax, imax+1 ),lda ) + jmax = imax + stdlib_i${ci}$amax( k-imax, a( imax, imax+1 ),lda ) rowmax = cabs1( a( imax, jmax ) ) else rowmax = zero end if if( imax>1 ) then - itemp = stdlib_iwamax( imax-1, a( 1, imax ), 1 ) + itemp = stdlib_i${ci}$amax( imax-1, a( 1, imax ), 1 ) dtemp = cabs1( a( itemp, imax ) ) if( dtemp>rowmax ) then rowmax = dtemp @@ -65907,23 +65909,23 @@ module stdlib_linalg_lapack_w if( ( kstep==2 ) .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 )call stdlib_wswap( p-1, a( 1, k ), 1, a( 1, p ), 1 ) - if( p<(k-1) )call stdlib_wswap( k-p-1, a( p+1, k ), 1, a( p, p+1 ),lda ) + if( p>1 )call stdlib_${ci}$swap( p-1, a( 1, k ), 1, a( 1, p ), 1 ) + if( p<(k-1) )call stdlib_${ci}$swap( k-p-1, a( p+1, k ), 1, a( p, p+1 ),lda ) t = a( k, k ) a( k, k ) = a( p, p ) a( p, p ) = t ! convert upper triangle of a into u form by applying ! the interchanges in columns k+1:n. - if( k1 )call stdlib_wswap( kp-1, a( 1, kk ), 1, a( 1, kp ), 1 ) - if( ( kk>1 ) .and. ( kp<(kk-1) ) )call stdlib_wswap( kk-kp-1, a( kp+1, kk ), & + if( kp>1 )call stdlib_${ci}$swap( kp-1, a( 1, kk ), 1, a( 1, kp ), 1 ) + if( ( kk>1 ) .and. ( kp<(kk-1) ) )call stdlib_${ci}$swap( kk-kp-1, a( kp+1, kk ), & 1, a( kp, kp+1 ),lda ) t = a( kk, kk ) a( kk, kk ) = a( kp, kp ) @@ -65935,7 +65937,7 @@ module stdlib_linalg_lapack_w end if ! convert upper triangle of a into u form by applying ! the interchanges in columns k+1:n. - if( krowmax ) then rowmax = dtemp @@ -66101,24 +66103,24 @@ module stdlib_linalg_lapack_w if( ( kstep==2 ) .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(k+1) )call stdlib_wswap( p-k-1, a( k+1, k ), 1, a( p, k+1 ), lda ) + if( p(k+1) )call stdlib_${ci}$swap( p-k-1, a( k+1, k ), 1, a( p, k+1 ), lda ) t = a( k, k ) a( k, k ) = a( p, p ) a( p, p ) = t ! convert lower triangle of a into l form by applying ! the interchanges in columns 1:k-1. - if ( k>1 )call stdlib_wswap( k-1, a( k, 1 ), lda, a( p, 1 ), lda ) + if ( k>1 )call stdlib_${ci}$swap( k-1, a( k, 1 ), lda, a( p, 1 ), lda ) end if ! second swap kk = k + kstep - 1 if( kp/=kk ) then ! interchange rows and columns kk and kp in the trailing ! submatrix a(k:n,k:n) - if( kp(kk+1) ) )call stdlib_wswap( kp-kk-1, a( kk+1, kk ), & + if( ( kk(kk+1) ) )call stdlib_${ci}$swap( kp-kk-1, a( kk+1, kk ), & 1, a( kp, kk+1 ),lda ) t = a( kk, kk ) a( kk, kk ) = a( kp, kp ) @@ -66130,7 +66132,7 @@ module stdlib_linalg_lapack_w end if ! convert lower triangle of a into l form by applying ! the interchanges in columns 1:k-1. - if ( k>1 )call stdlib_wswap( k-1, a( kk, 1 ), lda, a( kp, 1 ), lda ) + if ( k>1 )call stdlib_${ci}$swap( k-1, a( kk, 1 ), lda, a( kp, 1 ), lda ) end if ! update the trailing submatrix if( kstep==1 ) then @@ -66145,10 +66147,10 @@ module stdlib_linalg_lapack_w ! 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_wsyr( uplo, n-k, -d11, a( k+1, k ), 1,a( k+1, k+1 ), lda ) + call stdlib_${ci}$syr( uplo, n-k, -d11, a( k+1, k ), 1,a( k+1, k+1 ), lda ) ! store l(k) in column k - call stdlib_wscal( n-k, d11, a( k+1, k ), 1 ) + call stdlib_${ci}$scal( n-k, d11, a( k+1, k ), 1 ) else ! store l(k) in column k d11 = a( k, k ) @@ -66159,7 +66161,7 @@ module stdlib_linalg_lapack_w ! 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_wsyr( uplo, n-k, -d11, a( k+1, k ), 1,a( k+1, k+1 ), lda ) + call stdlib_${ci}$syr( uplo, n-k, -d11, a( k+1, k ), 1,a( k+1, k+1 ), lda ) end if ! store the subdiagonal element of d in array e @@ -66214,10 +66216,10 @@ module stdlib_linalg_lapack_w 64 continue end if return - end subroutine stdlib_wsytf2_rk + end subroutine stdlib_${ci}$sytf2_rk - pure subroutine stdlib_wsytf2_rook( uplo, n, a, lda, ipiv, info ) + pure subroutine stdlib_${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 @@ -66234,24 +66236,24 @@ module stdlib_linalg_lapack_w integer(ilp), intent(in) :: lda, n ! Array Arguments integer(ilp), intent(out) :: ipiv(*) - complex(qp), intent(inout) :: a(lda,*) + complex(${ck}$), intent(inout) :: a(lda,*) ! ===================================================================== ! Parameters - real(qp), parameter :: sevten = 17.0e+0_qp + real(${ck}$), parameter :: sevten = 17.0e+0_${ck}$ ! Local Scalars logical(lk) :: upper, done integer(ilp) :: i, imax, j, jmax, itemp, k, kk, kp, kstep, p, ii - real(qp) :: absakk, alpha, colmax, rowmax, dtemp, sfmin - complex(qp) :: d11, d12, d21, d22, t, wk, wkm1, wkp1, z + real(${ck}$) :: absakk, alpha, colmax, rowmax, dtemp, sfmin + complex(${ck}$) :: d11, d12, d21, d22, t, wk, wkm1, wkp1, z ! Intrinsic Functions intrinsic :: abs,max,sqrt,aimag,real ! Statement Functions - real(qp) :: cabs1 + real(${ck}$) :: cabs1 ! Statement Function Definitions - cabs1( z ) = abs( real( z,KIND=qp) ) + abs( aimag( z ) ) + cabs1( z ) = abs( real( z,KIND=${ck}$) ) + abs( aimag( z ) ) ! Executable Statements ! test the input parameters. info = 0 @@ -66270,7 +66272,7 @@ module stdlib_linalg_lapack_w ! initialize alpha for use in choosing pivot block size. alpha = ( one+sqrt( sevten ) ) / eight ! compute machine safe minimum - sfmin = stdlib_qlamch( 'S' ) + sfmin = stdlib_${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 @@ -66288,7 +66290,7 @@ module stdlib_linalg_lapack_w ! column k, and colmax is its absolute value. ! determine both colmax and imax. if( k>1 ) then - imax = stdlib_iwamax( k-1, a( 1, k ), 1 ) + imax = stdlib_i${ci}$amax( k-1, a( 1, k ), 1 ) colmax = cabs1( a( imax, k ) ) else colmax = zero @@ -66314,13 +66316,13 @@ module stdlib_linalg_lapack_w ! element in row imax, and rowmax is its absolute value. ! determine both rowmax and jmax. if( imax/=k ) then - jmax = imax + stdlib_iwamax( k-imax, a( imax, imax+1 ),lda ) + jmax = imax + stdlib_i${ci}$amax( k-imax, a( imax, imax+1 ),lda ) rowmax = cabs1( a( imax, jmax ) ) else rowmax = zero end if if( imax>1 ) then - itemp = stdlib_iwamax( imax-1, a( 1, imax ), 1 ) + itemp = stdlib_i${ci}$amax( imax-1, a( 1, imax ), 1 ) dtemp = cabs1( a( itemp, imax ) ) if( dtemp>rowmax ) then rowmax = dtemp @@ -66356,8 +66358,8 @@ module stdlib_linalg_lapack_w if( ( kstep==2 ) .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 )call stdlib_wswap( p-1, a( 1, k ), 1, a( 1, p ), 1 ) - if( p<(k-1) )call stdlib_wswap( k-p-1, a( p+1, k ), 1, a( p, p+1 ),lda ) + if( p>1 )call stdlib_${ci}$swap( p-1, a( 1, k ), 1, a( 1, p ), 1 ) + if( p<(k-1) )call stdlib_${ci}$swap( k-p-1, a( p+1, k ), 1, a( p, p+1 ),lda ) t = a( k, k ) a( k, k ) = a( p, p ) @@ -66368,8 +66370,8 @@ module stdlib_linalg_lapack_w if( kp/=kk ) then ! interchange rows and columns kk and kp in the leading ! submatrix a(1:k,1:k) - if( kp>1 )call stdlib_wswap( kp-1, a( 1, kk ), 1, a( 1, kp ), 1 ) - if( ( kk>1 ) .and. ( kp<(kk-1) ) )call stdlib_wswap( kk-kp-1, a( kp+1, kk ), & + if( kp>1 )call stdlib_${ci}$swap( kp-1, a( 1, kk ), 1, a( 1, kp ), 1 ) + if( ( kk>1 ) .and. ( kp<(kk-1) ) )call stdlib_${ci}$swap( kk-kp-1, a( kp+1, kk ), & 1, a( kp, kp+1 ),lda ) t = a( kk, kk ) a( kk, kk ) = a( kp, kp ) @@ -66393,9 +66395,9 @@ module stdlib_linalg_lapack_w ! 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_wsyr( uplo, k-1, -d11, a( 1, k ), 1, a, lda ) + call stdlib_${ci}$syr( uplo, k-1, -d11, a( 1, k ), 1, a, lda ) ! store u(k) in column k - call stdlib_wscal( k-1, d11, a( 1, k ), 1 ) + call stdlib_${ci}$scal( k-1, d11, a( 1, k ), 1 ) else ! store l(k) in column k d11 = a( k, k ) @@ -66406,7 +66408,7 @@ module stdlib_linalg_lapack_w ! 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_wsyr( uplo, k-1, -d11, a( 1, k ), 1, a, lda ) + call stdlib_${ci}$syr( uplo, k-1, -d11, a( 1, k ), 1, a, lda ) end if end if else @@ -66464,7 +66466,7 @@ module stdlib_linalg_lapack_w ! column k, and colmax is its absolute value. ! determine both colmax and imax. if( krowmax ) then rowmax = dtemp @@ -66531,8 +66533,8 @@ module stdlib_linalg_lapack_w if( ( kstep==2 ) .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(k+1) )call stdlib_wswap( p-k-1, a( k+1, k ), 1, a( p, k+1 ), lda ) + if( p(k+1) )call stdlib_${ci}$swap( p-k-1, a( k+1, k ), 1, a( p, k+1 ), lda ) t = a( k, k ) a( k, k ) = a( p, p ) @@ -66543,9 +66545,9 @@ module stdlib_linalg_lapack_w if( kp/=kk ) then ! interchange rows and columns kk and kp in the trailing ! submatrix a(k:n,k:n) - if( kp(kk+1) ) )call stdlib_wswap( kp-kk-1, a( kk+1, kk ), & + if( ( kk(kk+1) ) )call stdlib_${ci}$swap( kp-kk-1, a( kk+1, kk ), & 1, a( kp, kk+1 ),lda ) t = a( kk, kk ) a( kk, kk ) = a( kp, kp ) @@ -66569,10 +66571,10 @@ module stdlib_linalg_lapack_w ! 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_wsyr( uplo, n-k, -d11, a( k+1, k ), 1,a( k+1, k+1 ), lda ) + call stdlib_${ci}$syr( uplo, n-k, -d11, a( k+1, k ), 1,a( k+1, k+1 ), lda ) ! store l(k) in column k - call stdlib_wscal( n-k, d11, a( k+1, k ), 1 ) + call stdlib_${ci}$scal( n-k, d11, a( k+1, k ), 1 ) else ! store l(k) in column k d11 = a( k, k ) @@ -66583,7 +66585,7 @@ module stdlib_linalg_lapack_w ! 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_wsyr( uplo, n-k, -d11, a( k+1, k ), 1,a( k+1, k+1 ), lda ) + call stdlib_${ci}$syr( uplo, n-k, -d11, a( k+1, k ), 1,a( k+1, k+1 ), lda ) end if end if @@ -66630,10 +66632,10 @@ module stdlib_linalg_lapack_w end if 70 continue return - end subroutine stdlib_wsytf2_rook + end subroutine stdlib_${ci}$sytf2_rook - pure subroutine stdlib_wsytrf( uplo, n, a, lda, ipiv, work, lwork, info ) + pure subroutine stdlib_${ci}$sytrf( uplo, n, a, lda, ipiv, work, lwork, info ) !! ZSYTRF: computes the factorization of a complex symmetric matrix A !! using the Bunch-Kaufman diagonal pivoting method. The form of the !! factorization is @@ -66651,8 +66653,8 @@ module stdlib_linalg_lapack_w integer(ilp), intent(in) :: lda, lwork, n ! Array Arguments integer(ilp), intent(out) :: ipiv(*) - complex(qp), intent(inout) :: a(lda,*) - complex(qp), intent(out) :: work(*) + complex(${ck}$), intent(inout) :: a(lda,*) + complex(${ck}$), intent(out) :: work(*) ! ===================================================================== ! Local Scalars logical(lk) :: lquery, upper @@ -66700,7 +66702,7 @@ module stdlib_linalg_lapack_w 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_wlasyf; + ! kb, where kb is the number of columns factorized by stdlib_${ci}$lasyf; ! kb is either nb or nb-1, or k for the last block k = n 10 continue @@ -66709,10 +66711,10 @@ module stdlib_linalg_lapack_w if( k>nb ) then ! factorize columns k-kb+1:k of a and use blocked code to ! update columns 1:k-kb - call stdlib_wlasyf( uplo, k, nb, kb, a, lda, ipiv, work, n, iinfo ) + call stdlib_${ci}$lasyf( uplo, k, nb, kb, a, lda, ipiv, work, n, iinfo ) else ! use unblocked code to factorize columns 1:k of a - call stdlib_wsytf2( uplo, k, a, lda, ipiv, iinfo ) + call stdlib_${ci}$sytf2( uplo, k, a, lda, ipiv, iinfo ) kb = k end if ! set info on the first occurrence of a zero pivot @@ -66723,7 +66725,7 @@ module stdlib_linalg_lapack_w 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_wlasyf; + ! kb, where kb is the number of columns factorized by stdlib_${ci}$lasyf; ! kb is either nb or nb-1, or n-k+1 for the last block k = 1 20 continue @@ -66732,11 +66734,11 @@ module stdlib_linalg_lapack_w 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_wlasyf( uplo, n-k+1, nb, kb, a( k, k ), lda, ipiv( k ),work, n, & + call stdlib_${ci}$lasyf( uplo, n-k+1, nb, kb, a( k, k ), lda, ipiv( k ),work, n, & iinfo ) else ! use unblocked code to factorize columns k:n of a - call stdlib_wsytf2( uplo, n-k+1, a( k, k ), lda, ipiv( k ), iinfo ) + call stdlib_${ci}$sytf2( uplo, n-k+1, a( k, k ), lda, ipiv( k ), iinfo ) kb = n - k + 1 end if ! set info on the first occurrence of a zero pivot @@ -66756,10 +66758,10 @@ module stdlib_linalg_lapack_w 40 continue work( 1 ) = lwkopt return - end subroutine stdlib_wsytrf + end subroutine stdlib_${ci}$sytrf - pure subroutine stdlib_wsytrf_aa( uplo, n, a, lda, ipiv, work, lwork, info) + pure subroutine stdlib_${ci}$sytrf_aa( uplo, n, a, lda, ipiv, work, lwork, info) !! ZSYTRF_AA: computes the factorization of a complex symmetric matrix A !! using the Aasen's algorithm. The form of the factorization is !! A = U**T*T*U or A = L*T*L**T @@ -66775,15 +66777,15 @@ module stdlib_linalg_lapack_w integer(ilp), intent(out) :: info ! Array Arguments integer(ilp), intent(out) :: ipiv(*) - complex(qp), intent(inout) :: a(lda,*) - complex(qp), intent(out) :: work(*) + complex(${ck}$), intent(inout) :: a(lda,*) + complex(${ck}$), intent(out) :: work(*) ! ===================================================================== ! Local Scalars logical(lk) :: lquery, upper integer(ilp) :: j, lwkopt integer(ilp) :: nb, mj, nj, k1, k2, j1, j2, j3, jb - complex(qp) :: alpha + complex(${ck}$) :: alpha ! Intrinsic Functions intrinsic :: max ! Executable Statements @@ -66829,9 +66831,9 @@ module stdlib_linalg_lapack_w ! factorize a as u**t*d*u using the upper triangle of a ! ..................................................... ! copy first row a(1, 1:n) into h(1:n) (stored in work(1:n)) - call stdlib_wcopy( n, a( 1, 1 ), lda, work( 1 ), 1 ) + call stdlib_${ci}$copy( n, a( 1, 1 ), lda, work( 1 ), 1 ) ! j is the main loop index, increasing from 1 to n in steps of - ! jb, where jb is the number of columns factorized by stdlib_wlasyf; + ! jb, where jb is the number of columns factorized by stdlib_${ci}$lasyf; ! jb is either nb, or n-j+1 for the last block j = 0 10 continue @@ -66846,13 +66848,13 @@ module stdlib_linalg_lapack_w jb = min( n-j1+1, nb ) k1 = max(1, j)-j ! panel factorization - call stdlib_wlasyf_aa( uplo, 2-k1, n-j, jb,a( max(1, j), j+1 ), lda,ipiv( j+1 ), & + call stdlib_${ci}$lasyf_aa( uplo, 2-k1, n-j, jb,a( max(1, j), j+1 ), lda,ipiv( j+1 ), & work, n, work( n*nb+1 ) ) ! adjust ipiv and apply it back (j-th step picks (j+1)-th pivot) do j2 = j+2, min(n, j+jb+1) ipiv( j2 ) = ipiv( j2 ) + j if( (j2/=ipiv(j2)) .and. ((j1-k1)>2) ) then - call stdlib_wswap( j1-k1-2, a( 1, j2 ), 1,a( 1, ipiv(j2) ), 1 ) + call stdlib_${ci}$swap( j1-k1-2, a( 1, j2 ), 1,a( 1, ipiv(j2) ), 1 ) end if end do j = j + jb @@ -66865,9 +66867,9 @@ module stdlib_linalg_lapack_w ! merge rank-1 update with blas-3 update alpha = a( j, j+1 ) a( j, j+1 ) = cone - call stdlib_wcopy( n-j, a( j-1, j+1 ), lda,work( (j+1-j1+1)+jb*n ), 1 ) + call stdlib_${ci}$copy( n-j, a( j-1, j+1 ), lda,work( (j+1-j1+1)+jb*n ), 1 ) - call stdlib_wscal( n-j, alpha, work( (j+1-j1+1)+jb*n ), 1 ) + call stdlib_${ci}$scal( n-j, alpha, work( (j+1-j1+1)+jb*n ), 1 ) ! k1 identifies if the previous column of the panel has been ! explicitly stored, e.g., k1=1 and k2= 0 for the first panel, ! while k1=0 and k2=1 for the rest @@ -66882,22 +66884,22 @@ module stdlib_linalg_lapack_w end if do j2 = j+1, n, nb nj = min( nb, n-j2+1 ) - ! update (j2, j2) diagonal block with stdlib_wgemv + ! update (j2, j2) diagonal block with stdlib_${ci}$gemv j3 = j2 do mj = nj-1, 1, -1 - call stdlib_wgemv( 'NO TRANSPOSE', mj, jb+1,-cone, work( j3-j1+1+k1*n ),& + call stdlib_${ci}$gemv( 'NO TRANSPOSE', mj, jb+1,-cone, work( j3-j1+1+k1*n ),& n,a( j1-k2, j3 ), 1,cone, a( j3, j3 ), lda ) j3 = j3 + 1 end do - ! update off-diagonal block of j2-th block row with stdlib_wgemm - call stdlib_wgemm( 'TRANSPOSE', 'TRANSPOSE',nj, n-j3+1, jb+1,-cone, a( j1-& + ! update off-diagonal block of j2-th block row with stdlib_${ci}$gemm + call stdlib_${ci}$gemm( 'TRANSPOSE', 'TRANSPOSE',nj, n-j3+1, jb+1,-cone, a( j1-& k2, j2 ), lda,work( j3-j1+1+k1*n ), n,cone, a( j2, j3 ), lda ) end do ! recover t( j, j+1 ) a( j, j+1 ) = alpha end if ! work(j+1, 1) stores h(j+1, 1) - call stdlib_wcopy( n-j, a( j+1, j+1 ), lda, work( 1 ), 1 ) + call stdlib_${ci}$copy( n-j, a( j+1, j+1 ), lda, work( 1 ), 1 ) end if go to 10 else @@ -66906,9 +66908,9 @@ module stdlib_linalg_lapack_w ! ..................................................... ! copy first column a(1:n, 1) into h(1:n, 1) ! (stored in work(1:n)) - call stdlib_wcopy( n, a( 1, 1 ), 1, work( 1 ), 1 ) + call stdlib_${ci}$copy( n, a( 1, 1 ), 1, work( 1 ), 1 ) ! j is the main loop index, increasing from 1 to n in steps of - ! jb, where jb is the number of columns factorized by stdlib_wlasyf; + ! jb, where jb is the number of columns factorized by stdlib_${ci}$lasyf; ! jb is either nb, or n-j+1 for the last block j = 0 11 continue @@ -66923,13 +66925,13 @@ module stdlib_linalg_lapack_w jb = min( n-j1+1, nb ) k1 = max(1, j)-j ! panel factorization - call stdlib_wlasyf_aa( uplo, 2-k1, n-j, jb,a( j+1, max(1, j) ), lda,ipiv( j+1 ), & + call stdlib_${ci}$lasyf_aa( uplo, 2-k1, n-j, jb,a( j+1, max(1, j) ), lda,ipiv( j+1 ), & work, n, work( n*nb+1 ) ) ! adjust ipiv and apply it back (j-th step picks (j+1)-th pivot) do j2 = j+2, min(n, j+jb+1) ipiv( j2 ) = ipiv( j2 ) + j if( (j2/=ipiv(j2)) .and. ((j1-k1)>2) ) then - call stdlib_wswap( j1-k1-2, a( j2, 1 ), lda,a( ipiv(j2), 1 ), lda ) + call stdlib_${ci}$swap( j1-k1-2, a( j2, 1 ), lda,a( ipiv(j2), 1 ), lda ) end if end do j = j + jb @@ -66942,8 +66944,8 @@ module stdlib_linalg_lapack_w ! merge rank-1 update with blas-3 update alpha = a( j+1, j ) a( j+1, j ) = cone - call stdlib_wcopy( n-j, a( j+1, j-1 ), 1,work( (j+1-j1+1)+jb*n ), 1 ) - call stdlib_wscal( n-j, alpha, work( (j+1-j1+1)+jb*n ), 1 ) + call stdlib_${ci}$copy( n-j, a( j+1, j-1 ), 1,work( (j+1-j1+1)+jb*n ), 1 ) + call stdlib_${ci}$scal( n-j, alpha, work( (j+1-j1+1)+jb*n ), 1 ) ! k1 identifies if the previous column of the panel has been ! explicitly stored, e.g., k1=1 and k2= 0 for the first panel, ! while k1=0 and k2=1 for the rest @@ -66958,15 +66960,15 @@ module stdlib_linalg_lapack_w end if do j2 = j+1, n, nb nj = min( nb, n-j2+1 ) - ! update (j2, j2) diagonal block with stdlib_wgemv + ! update (j2, j2) diagonal block with stdlib_${ci}$gemv j3 = j2 do mj = nj-1, 1, -1 - call stdlib_wgemv( 'NO TRANSPOSE', mj, jb+1,-cone, work( j3-j1+1+k1*n ),& + call stdlib_${ci}$gemv( 'NO TRANSPOSE', mj, jb+1,-cone, work( j3-j1+1+k1*n ),& n,a( j3, j1-k2 ), lda,cone, a( j3, j3 ), 1 ) j3 = j3 + 1 end do - ! update off-diagonal block in j2-th block column with stdlib_wgemm - call stdlib_wgemm( 'NO TRANSPOSE', 'TRANSPOSE',n-j3+1, nj, jb+1,-cone, & + ! update off-diagonal block in j2-th block column with stdlib_${ci}$gemm + call stdlib_${ci}$gemm( 'NO TRANSPOSE', 'TRANSPOSE',n-j3+1, nj, jb+1,-cone, & work( j3-j1+1+k1*n ), n,a( j2, j1-k2 ), lda,cone, a( j3, j2 ), lda ) end do @@ -66974,17 +66976,17 @@ module stdlib_linalg_lapack_w a( j+1, j ) = alpha end if ! work(j+1, 1) stores h(j+1, 1) - call stdlib_wcopy( n-j, a( j+1, j+1 ), 1, work( 1 ), 1 ) + call stdlib_${ci}$copy( n-j, a( j+1, j+1 ), 1, work( 1 ), 1 ) end if go to 11 end if 20 continue work( 1 ) = lwkopt return - end subroutine stdlib_wsytrf_aa + end subroutine stdlib_${ci}$sytrf_aa - pure subroutine stdlib_wsytrf_rk( uplo, n, a, lda, e, ipiv, work, lwork,info ) + pure subroutine stdlib_${ci}$sytrf_rk( uplo, n, a, lda, e, ipiv, work, lwork,info ) !! ZSYTRF_RK: computes the factorization of a complex 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), @@ -67003,8 +67005,8 @@ module stdlib_linalg_lapack_w integer(ilp), intent(in) :: lda, lwork, n ! Array Arguments integer(ilp), intent(out) :: ipiv(*) - complex(qp), intent(inout) :: a(lda,*) - complex(qp), intent(out) :: e(*), work(*) + complex(${ck}$), intent(inout) :: a(lda,*) + complex(${ck}$), intent(out) :: e(*), work(*) ! ===================================================================== ! Local Scalars logical(lk) :: lquery, upper @@ -67052,7 +67054,7 @@ module stdlib_linalg_lapack_w 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_wlasyf_rk; + ! kb, where kb is the number of columns factorized by stdlib_${ci}$lasyf_rk; ! kb is either nb or nb-1, or k for the last block k = n 10 continue @@ -67061,11 +67063,11 @@ module stdlib_linalg_lapack_w if( k>nb ) then ! factorize columns k-kb+1:k of a and use blocked code to ! update columns 1:k-kb - call stdlib_wlasyf_rk( uplo, k, nb, kb, a, lda, e,ipiv, work, ldwork, iinfo ) + call stdlib_${ci}$lasyf_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_wsytf2_rk( uplo, k, a, lda, e, ipiv, iinfo ) + call stdlib_${ci}$sytf2_rk( uplo, k, a, lda, e, ipiv, iinfo ) kb = k end if ! set info on the first occurrence of a zero pivot @@ -67082,7 +67084,7 @@ module stdlib_linalg_lapack_w do i = k, ( k - kb + 1 ), -1 ip = abs( ipiv( i ) ) if( ip/=i ) then - call stdlib_wswap( n-k, a( i, k+1 ), lda,a( ip, k+1 ), lda ) + call stdlib_${ci}$swap( n-k, a( i, k+1 ), lda,a( ip, k+1 ), lda ) end if end do end if @@ -67095,7 +67097,7 @@ module stdlib_linalg_lapack_w 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_wlasyf_rk; + ! kb, where kb is the number of columns factorized by stdlib_${ci}$lasyf_rk; ! kb is either nb or nb-1, or n-k+1 for the last block k = 1 20 continue @@ -67104,11 +67106,11 @@ module stdlib_linalg_lapack_w 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_wlasyf_rk( uplo, n-k+1, nb, kb, a( k, k ), lda, e( k ),ipiv( k ), & + call stdlib_${ci}$lasyf_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_wsytf2_rk( uplo, n-k+1, a( k, k ), lda, e( k ),ipiv( k ), iinfo ) + call stdlib_${ci}$sytf2_rk( uplo, n-k+1, a( k, k ), lda, e( k ),ipiv( k ), iinfo ) kb = n - k + 1 end if @@ -67133,7 +67135,7 @@ module stdlib_linalg_lapack_w do i = k, ( k + kb - 1 ), 1 ip = abs( ipiv( i ) ) if( ip/=i ) then - call stdlib_wswap( k-1, a( i, 1 ), lda,a( ip, 1 ), lda ) + call stdlib_${ci}$swap( k-1, a( i, 1 ), lda,a( ip, 1 ), lda ) end if end do end if @@ -67147,10 +67149,10 @@ module stdlib_linalg_lapack_w end if work( 1 ) = lwkopt return - end subroutine stdlib_wsytrf_rk + end subroutine stdlib_${ci}$sytrf_rk - pure subroutine stdlib_wsytrf_rook( uplo, n, a, lda, ipiv, work, lwork, info ) + pure subroutine stdlib_${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 @@ -67168,8 +67170,8 @@ module stdlib_linalg_lapack_w integer(ilp), intent(in) :: lda, lwork, n ! Array Arguments integer(ilp), intent(out) :: ipiv(*) - complex(qp), intent(inout) :: a(lda,*) - complex(qp), intent(out) :: work(*) + complex(${ck}$), intent(inout) :: a(lda,*) + complex(${ck}$), intent(out) :: work(*) ! ===================================================================== ! Local Scalars logical(lk) :: lquery, upper @@ -67217,7 +67219,7 @@ module stdlib_linalg_lapack_w 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_wlasyf_rook; + ! kb, where kb is the number of columns factorized by stdlib_${ci}$lasyf_rook; ! kb is either nb or nb-1, or k for the last block k = n 10 continue @@ -67226,11 +67228,11 @@ module stdlib_linalg_lapack_w if( k>nb ) then ! factorize columns k-kb+1:k of a and use blocked code to ! update columns 1:k-kb - call stdlib_wlasyf_rook( uplo, k, nb, kb, a, lda,ipiv, work, ldwork, iinfo ) + call stdlib_${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_wsytf2_rook( uplo, k, a, lda, ipiv, iinfo ) + call stdlib_${ci}$sytf2_rook( uplo, k, a, lda, ipiv, iinfo ) kb = k end if ! set info on the first occurrence of a zero pivot @@ -67242,7 +67244,7 @@ module stdlib_linalg_lapack_w 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_wlasyf_rook; + ! kb, where kb is the number of columns factorized by stdlib_${ci}$lasyf_rook; ! kb is either nb or nb-1, or n-k+1 for the last block k = 1 20 continue @@ -67251,11 +67253,11 @@ module stdlib_linalg_lapack_w 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_wlasyf_rook( uplo, n-k+1, nb, kb, a( k, k ), lda,ipiv( k ), work, & + call stdlib_${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_wsytf2_rook( uplo, n-k+1, a( k, k ), lda, ipiv( k ),iinfo ) + call stdlib_${ci}$sytf2_rook( uplo, n-k+1, a( k, k ), lda, ipiv( k ),iinfo ) kb = n - k + 1 end if ! set info on the first occurrence of a zero pivot @@ -67275,10 +67277,10 @@ module stdlib_linalg_lapack_w 40 continue work( 1 ) = lwkopt return - end subroutine stdlib_wsytrf_rook + end subroutine stdlib_${ci}$sytrf_rook - pure subroutine stdlib_wsytri( uplo, n, a, lda, ipiv, work, info ) + pure subroutine stdlib_${ci}$sytri( uplo, n, a, lda, ipiv, work, info ) !! ZSYTRI: computes the inverse of a complex symmetric indefinite matrix !! A using the factorization A = U*D*U**T or A = L*D*L**T computed by !! ZSYTRF. @@ -67291,14 +67293,14 @@ module stdlib_linalg_lapack_w integer(ilp), intent(in) :: lda, n ! Array Arguments integer(ilp), intent(in) :: ipiv(*) - complex(qp), intent(inout) :: a(lda,*) - complex(qp), intent(out) :: work(*) + complex(${ck}$), intent(inout) :: a(lda,*) + complex(${ck}$), intent(out) :: work(*) ! ===================================================================== ! Local Scalars logical(lk) :: upper integer(ilp) :: k, kp, kstep - complex(qp) :: ak, akkp1, akp1, d, t, temp + complex(${ck}$) :: ak, akkp1, akp1, d, t, temp ! Intrinsic Functions intrinsic :: abs,max ! Executable Statements @@ -67345,10 +67347,10 @@ module stdlib_linalg_lapack_w a( k, k ) = cone / a( k, k ) ! compute column k of the inverse. if( k>1 ) then - call stdlib_wcopy( k-1, a( 1, k ), 1, work, 1 ) - call stdlib_wsymv( uplo, k-1, -cone, a, lda, work, 1, czero,a( 1, k ), 1 ) + call stdlib_${ci}$copy( k-1, a( 1, k ), 1, work, 1 ) + call stdlib_${ci}$symv( uplo, k-1, -cone, a, lda, work, 1, czero,a( 1, k ), 1 ) - a( k, k ) = a( k, k ) - stdlib_wdotu( k-1, work, 1, a( 1, k ),1 ) + a( k, k ) = a( k, k ) - stdlib_${ci}$dotu( k-1, work, 1, a( 1, k ),1 ) end if kstep = 1 else @@ -67364,16 +67366,16 @@ module stdlib_linalg_lapack_w a( k, k+1 ) = -akkp1 / d ! compute columns k and k+1 of the inverse. if( k>1 ) then - call stdlib_wcopy( k-1, a( 1, k ), 1, work, 1 ) - call stdlib_wsymv( uplo, k-1, -cone, a, lda, work, 1, czero,a( 1, k ), 1 ) + call stdlib_${ci}$copy( k-1, a( 1, k ), 1, work, 1 ) + call stdlib_${ci}$symv( uplo, k-1, -cone, a, lda, work, 1, czero,a( 1, k ), 1 ) - a( k, k ) = a( k, k ) - stdlib_wdotu( k-1, work, 1, a( 1, k ),1 ) - a( k, k+1 ) = a( k, k+1 ) -stdlib_wdotu( k-1, a( 1, k ), 1, a( 1, k+1 ), 1 ) + a( k, k ) = a( k, k ) - stdlib_${ci}$dotu( k-1, work, 1, a( 1, k ),1 ) + a( k, k+1 ) = a( k, k+1 ) -stdlib_${ci}$dotu( k-1, a( 1, k ), 1, a( 1, k+1 ), 1 ) - call stdlib_wcopy( k-1, a( 1, k+1 ), 1, work, 1 ) - call stdlib_wsymv( uplo, k-1, -cone, a, lda, work, 1, czero,a( 1, k+1 ), 1 ) + call stdlib_${ci}$copy( k-1, a( 1, k+1 ), 1, work, 1 ) + call stdlib_${ci}$symv( uplo, k-1, -cone, a, lda, work, 1, czero,a( 1, k+1 ), 1 ) - a( k+1, k+1 ) = a( k+1, k+1 ) -stdlib_wdotu( k-1, work, 1, a( 1, k+1 ), 1 ) + a( k+1, k+1 ) = a( k+1, k+1 ) -stdlib_${ci}$dotu( k-1, work, 1, a( 1, k+1 ), 1 ) end if kstep = 2 @@ -67382,8 +67384,8 @@ module stdlib_linalg_lapack_w if( kp/=k ) then ! interchange rows and columns k and kp in the leading ! submatrix a(1:k+1,1:k+1) - call stdlib_wswap( kp-1, a( 1, k ), 1, a( 1, kp ), 1 ) - call stdlib_wswap( k-kp-1, a( kp+1, k ), 1, a( kp, kp+1 ), lda ) + call stdlib_${ci}$swap( kp-1, a( 1, k ), 1, a( 1, kp ), 1 ) + call stdlib_${ci}$swap( k-kp-1, a( kp+1, k ), 1, a( kp, kp+1 ), lda ) temp = a( k, k ) a( k, k ) = a( kp, kp ) a( kp, kp ) = temp @@ -67410,10 +67412,10 @@ module stdlib_linalg_lapack_w a( k, k ) = cone / a( k, k ) ! compute column k of the inverse. if( k1 ) then - call stdlib_wcopy( k-1, a( 1, k ), 1, work, 1 ) - call stdlib_wsymv( uplo, k-1, -cone, a, lda, work, 1, czero,a( 1, k ), 1 ) + call stdlib_${ci}$copy( k-1, a( 1, k ), 1, work, 1 ) + call stdlib_${ci}$symv( uplo, k-1, -cone, a, lda, work, 1, czero,a( 1, k ), 1 ) - a( k, k ) = a( k, k ) - stdlib_wdotu( k-1, work, 1, a( 1, k ),1 ) + a( k, k ) = a( k, k ) - stdlib_${ci}$dotu( k-1, work, 1, a( 1, k ),1 ) end if kstep = 1 else @@ -67552,16 +67554,16 @@ module stdlib_linalg_lapack_w a( k, k+1 ) = -akkp1 / d ! compute columns k and k+1 of the inverse. if( k>1 ) then - call stdlib_wcopy( k-1, a( 1, k ), 1, work, 1 ) - call stdlib_wsymv( uplo, k-1, -cone, a, lda, work, 1, czero,a( 1, k ), 1 ) + call stdlib_${ci}$copy( k-1, a( 1, k ), 1, work, 1 ) + call stdlib_${ci}$symv( uplo, k-1, -cone, a, lda, work, 1, czero,a( 1, k ), 1 ) - a( k, k ) = a( k, k ) - stdlib_wdotu( k-1, work, 1, a( 1, k ),1 ) - a( k, k+1 ) = a( k, k+1 ) -stdlib_wdotu( k-1, a( 1, k ), 1, a( 1, k+1 ), 1 ) + a( k, k ) = a( k, k ) - stdlib_${ci}$dotu( k-1, work, 1, a( 1, k ),1 ) + a( k, k+1 ) = a( k, k+1 ) -stdlib_${ci}$dotu( k-1, a( 1, k ), 1, a( 1, k+1 ), 1 ) - call stdlib_wcopy( k-1, a( 1, k+1 ), 1, work, 1 ) - call stdlib_wsymv( uplo, k-1, -cone, a, lda, work, 1, czero,a( 1, k+1 ), 1 ) + call stdlib_${ci}$copy( k-1, a( 1, k+1 ), 1, work, 1 ) + call stdlib_${ci}$symv( uplo, k-1, -cone, a, lda, work, 1, czero,a( 1, k+1 ), 1 ) - a( k+1, k+1 ) = a( k+1, k+1 ) -stdlib_wdotu( k-1, work, 1, a( 1, k+1 ), 1 ) + a( k+1, k+1 ) = a( k+1, k+1 ) -stdlib_${ci}$dotu( k-1, work, 1, a( 1, k+1 ), 1 ) end if kstep = 2 @@ -67571,8 +67573,8 @@ module stdlib_linalg_lapack_w ! submatrix a(1:k+1,1:k+1) kp = ipiv( k ) if( kp/=k ) then - if( kp>1 )call stdlib_wswap( kp-1, a( 1, k ), 1, a( 1, kp ), 1 ) - call stdlib_wswap( k-kp-1, a( kp+1, k ), 1, a( kp, kp+1 ), lda ) + if( kp>1 )call stdlib_${ci}$swap( kp-1, a( 1, k ), 1, a( 1, kp ), 1 ) + call stdlib_${ci}$swap( k-kp-1, a( kp+1, k ), 1, a( kp, kp+1 ), lda ) temp = a( k, k ) a( k, k ) = a( kp, kp ) a( kp, kp ) = temp @@ -67582,8 +67584,8 @@ module stdlib_linalg_lapack_w ! -ipiv(k+1)in the leading submatrix a(1:k+1,1:k+1) kp = -ipiv( k ) if( kp/=k ) then - if( kp>1 )call stdlib_wswap( kp-1, a( 1, k ), 1, a( 1, kp ), 1 ) - call stdlib_wswap( k-kp-1, a( kp+1, k ), 1, a( kp, kp+1 ), lda ) + if( kp>1 )call stdlib_${ci}$swap( kp-1, a( 1, k ), 1, a( 1, kp ), 1 ) + call stdlib_${ci}$swap( k-kp-1, a( kp+1, k ), 1, a( kp, kp+1 ), lda ) temp = a( k, k ) a( k, k ) = a( kp, kp ) a( kp, kp ) = temp @@ -67594,8 +67596,8 @@ module stdlib_linalg_lapack_w k = k + 1 kp = -ipiv( k ) if( kp/=k ) then - if( kp>1 )call stdlib_wswap( kp-1, a( 1, k ), 1, a( 1, kp ), 1 ) - call stdlib_wswap( k-kp-1, a( kp+1, k ), 1, a( kp, kp+1 ), lda ) + if( kp>1 )call stdlib_${ci}$swap( kp-1, a( 1, k ), 1, a( 1, kp ), 1 ) + call stdlib_${ci}$swap( k-kp-1, a( kp+1, k ), 1, a( kp, kp+1 ), lda ) temp = a( k, k ) a( k, k ) = a( kp, kp ) a( kp, kp ) = temp @@ -67618,10 +67620,10 @@ module stdlib_linalg_lapack_w a( k, k ) = cone / a( k, k ) ! compute column k of the inverse. if( k b [ (u \p**t * b) ] - call stdlib_wtrsm('L','U','N','U',n,nrhs,cone,a,lda,b,ldb) + call stdlib_${ci}$trsm('L','U','N','U',n,nrhs,cone,a,lda,b,ldb) ! compute d \ b -> b [ d \ (u \p**t * b) ] i=n do while ( i >= 1 ) if( ipiv(i) > 0 ) then - call stdlib_wscal( nrhs, cone / a( i, i ), b( i, 1 ), ldb ) + call stdlib_${ci}$scal( nrhs, cone / a( i, i ), b( i, 1 ), ldb ) elseif ( i > 1) then if ( ipiv(i-1) == ipiv(i) ) then akm1k = work(i) @@ -67994,7 +67996,7 @@ module stdlib_linalg_lapack_w i = i - 1 end do ! compute (u**t \ b) -> b [ u**t \ (d \ (u \p**t * b) ) ] - call stdlib_wtrsm('L','U','T','U',n,nrhs,cone,a,lda,b,ldb) + call stdlib_${ci}$trsm('L','U','T','U',n,nrhs,cone,a,lda,b,ldb) ! p * b [ p * (u**t \ (d \ (u \p**t * b) )) ] k=1 do while ( k <= n ) @@ -68002,13 +68004,13 @@ module stdlib_linalg_lapack_w ! 1 x 1 diagonal block ! interchange rows k and ipiv(k). kp = ipiv( k ) - if( kp/=k )call stdlib_wswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib_${ci}$swap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) k=k+1 else ! 2 x 2 diagonal block ! interchange rows k-1 and -ipiv(k). kp = -ipiv( k ) - if( k < n .and. kp==-ipiv( k+1 ) )call stdlib_wswap( nrhs, b( k, 1 ), ldb, b( kp,& + if( k < n .and. kp==-ipiv( k+1 ) )call stdlib_${ci}$swap( nrhs, b( k, 1 ), ldb, b( kp,& 1 ), ldb ) k=k+2 endif @@ -68022,24 +68024,24 @@ module stdlib_linalg_lapack_w ! 1 x 1 diagonal block ! interchange rows k and ipiv(k). kp = ipiv( k ) - if( kp/=k )call stdlib_wswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib_${ci}$swap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) k=k+1 else ! 2 x 2 diagonal block ! interchange rows k and -ipiv(k+1). kp = -ipiv( k+1 ) - if( kp==-ipiv( k ) )call stdlib_wswap( nrhs, b( k+1, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp==-ipiv( k ) )call stdlib_${ci}$swap( nrhs, b( k+1, 1 ), ldb, b( kp, 1 ), ldb ) k=k+2 endif end do ! compute (l \p**t * b) -> b [ (l \p**t * b) ] - call stdlib_wtrsm('L','L','N','U',n,nrhs,cone,a,lda,b,ldb) + call stdlib_${ci}$trsm('L','L','N','U',n,nrhs,cone,a,lda,b,ldb) ! compute d \ b -> b [ d \ (l \p**t * b) ] i=1 do while ( i <= n ) if( ipiv(i) > 0 ) then - call stdlib_wscal( nrhs, cone / a( i, i ), b( i, 1 ), ldb ) + call stdlib_${ci}$scal( nrhs, cone / a( i, i ), b( i, 1 ), ldb ) else akm1k = work(i) akm1 = a( i, i ) / akm1k @@ -68056,7 +68058,7 @@ module stdlib_linalg_lapack_w i = i + 1 end do ! compute (l**t \ b) -> b [ l**t \ (d \ (l \p**t * b) ) ] - call stdlib_wtrsm('L','L','T','U',n,nrhs,cone,a,lda,b,ldb) + call stdlib_${ci}$trsm('L','L','T','U',n,nrhs,cone,a,lda,b,ldb) ! p * b [ p * (l**t \ (d \ (l \p**t * b) )) ] k=n do while ( k >= 1 ) @@ -68064,25 +68066,25 @@ module stdlib_linalg_lapack_w ! 1 x 1 diagonal block ! interchange rows k and ipiv(k). kp = ipiv( k ) - if( kp/=k )call stdlib_wswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib_${ci}$swap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) k=k-1 else ! 2 x 2 diagonal block ! interchange rows k-1 and -ipiv(k). kp = -ipiv( k ) - if( k>1 .and. kp==-ipiv( k-1 ) )call stdlib_wswap( nrhs, b( k, 1 ), ldb, b( kp, & + if( k>1 .and. kp==-ipiv( k-1 ) )call stdlib_${ci}$swap( nrhs, b( k, 1 ), ldb, b( kp, & 1 ), ldb ) k=k-2 endif end do end if ! revert a - call stdlib_wsyconv( uplo, 'R', n, a, lda, ipiv, work, iinfo ) + call stdlib_${ci}$syconv( uplo, 'R', n, a, lda, ipiv, work, iinfo ) return - end subroutine stdlib_wsytrs2 + end subroutine stdlib_${ci}$sytrs2 - pure subroutine stdlib_wsytrs_3( uplo, n, nrhs, a, lda, e, ipiv, b, ldb,info ) + pure subroutine stdlib_${ci}$sytrs_3( uplo, n, nrhs, a, lda, e, ipiv, b, ldb,info ) !! ZSYTRS_3: solves a system of linear equations A * X = B with a complex !! symmetric matrix A using the factorization computed !! by ZSYTRF_RK or ZSYTRF_BK: @@ -68101,14 +68103,14 @@ module stdlib_linalg_lapack_w integer(ilp), intent(in) :: lda, ldb, n, nrhs ! Array Arguments integer(ilp), intent(in) :: ipiv(*) - complex(qp), intent(in) :: a(lda,*), e(*) - complex(qp), intent(inout) :: b(ldb,*) + complex(${ck}$), intent(in) :: a(lda,*), e(*) + complex(${ck}$), intent(inout) :: b(ldb,*) ! ===================================================================== ! Local Scalars logical(lk) :: upper integer(ilp) :: i, j, k, kp - complex(qp) :: ak, akm1, akm1k, bk, bkm1, denom + complex(${ck}$) :: ak, akm1, akm1k, bk, bkm1, denom ! Intrinsic Functions intrinsic :: abs,max ! Executable Statements @@ -68143,16 +68145,16 @@ module stdlib_linalg_lapack_w do k = n, 1, -1 kp = abs( ipiv( k ) ) if( kp/=k ) then - call stdlib_wswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + call stdlib_${ci}$swap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) end if end do ! compute (u \p**t * b) -> b [ (u \p**t * b) ] - call stdlib_wtrsm( 'L', 'U', 'N', 'U', n, nrhs, cone, a, lda, b, ldb ) + call stdlib_${ci}$trsm( 'L', 'U', 'N', 'U', n, nrhs, cone, a, lda, b, ldb ) ! compute d \ b -> b [ d \ (u \p**t * b) ] i = n do while ( i>=1 ) if( ipiv( i )>0 ) then - call stdlib_wscal( nrhs, cone / a( i, i ), b( i, 1 ), ldb ) + call stdlib_${ci}$scal( nrhs, cone / a( i, i ), b( i, 1 ), ldb ) else if ( i>1 ) then akm1k = e( i ) akm1 = a( i-1, i-1 ) / akm1k @@ -68169,7 +68171,7 @@ module stdlib_linalg_lapack_w i = i - 1 end do ! compute (u**t \ b) -> b [ u**t \ (d \ (u \p**t * b) ) ] - call stdlib_wtrsm( 'L', 'U', 'T', 'U', n, nrhs, cone, a, lda, b, ldb ) + call stdlib_${ci}$trsm( 'L', 'U', 'T', 'U', n, nrhs, cone, a, lda, b, ldb ) ! p * b [ p * (u**t \ (d \ (u \p**t * b) )) ] ! interchange rows k and ipiv(k) of matrix b in reverse order ! from the formation order of ipiv(i) vector for upper case. @@ -68179,7 +68181,7 @@ module stdlib_linalg_lapack_w do k = 1, n, 1 kp = abs( ipiv( k ) ) if( kp/=k ) then - call stdlib_wswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + call stdlib_${ci}$swap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) end if end do else @@ -68194,16 +68196,16 @@ module stdlib_linalg_lapack_w do k = 1, n, 1 kp = abs( ipiv( k ) ) if( kp/=k ) then - call stdlib_wswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + call stdlib_${ci}$swap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) end if end do ! compute (l \p**t * b) -> b [ (l \p**t * b) ] - call stdlib_wtrsm( 'L', 'L', 'N', 'U', n, nrhs, cone, a, lda, b, ldb ) + call stdlib_${ci}$trsm( 'L', 'L', 'N', 'U', n, nrhs, cone, a, lda, b, ldb ) ! compute d \ b -> b [ d \ (l \p**t * b) ] i = 1 do while ( i<=n ) if( ipiv( i )>0 ) then - call stdlib_wscal( nrhs, cone / a( i, i ), b( i, 1 ), ldb ) + call stdlib_${ci}$scal( nrhs, cone / a( i, i ), b( i, 1 ), ldb ) else if( i b [ l**t \ (d \ (l \p**t * b) ) ] - call stdlib_wtrsm('L', 'L', 'T', 'U', n, nrhs, cone, a, lda, b, ldb ) + call stdlib_${ci}$trsm('L', 'L', 'T', 'U', n, nrhs, cone, a, lda, b, ldb ) ! p * b [ p * (l**t \ (d \ (l \p**t * b) )) ] ! interchange rows k and ipiv(k) of matrix b in reverse order ! from the formation order of ipiv(i) vector for lower case. @@ -68230,16 +68232,16 @@ module stdlib_linalg_lapack_w do k = n, 1, -1 kp = abs( ipiv( k ) ) if( kp/=k ) then - call stdlib_wswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + call stdlib_${ci}$swap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) end if end do ! end lower end if return - end subroutine stdlib_wsytrs_3 + end subroutine stdlib_${ci}$sytrs_3 - pure subroutine stdlib_wsytrs_aa( uplo, n, nrhs, a, lda, ipiv, b, ldb,work, lwork, info ) + pure subroutine stdlib_${ci}$sytrs_aa( uplo, n, nrhs, a, lda, ipiv, b, ldb,work, lwork, info ) !! ZSYTRS_AA: solves a system of linear equations A*X = B with a complex !! symmetric matrix A using the factorization A = U**T*T*U or !! A = L*T*L**T computed by ZSYTRF_AA. @@ -68253,9 +68255,9 @@ module stdlib_linalg_lapack_w integer(ilp), intent(out) :: info ! Array Arguments integer(ilp), intent(in) :: ipiv(*) - complex(qp), intent(in) :: a(lda,*) - complex(qp), intent(inout) :: b(ldb,*) - complex(qp), intent(out) :: work(*) + complex(${ck}$), intent(in) :: a(lda,*) + complex(${ck}$), intent(inout) :: b(ldb,*) + complex(${ck}$), intent(out) :: work(*) ! ===================================================================== logical(lk) :: lquery, upper @@ -68296,29 +68298,29 @@ module stdlib_linalg_lapack_w ! pivot, p**t * b -> b do k = 1, n kp = ipiv( k ) - if( kp/=k )call stdlib_wswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib_${ci}$swap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) end do ! compute u**t \ b -> b [ (u**t \p**t * b) ] - call stdlib_wtrsm( 'L', 'U', 'T', 'U', n-1, nrhs, cone, a( 1, 2 ),lda, b( 2, 1 ),& + call stdlib_${ci}$trsm( 'L', 'U', 'T', 'U', n-1, nrhs, cone, a( 1, 2 ),lda, b( 2, 1 ),& ldb) end if ! 2) solve with triangular matrix t ! compute t \ b -> b [ t \ (u**t \p**t * b) ] - call stdlib_wlacpy( 'F', 1, n, a( 1, 1 ), lda+1, work( n ), 1) + call stdlib_${ci}$lacpy( 'F', 1, n, a( 1, 1 ), lda+1, work( n ), 1) if( n>1 ) then - call stdlib_wlacpy( 'F', 1, n-1, a( 1, 2 ), lda+1, work( 1 ), 1 ) - call stdlib_wlacpy( 'F', 1, n-1, a( 1, 2 ), lda+1, work( 2*n ), 1 ) + call stdlib_${ci}$lacpy( 'F', 1, n-1, a( 1, 2 ), lda+1, work( 1 ), 1 ) + call stdlib_${ci}$lacpy( 'F', 1, n-1, a( 1, 2 ), lda+1, work( 2*n ), 1 ) end if - call stdlib_wgtsv( n, nrhs, work( 1 ), work( n ), work( 2*n ), b, ldb,info ) + call stdlib_${ci}$gtsv( n, nrhs, work( 1 ), work( n ), work( 2*n ), b, ldb,info ) ! 3) backward substitution with u if( n>1 ) then ! compute u \ b -> b [ u \ (t \ (u**t \p**t * b) ) ] - call stdlib_wtrsm( 'L', 'U', 'N', 'U', n-1, nrhs, cone, a( 1, 2 ),lda, b( 2, 1 ),& + call stdlib_${ci}$trsm( 'L', 'U', 'N', 'U', n-1, nrhs, cone, a( 1, 2 ),lda, b( 2, 1 ),& ldb) ! pivot, p * b -> b [ p * (u \ (t \ (u**t \p**t * b) )) ] do k = n, 1, -1 kp = ipiv( k ) - if( kp/=k )call stdlib_wswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib_${ci}$swap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) end do end if else @@ -68328,37 +68330,37 @@ module stdlib_linalg_lapack_w ! pivot, p**t * b -> b do k = 1, n kp = ipiv( k ) - if( kp/=k )call stdlib_wswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib_${ci}$swap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) end do ! compute l \ b -> b [ (l \p**t * b) ] - call stdlib_wtrsm( 'L', 'L', 'N', 'U', n-1, nrhs, cone, a( 2, 1 ),lda, b( 2, 1 ),& + call stdlib_${ci}$trsm( 'L', 'L', 'N', 'U', n-1, nrhs, cone, a( 2, 1 ),lda, b( 2, 1 ),& ldb) end if ! 2) solve with triangular matrix t ! compute t \ b -> b [ t \ (l \p**t * b) ] - call stdlib_wlacpy( 'F', 1, n, a(1, 1), lda+1, work(n), 1) + call stdlib_${ci}$lacpy( 'F', 1, n, a(1, 1), lda+1, work(n), 1) if( n>1 ) then - call stdlib_wlacpy( 'F', 1, n-1, a( 2, 1 ), lda+1, work( 1 ), 1 ) - call stdlib_wlacpy( 'F', 1, n-1, a( 2, 1 ), lda+1, work( 2*n ), 1 ) + call stdlib_${ci}$lacpy( 'F', 1, n-1, a( 2, 1 ), lda+1, work( 1 ), 1 ) + call stdlib_${ci}$lacpy( 'F', 1, n-1, a( 2, 1 ), lda+1, work( 2*n ), 1 ) end if - call stdlib_wgtsv( n, nrhs, work( 1 ), work(n), work( 2*n ), b, ldb,info) + call stdlib_${ci}$gtsv( n, nrhs, work( 1 ), work(n), work( 2*n ), b, ldb,info) ! 3) backward substitution with l**t if( n>1 ) then ! compute (l**t \ b) -> b [ l**t \ (t \ (l \p**t * b) ) ] - call stdlib_wtrsm( 'L', 'L', 'T', 'U', n-1, nrhs, cone, a( 2, 1 ),lda, b( 2, 1 ),& + call stdlib_${ci}$trsm( 'L', 'L', 'T', 'U', n-1, nrhs, cone, a( 2, 1 ),lda, b( 2, 1 ),& ldb) ! pivot, p * b -> b [ p * (l**t \ (t \ (l \p**t * b) )) ] do k = n, 1, -1 kp = ipiv( k ) - if( kp/=k )call stdlib_wswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib_${ci}$swap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) end do end if end if return - end subroutine stdlib_wsytrs_aa + end subroutine stdlib_${ci}$sytrs_aa - pure subroutine stdlib_wsytrs_rook( uplo, n, nrhs, a, lda, ipiv, b, ldb,info ) + pure subroutine stdlib_${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. @@ -68371,14 +68373,14 @@ module stdlib_linalg_lapack_w integer(ilp), intent(in) :: lda, ldb, n, nrhs ! Array Arguments integer(ilp), intent(in) :: ipiv(*) - complex(qp), intent(in) :: a(lda,*) - complex(qp), intent(inout) :: b(ldb,*) + complex(${ck}$), intent(in) :: a(lda,*) + complex(${ck}$), intent(inout) :: b(ldb,*) ! ===================================================================== ! Local Scalars logical(lk) :: upper integer(ilp) :: j, k, kp - complex(qp) :: ak, akm1, akm1k, bk, bkm1, denom + complex(${ck}$) :: ak, akm1, akm1k, bk, bkm1, denom ! Intrinsic Functions intrinsic :: max ! Executable Statements @@ -68414,27 +68416,27 @@ module stdlib_linalg_lapack_w ! 1 x 1 diagonal block ! interchange rows k and ipiv(k). kp = ipiv( k ) - if( kp/=k )call stdlib_wswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib_${ci}$swap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) ! multiply by inv(u(k)), where u(k) is the transformation ! stored in column k of a. - call stdlib_wgeru( k-1, nrhs, -cone, a( 1, k ), 1, b( k, 1 ), ldb,b( 1, 1 ), ldb & + call stdlib_${ci}$geru( k-1, nrhs, -cone, a( 1, k ), 1, b( k, 1 ), ldb,b( 1, 1 ), ldb & ) ! multiply by the inverse of the diagonal block. - call stdlib_wscal( nrhs, cone / a( k, k ), b( k, 1 ), ldb ) + call stdlib_${ci}$scal( nrhs, cone / a( k, k ), b( k, 1 ), ldb ) k = k - 1 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_wswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib_${ci}$swap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) kp = -ipiv( k-1 ) - if( kp/=k-1 )call stdlib_wswap( nrhs, b( k-1, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k-1 )call stdlib_${ci}$swap( nrhs, b( k-1, 1 ), ldb, b( kp, 1 ), ldb ) ! multiply by inv(u(k)), where u(k) is the transformation ! stored in columns k-1 and k of a. if( k>2 ) then - call stdlib_wgeru( k-2, nrhs,-cone, a( 1, k ), 1, b( k, 1 ),ldb, b( 1, 1 ), & + call stdlib_${ci}$geru( k-2, nrhs,-cone, a( 1, k ), 1, b( k, 1 ),ldb, b( 1, 1 ), & ldb ) - call stdlib_wgeru( k-2, nrhs,-cone, a( 1, k-1 ), 1, b( k-1, 1 ),ldb, b( 1, 1 )& + call stdlib_${ci}$geru( k-2, nrhs,-cone, a( 1, k-1 ), 1, b( k-1, 1 ),ldb, b( 1, 1 )& , ldb ) end if ! multiply by the inverse of the diagonal block. @@ -68463,27 +68465,27 @@ module stdlib_linalg_lapack_w ! 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 )call stdlib_wgemv( 'TRANSPOSE', k-1, nrhs, -cone, b,ldb, a( 1, k ), 1, & + if( k>1 )call stdlib_${ci}$gemv( 'TRANSPOSE', k-1, nrhs, -cone, b,ldb, a( 1, k ), 1, & cone, b( k, 1 ), ldb ) ! interchange rows k and ipiv(k). kp = ipiv( k ) - if( kp/=k )call stdlib_wswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib_${ci}$swap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) k = k + 1 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 ) then - call stdlib_wgemv( 'TRANSPOSE', k-1, nrhs, -cone, b,ldb, a( 1, k ), 1, cone, & + call stdlib_${ci}$gemv( 'TRANSPOSE', k-1, nrhs, -cone, b,ldb, a( 1, k ), 1, cone, & b( k, 1 ), ldb ) - call stdlib_wgemv( 'TRANSPOSE', k-1, nrhs, -cone, b,ldb, a( 1, k+1 ), 1, cone,& + call stdlib_${ci}$gemv( 'TRANSPOSE', k-1, nrhs, -cone, b,ldb, a( 1, k+1 ), 1, cone,& b( k+1, 1 ), ldb ) end if ! interchange rows k and -ipiv(k) then k+1 and -ipiv(k+1). kp = -ipiv( k ) - if( kp/=k )call stdlib_wswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib_${ci}$swap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) kp = -ipiv( k+1 ) - if( kp/=k+1 )call stdlib_wswap( nrhs, b( k+1, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k+1 )call stdlib_${ci}$swap( nrhs, b( k+1, 1 ), ldb, b( kp, 1 ), ldb ) k = k + 2 end if go to 40 @@ -68501,27 +68503,27 @@ module stdlib_linalg_lapack_w ! 1 x 1 diagonal block ! interchange rows k and ipiv(k). kp = ipiv( k ) - if( kp/=k )call stdlib_wswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib_${ci}$swap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) ! multiply by inv(l(k)), where l(k) is the transformation ! stored in column k of a. - if( k 0. if( anorm>zero ) then ! estimate the 1-norm of the inverse of a. @@ -68660,24 +68662,24 @@ module stdlib_linalg_lapack_w end if kase = 0 10 continue - call stdlib_wlacn2( n, work( n+1 ), work, ainvnm, kase, isave ) + call stdlib_${ci}$lacn2( n, work( n+1 ), work, ainvnm, kase, isave ) if( kase/=0 ) then if( kase==kase1 ) then ! multiply by inv(a). - call stdlib_wlatbs( uplo, 'NO TRANSPOSE', diag, normin, n, kd,ab, ldab, work, & + call stdlib_${ci}$latbs( uplo, 'NO TRANSPOSE', diag, normin, n, kd,ab, ldab, work, & scale, rwork, info ) else ! multiply by inv(a**h). - call stdlib_wlatbs( uplo, 'CONJUGATE TRANSPOSE', diag, normin,n, kd, ab, ldab,& + call stdlib_${ci}$latbs( uplo, 'CONJUGATE TRANSPOSE', diag, normin,n, kd, ab, ldab,& work, scale, rwork, info ) end if normin = 'Y' ! multiply by 1/scale if doing so will not cause overflow. if( scale/=one ) then - ix = stdlib_iwamax( n, work, 1 ) + ix = stdlib_i${ci}$amax( n, work, 1 ) xnorm = cabs1( work( ix ) ) if( scale a(0,0), t2 -> a(0,1), s -> a(n1,0) ! t1 -> a(0), t2 -> a(n), s -> a(n1) - call stdlib_wtrtri( 'L', diag, n1, a( 0 ), n, info ) + call stdlib_${ci}$trtri( 'L', diag, n1, a( 0 ), n, info ) if( info>0 )return - call stdlib_wtrmm( 'R', 'L', 'N', diag, n2, n1, -cone, a( 0 ),n, a( n1 ), n ) + call stdlib_${ci}$trmm( 'R', 'L', 'N', diag, n2, n1, -cone, a( 0 ),n, a( n1 ), n ) - call stdlib_wtrtri( 'U', diag, n2, a( n ), n, info ) + call stdlib_${ci}$trtri( 'U', diag, n2, a( n ), n, info ) if( info>0 )info = info + n1 if( info>0 )return - call stdlib_wtrmm( 'L', 'U', 'C', diag, n2, n1, cone, a( n ), n,a( n1 ), n ) + call stdlib_${ci}$trmm( 'L', 'U', 'C', diag, n2, n1, cone, a( n ), n,a( n1 ), n ) else ! srpa for upper, normal and n is odd ( a(0:n-1,0:n2-1) ! t1 -> a(n1+1,0), t2 -> a(n1,0), s -> a(0,0) ! t1 -> a(n2), t2 -> a(n1), s -> a(0) - call stdlib_wtrtri( 'L', diag, n1, a( n2 ), n, info ) + call stdlib_${ci}$trtri( 'L', diag, n1, a( n2 ), n, info ) if( info>0 )return - call stdlib_wtrmm( 'L', 'L', 'C', diag, n1, n2, -cone, a( n2 ),n, a( 0 ), n ) + call stdlib_${ci}$trmm( 'L', 'L', 'C', diag, n1, n2, -cone, a( n2 ),n, a( 0 ), n ) - call stdlib_wtrtri( 'U', diag, n2, a( n1 ), n, info ) + call stdlib_${ci}$trtri( 'U', diag, n2, a( n1 ), n, info ) if( info>0 )info = info + n1 if( info>0 )return - call stdlib_wtrmm( 'R', 'U', 'N', diag, n1, n2, cone, a( n1 ),n, a( 0 ), n ) + call stdlib_${ci}$trmm( 'R', 'U', 'N', diag, n1, n2, cone, a( n1 ),n, a( 0 ), n ) end if else @@ -69601,26 +69603,26 @@ module stdlib_linalg_lapack_w if( lower ) then ! srpa for lower, transpose and n is odd ! t1 -> a(0), t2 -> a(1), s -> a(0+n1*n1) - call stdlib_wtrtri( 'U', diag, n1, a( 0 ), n1, info ) + call stdlib_${ci}$trtri( 'U', diag, n1, a( 0 ), n1, info ) if( info>0 )return - call stdlib_wtrmm( 'L', 'U', 'N', diag, n1, n2, -cone, a( 0 ),n1, a( n1*n1 ), & + call stdlib_${ci}$trmm( 'L', 'U', 'N', diag, n1, n2, -cone, a( 0 ),n1, a( n1*n1 ), & n1 ) - call stdlib_wtrtri( 'L', diag, n2, a( 1 ), n1, info ) + call stdlib_${ci}$trtri( 'L', diag, n2, a( 1 ), n1, info ) if( info>0 )info = info + n1 if( info>0 )return - call stdlib_wtrmm( 'R', 'L', 'C', diag, n1, n2, cone, a( 1 ),n1, a( n1*n1 ), & + call stdlib_${ci}$trmm( 'R', 'L', 'C', diag, n1, n2, cone, a( 1 ),n1, a( n1*n1 ), & n1 ) else ! srpa for upper, transpose and n is odd ! t1 -> a(0+n2*n2), t2 -> a(0+n1*n2), s -> a(0) - call stdlib_wtrtri( 'U', diag, n1, a( n2*n2 ), n2, info ) + call stdlib_${ci}$trtri( 'U', diag, n1, a( n2*n2 ), n2, info ) if( info>0 )return - call stdlib_wtrmm( 'R', 'U', 'C', diag, n2, n1, -cone,a( n2*n2 ), n2, a( 0 ), & + call stdlib_${ci}$trmm( 'R', 'U', 'C', diag, n2, n1, -cone,a( n2*n2 ), n2, a( 0 ), & n2 ) - call stdlib_wtrtri( 'L', diag, n2, a( n1*n2 ), n2, info ) + call stdlib_${ci}$trtri( 'L', diag, n2, a( n1*n2 ), n2, info ) if( info>0 )info = info + n1 if( info>0 )return - call stdlib_wtrmm( 'L', 'L', 'N', diag, n2, n1, cone,a( n1*n2 ), n2, a( 0 ), & + call stdlib_${ci}$trmm( 'L', 'L', 'N', diag, n2, n1, cone,a( n1*n2 ), n2, a( 0 ), & n2 ) end if end if @@ -69632,27 +69634,27 @@ module stdlib_linalg_lapack_w ! srpa for lower, normal, and n is even ( a(0:n,0:k-1) ) ! t1 -> a(1,0), t2 -> a(0,0), s -> a(k+1,0) ! t1 -> a(1), t2 -> a(0), s -> a(k+1) - call stdlib_wtrtri( 'L', diag, k, a( 1 ), n+1, info ) + call stdlib_${ci}$trtri( 'L', diag, k, a( 1 ), n+1, info ) if( info>0 )return - call stdlib_wtrmm( 'R', 'L', 'N', diag, k, k, -cone, a( 1 ),n+1, a( k+1 ), n+& + call stdlib_${ci}$trmm( 'R', 'L', 'N', diag, k, k, -cone, a( 1 ),n+1, a( k+1 ), n+& 1 ) - call stdlib_wtrtri( 'U', diag, k, a( 0 ), n+1, info ) + call stdlib_${ci}$trtri( 'U', diag, k, a( 0 ), n+1, info ) if( info>0 )info = info + k if( info>0 )return - call stdlib_wtrmm( 'L', 'U', 'C', diag, k, k, cone, a( 0 ), n+1,a( k+1 ), n+1 & + call stdlib_${ci}$trmm( 'L', 'U', 'C', diag, k, k, cone, a( 0 ), n+1,a( k+1 ), n+1 & ) else ! srpa for upper, normal, and n is even ( a(0:n,0:k-1) ) ! t1 -> a(k+1,0) , t2 -> a(k,0), s -> a(0,0) ! t1 -> a(k+1), t2 -> a(k), s -> a(0) - call stdlib_wtrtri( 'L', diag, k, a( k+1 ), n+1, info ) + call stdlib_${ci}$trtri( 'L', diag, k, a( k+1 ), n+1, info ) if( info>0 )return - call stdlib_wtrmm( 'L', 'L', 'C', diag, k, k, -cone, a( k+1 ),n+1, a( 0 ), n+& + call stdlib_${ci}$trmm( 'L', 'L', 'C', diag, k, k, -cone, a( k+1 ),n+1, a( 0 ), n+& 1 ) - call stdlib_wtrtri( 'U', diag, k, a( k ), n+1, info ) + call stdlib_${ci}$trtri( 'U', diag, k, a( k ), n+1, info ) if( info>0 )info = info + k if( info>0 )return - call stdlib_wtrmm( 'R', 'U', 'N', diag, k, k, cone, a( k ), n+1,a( 0 ), n+1 ) + call stdlib_${ci}$trmm( 'R', 'U', 'N', diag, k, k, cone, a( k ), n+1,a( 0 ), n+1 ) end if else @@ -69661,36 +69663,36 @@ module stdlib_linalg_lapack_w ! srpa for lower, transpose and n is even (see paper) ! t1 -> b(0,1), t2 -> b(0,0), s -> b(0,k+1) ! t1 -> a(0+k), t2 -> a(0+0), s -> a(0+k*(k+1)); lda=k - call stdlib_wtrtri( 'U', diag, k, a( k ), k, info ) + call stdlib_${ci}$trtri( 'U', diag, k, a( k ), k, info ) if( info>0 )return - call stdlib_wtrmm( 'L', 'U', 'N', diag, k, k, -cone, a( k ), k,a( k*( k+1 ) ),& + call stdlib_${ci}$trmm( 'L', 'U', 'N', diag, k, k, -cone, a( k ), k,a( k*( k+1 ) ),& k ) - call stdlib_wtrtri( 'L', diag, k, a( 0 ), k, info ) + call stdlib_${ci}$trtri( 'L', diag, k, a( 0 ), k, info ) if( info>0 )info = info + k if( info>0 )return - call stdlib_wtrmm( 'R', 'L', 'C', diag, k, k, cone, a( 0 ), k,a( k*( k+1 ) ), & + call stdlib_${ci}$trmm( 'R', 'L', 'C', diag, k, k, cone, a( 0 ), k,a( k*( k+1 ) ), & k ) else ! srpa for upper, transpose and n is even (see paper) ! t1 -> b(0,k+1), t2 -> b(0,k), s -> b(0,0) ! t1 -> a(0+k*(k+1)), t2 -> a(0+k*k), s -> a(0+0)); lda=k - call stdlib_wtrtri( 'U', diag, k, a( k*( k+1 ) ), k, info ) + call stdlib_${ci}$trtri( 'U', diag, k, a( k*( k+1 ) ), k, info ) if( info>0 )return - call stdlib_wtrmm( 'R', 'U', 'C', diag, k, k, -cone,a( k*( k+1 ) ), k, a( 0 ),& + call stdlib_${ci}$trmm( 'R', 'U', 'C', diag, k, k, -cone,a( k*( k+1 ) ), k, a( 0 ),& k ) - call stdlib_wtrtri( 'L', diag, k, a( k*k ), k, info ) + call stdlib_${ci}$trtri( 'L', diag, k, a( k*k ), k, info ) if( info>0 )info = info + k if( info>0 )return - call stdlib_wtrmm( 'L', 'L', 'N', diag, k, k, cone, a( k*k ), k,a( 0 ), k ) + call stdlib_${ci}$trmm( 'L', 'L', 'N', diag, k, k, cone, a( k*k ), k,a( 0 ), k ) end if end if end if return - end subroutine stdlib_wtftri + end subroutine stdlib_${ci}$tftri - pure subroutine stdlib_wtfttp( transr, uplo, n, arf, ap, info ) + pure subroutine stdlib_${ci}$tfttp( transr, uplo, n, arf, ap, info ) !! ZTFTTP: copies a triangular matrix A from rectangular full packed !! format (TF) to standard packed format (TP). ! -- lapack computational routine -- @@ -69701,8 +69703,8 @@ module stdlib_linalg_lapack_w integer(ilp), intent(out) :: info integer(ilp), intent(in) :: n ! Array Arguments - complex(qp), intent(out) :: ap(0:*) - complex(qp), intent(in) :: arf(0:*) + complex(${ck}$), intent(out) :: ap(0:*) + complex(${ck}$), intent(in) :: arf(0:*) ! ===================================================================== ! Parameters ! Local Scalars @@ -69946,10 +69948,10 @@ module stdlib_linalg_lapack_w end if end if return - end subroutine stdlib_wtfttp + end subroutine stdlib_${ci}$tfttp - pure subroutine stdlib_wtfttr( transr, uplo, n, arf, a, lda, info ) + pure subroutine stdlib_${ci}$tfttr( transr, uplo, n, arf, a, lda, info ) !! ZTFTTR: copies a triangular matrix A from rectangular full packed !! format (TF) to standard full format (TR). ! -- lapack computational routine -- @@ -69960,8 +69962,8 @@ module stdlib_linalg_lapack_w integer(ilp), intent(out) :: info integer(ilp), intent(in) :: n, lda ! Array Arguments - complex(qp), intent(out) :: a(0:lda-1,0:*) - complex(qp), intent(in) :: arf(0:*) + complex(${ck}$), intent(out) :: a(0:lda-1,0:*) + complex(${ck}$), intent(in) :: arf(0:*) ! ===================================================================== ! Parameters ! Local Scalars @@ -70196,10 +70198,10 @@ module stdlib_linalg_lapack_w end if end if return - end subroutine stdlib_wtfttr + end subroutine stdlib_${ci}$tfttr - pure subroutine stdlib_wtgevc( side, howmny, select, n, s, lds, p, ldp, vl,ldvl, vr, ldvr, & + pure subroutine stdlib_${ci}$tgevc( side, howmny, select, n, s, lds, p, ldp, vl,ldvl, vr, ldvr, & !! ZTGEVC: computes some or all of the right and/or left eigenvectors of !! a pair of complex matrices (S,P), where S and P are upper triangular. !! Matrix pairs of this type are produced by the generalized Schur @@ -70228,25 +70230,25 @@ module stdlib_linalg_lapack_w integer(ilp), intent(in) :: ldp, lds, ldvl, ldvr, mm, n ! Array Arguments logical(lk), intent(in) :: select(*) - real(qp), intent(out) :: rwork(*) - complex(qp), intent(in) :: p(ldp,*), s(lds,*) - complex(qp), intent(inout) :: vl(ldvl,*), vr(ldvr,*) - complex(qp), intent(out) :: work(*) + real(${ck}$), intent(out) :: rwork(*) + complex(${ck}$), intent(in) :: p(ldp,*), s(lds,*) + complex(${ck}$), intent(inout) :: vl(ldvl,*), vr(ldvr,*) + complex(${ck}$), intent(out) :: work(*) ! ===================================================================== ! Local Scalars logical(lk) :: compl, compr, ilall, ilback, ilbbad, ilcomp, lsa, lsb integer(ilp) :: i, ibeg, ieig, iend, ihwmny, im, iside, isrc, j, je, jr - real(qp) :: acoefa, acoeff, anorm, ascale, bcoefa, big, bignum, bnorm, bscale, dmin, & + real(${ck}$) :: acoefa, acoeff, anorm, ascale, bcoefa, big, bignum, bnorm, bscale, dmin, & safmin, sbeta, scale, small, temp, ulp, xmax - complex(qp) :: bcoeff, ca, cb, d, salpha, sum, suma, sumb, x + complex(${ck}$) :: bcoeff, ca, cb, d, salpha, sum, suma, sumb, x ! Intrinsic Functions intrinsic :: abs,real,cmplx,conjg,aimag,max,min ! Statement Functions - real(qp) :: abs1 + real(${ck}$) :: abs1 ! Statement Function Definitions - abs1( x ) = abs( real( x,KIND=qp) ) + abs( aimag( x ) ) + abs1( x ) = abs( real( x,KIND=${ck}$) ) + abs( aimag( x ) ) ! Executable Statements ! decode and test the input parameters if( stdlib_lsame( howmny, 'A' ) ) then @@ -70326,10 +70328,10 @@ module stdlib_linalg_lapack_w m = im if( n==0 )return ! machine constants - safmin = stdlib_qlamch( 'SAFE MINIMUM' ) + safmin = stdlib_${c2ri(ci)}$lamch( 'SAFE MINIMUM' ) big = one / safmin - call stdlib_qlabad( safmin, big ) - ulp = stdlib_qlamch( 'EPSILON' )*stdlib_qlamch( 'BASE' ) + call stdlib_${c2ri(ci)}$labad( safmin, big ) + ulp = stdlib_${c2ri(ci)}$lamch( 'EPSILON' )*stdlib_${c2ri(ci)}$lamch( 'BASE' ) small = safmin*n / ulp big = one / small bignum = one / ( safmin*n ) @@ -70364,7 +70366,7 @@ module stdlib_linalg_lapack_w end if if( ilcomp ) then ieig = ieig + 1 - if( abs1( s( je, je ) )<=safmin .and.abs( real( p( je, je ),KIND=qp) )& + if( abs1( s( je, je ) )<=safmin .and.abs( real( p( je, je ),KIND=${ck}$) )& <=safmin ) then ! singular matrix pencil -- return unit eigenvector do jr = 1, n @@ -70377,10 +70379,10 @@ module stdlib_linalg_lapack_w ! compute coefficients a and b in ! h ! y ( a a - b b ) = 0 - temp = one / max( abs1( s( je, je ) )*ascale,abs( real( p( je, je ),KIND=qp) )& + temp = one / max( abs1( s( je, je ) )*ascale,abs( real( p( je, je ),KIND=${ck}$) )& *bscale, safmin ) salpha = ( temp*s( je, je ) )*ascale - sbeta = ( temp*real( p( je, je ),KIND=qp) )*bscale + sbeta = ( temp*real( p( je, je ),KIND=${ck}$) )*bscale acoeff = sbeta*ascale bcoeff = salpha*bscale ! scale to avoid underflow @@ -70439,7 +70441,7 @@ module stdlib_linalg_lapack_w ! form x(j) = - sum / conjg( a*s(j,j) - b*p(j,j) ) ! with scaling and perturbation of the denominator d = conjg( acoeff*s( j, j )-bcoeff*p( j, j ) ) - if( abs1( d )<=dmin )d = cmplx( dmin,KIND=qp) + if( abs1( d )<=dmin )d = cmplx( dmin,KIND=${ck}$) if( abs1( d )=bignum*abs1( d ) ) then temp = one / abs1( sum ) @@ -70450,12 +70452,12 @@ module stdlib_linalg_lapack_w sum = temp*sum end if end if - work( j ) = stdlib_wladiv( -sum, d ) + work( j ) = stdlib_${ci}$ladiv( -sum, d ) xmax = max( xmax, abs1( work( j ) ) ) end do loop_100 ! back transform eigenvector if howmny='b'. if( ilback ) then - call stdlib_wgemv( 'N', n, n+1-je, cone, vl( 1, je ), ldvl,work( je ), 1, & + call stdlib_${ci}$gemv( 'N', n, n+1-je, cone, vl( 1, je ), ldvl,work( je ), 1, & czero, work( n+1 ), 1 ) isrc = 2 ibeg = 1 @@ -70494,7 +70496,7 @@ module stdlib_linalg_lapack_w end if if( ilcomp ) then ieig = ieig - 1 - if( abs1( s( je, je ) )<=safmin .and.abs( real( p( je, je ),KIND=qp) )& + if( abs1( s( je, je ) )<=safmin .and.abs( real( p( je, je ),KIND=${ck}$) )& <=safmin ) then ! singular matrix pencil -- return unit eigenvector do jr = 1, n @@ -70506,10 +70508,10 @@ module stdlib_linalg_lapack_w ! non-singular eigenvalue: ! compute coefficients a and b in ! ( a a - b b ) x = 0 - temp = one / max( abs1( s( je, je ) )*ascale,abs( real( p( je, je ),KIND=qp) )& + temp = one / max( abs1( s( je, je ) )*ascale,abs( real( p( je, je ),KIND=${ck}$) )& *bscale, safmin ) salpha = ( temp*s( je, je ) )*ascale - sbeta = ( temp*real( p( je, je ),KIND=qp) )*bscale + sbeta = ( temp*real( p( je, je ),KIND=${ck}$) )*bscale acoeff = sbeta*ascale bcoeff = salpha*bscale ! scale to avoid underflow @@ -70552,7 +70554,7 @@ module stdlib_linalg_lapack_w ! form x(j) := - w(j) / d ! with scaling and perturbation of the denominator d = acoeff*s( j, j ) - bcoeff*p( j, j ) - if( abs1( d )<=dmin )d = cmplx( dmin,KIND=qp) + if( abs1( d )<=dmin )d = cmplx( dmin,KIND=${ck}$) if( abs1( d )=bignum*abs1( d ) ) then temp = one / abs1( work( j ) ) @@ -70561,7 +70563,7 @@ module stdlib_linalg_lapack_w end do end if end if - work( j ) = stdlib_wladiv( -work( j ), d ) + work( j ) = stdlib_${ci}$ladiv( -work( j ), d ) if( j>1 ) then ! w = w + x(j)*(a s(*,j) - b p(*,j) ) with scaling if( abs1( work( j ) )>one ) then @@ -70581,7 +70583,7 @@ module stdlib_linalg_lapack_w end do loop_210 ! back transform eigenvector if howmny='b'. if( ilback ) then - call stdlib_wgemv( 'N', n, je, cone, vr, ldvr, work, 1,czero, work( n+1 ), & + call stdlib_${ci}$gemv( 'N', n, je, cone, vr, ldvr, work, 1,czero, work( n+1 ), & 1 ) isrc = 2 iend = n @@ -70609,10 +70611,10 @@ module stdlib_linalg_lapack_w end do loop_250 end if return - end subroutine stdlib_wtgevc + end subroutine stdlib_${ci}$tgevc - pure subroutine stdlib_wtgex2( wantq, wantz, n, a, lda, b, ldb, q, ldq, z,ldz, j1, info ) + pure subroutine stdlib_${ci}$tgex2( wantq, wantz, n, a, lda, b, ldb, q, ldq, z,ldz, j1, info ) !! ZTGEX2: swaps adjacent diagonal 1 by 1 blocks (A11,B11) and (A22,B22) !! in an upper triangular matrix pair (A, B) by an unitary equivalence !! transformation. @@ -70631,10 +70633,10 @@ module stdlib_linalg_lapack_w integer(ilp), intent(out) :: info integer(ilp), intent(in) :: j1, lda, ldb, ldq, ldz, n ! Array Arguments - complex(qp), intent(inout) :: a(lda,*), b(ldb,*), q(ldq,*), z(ldz,*) + complex(${ck}$), intent(inout) :: a(lda,*), b(ldb,*), q(ldq,*), z(ldz,*) ! ===================================================================== ! Parameters - real(qp), parameter :: twenty = 2.0e+1_qp + real(${ck}$), parameter :: twenty = 2.0e+1_${ck}$ integer(ilp), parameter :: ldst = 2 logical(lk), parameter :: wands = .true. @@ -70644,10 +70646,10 @@ module stdlib_linalg_lapack_w ! Local Scalars logical(lk) :: strong, weak integer(ilp) :: i, m - real(qp) :: cq, cz, eps, sa, sb, scale, smlnum, sum, thresha, threshb - complex(qp) :: cdum, f, g, sq, sz + real(${ck}$) :: cq, cz, eps, sa, sb, scale, smlnum, sum, thresha, threshb + complex(${ck}$) :: cdum, f, g, sq, sz ! Local Arrays - complex(qp) :: s(ldst,ldst), t(ldst,ldst), work(8) + complex(${ck}$) :: s(ldst,ldst), t(ldst,ldst), work(8) ! Intrinsic Functions intrinsic :: abs,real,conjg,max,sqrt ! Executable Statements @@ -70658,20 +70660,20 @@ module stdlib_linalg_lapack_w weak = .false. strong = .false. ! make a local copy of selected block in (a, b) - call stdlib_wlacpy( 'FULL', m, m, a( j1, j1 ), lda, s, ldst ) - call stdlib_wlacpy( 'FULL', m, m, b( j1, j1 ), ldb, t, ldst ) + call stdlib_${ci}$lacpy( 'FULL', m, m, a( j1, j1 ), lda, s, ldst ) + call stdlib_${ci}$lacpy( 'FULL', m, m, b( j1, j1 ), ldb, t, ldst ) ! compute the threshold for testing the acceptance of swapping. - eps = stdlib_qlamch( 'P' ) - smlnum = stdlib_qlamch( 'S' ) / eps - scale = real( czero,KIND=qp) - sum = real( cone,KIND=qp) - call stdlib_wlacpy( 'FULL', m, m, s, ldst, work, m ) - call stdlib_wlacpy( 'FULL', m, m, t, ldst, work( m*m+1 ), m ) - call stdlib_wlassq( m*m, work, 1, scale, sum ) + eps = stdlib_${c2ri(ci)}$lamch( 'P' ) + smlnum = stdlib_${c2ri(ci)}$lamch( 'S' ) / eps + scale = real( czero,KIND=${ck}$) + sum = real( cone,KIND=${ck}$) + call stdlib_${ci}$lacpy( 'FULL', m, m, s, ldst, work, m ) + call stdlib_${ci}$lacpy( 'FULL', m, m, t, ldst, work( m*m+1 ), m ) + call stdlib_${ci}$lassq( m*m, work, 1, scale, sum ) sa = scale*sqrt( sum ) - scale = real( czero,KIND=qp) - sum = real( cone,KIND=qp) - call stdlib_wlassq( m*m, work(m*m+1), 1, scale, sum ) + scale = real( czero,KIND=${ck}$) + sum = real( cone,KIND=${ck}$) + call stdlib_${ci}$lassq( m*m, work(m*m+1), 1, scale, sum ) sb = scale*sqrt( sum ) ! thres has been changed from ! thresh = max( ten*eps*sa, smlnum ) @@ -70688,17 +70690,17 @@ module stdlib_linalg_lapack_w g = s( 2, 2 )*t( 1, 2 ) - t( 2, 2 )*s( 1, 2 ) sa = abs( s( 2, 2 ) ) * abs( t( 1, 1 ) ) sb = abs( s( 1, 1 ) ) * abs( t( 2, 2 ) ) - call stdlib_wlartg( g, f, cz, sz, cdum ) + call stdlib_${ci}$lartg( g, f, cz, sz, cdum ) sz = -sz - call stdlib_wrot( 2, s( 1, 1 ), 1, s( 1, 2 ), 1, cz, conjg( sz ) ) - call stdlib_wrot( 2, t( 1, 1 ), 1, t( 1, 2 ), 1, cz, conjg( sz ) ) + call stdlib_${ci}$rot( 2, s( 1, 1 ), 1, s( 1, 2 ), 1, cz, conjg( sz ) ) + call stdlib_${ci}$rot( 2, t( 1, 1 ), 1, t( 1, 2 ), 1, cz, conjg( sz ) ) if( sa>=sb ) then - call stdlib_wlartg( s( 1, 1 ), s( 2, 1 ), cq, sq, cdum ) + call stdlib_${ci}$lartg( s( 1, 1 ), s( 2, 1 ), cq, sq, cdum ) else - call stdlib_wlartg( t( 1, 1 ), t( 2, 1 ), cq, sq, cdum ) + call stdlib_${ci}$lartg( t( 1, 1 ), t( 2, 1 ), cq, sq, cdum ) end if - call stdlib_wrot( 2, s( 1, 1 ), ldst, s( 2, 1 ), ldst, cq, sq ) - call stdlib_wrot( 2, t( 1, 1 ), ldst, t( 2, 1 ), ldst, cq, sq ) + call stdlib_${ci}$rot( 2, s( 1, 1 ), ldst, s( 2, 1 ), ldst, cq, sq ) + call stdlib_${ci}$rot( 2, t( 1, 1 ), ldst, t( 2, 1 ), ldst, cq, sq ) ! weak stability test: |s21| <= o(eps f-norm((a))) ! and |t21| <= o(eps f-norm((b))) weak = abs( s( 2, 1 ) )<=thresha .and.abs( t( 2, 1 ) )<=threshb @@ -70708,42 +70710,42 @@ module stdlib_linalg_lapack_w ! f-norm((a-ql**h*s*qr)) <= o(eps*f-norm((a))) ! and ! f-norm((b-ql**h*t*qr)) <= o(eps*f-norm((b))) - call stdlib_wlacpy( 'FULL', m, m, s, ldst, work, m ) - call stdlib_wlacpy( 'FULL', m, m, t, ldst, work( m*m+1 ), m ) - call stdlib_wrot( 2, work, 1, work( 3 ), 1, cz, -conjg( sz ) ) - call stdlib_wrot( 2, work( 5 ), 1, work( 7 ), 1, cz, -conjg( sz ) ) - call stdlib_wrot( 2, work, 2, work( 2 ), 2, cq, -sq ) - call stdlib_wrot( 2, work( 5 ), 2, work( 6 ), 2, cq, -sq ) + call stdlib_${ci}$lacpy( 'FULL', m, m, s, ldst, work, m ) + call stdlib_${ci}$lacpy( 'FULL', m, m, t, ldst, work( m*m+1 ), m ) + call stdlib_${ci}$rot( 2, work, 1, work( 3 ), 1, cz, -conjg( sz ) ) + call stdlib_${ci}$rot( 2, work( 5 ), 1, work( 7 ), 1, cz, -conjg( sz ) ) + call stdlib_${ci}$rot( 2, work, 2, work( 2 ), 2, cq, -sq ) + call stdlib_${ci}$rot( 2, work( 5 ), 2, work( 6 ), 2, cq, -sq ) do i = 1, 2 work( i ) = work( i ) - a( j1+i-1, j1 ) work( i+2 ) = work( i+2 ) - a( j1+i-1, j1+1 ) work( i+4 ) = work( i+4 ) - b( j1+i-1, j1 ) work( i+6 ) = work( i+6 ) - b( j1+i-1, j1+1 ) end do - scale = real( czero,KIND=qp) - sum = real( cone,KIND=qp) - call stdlib_wlassq( m*m, work, 1, scale, sum ) + scale = real( czero,KIND=${ck}$) + sum = real( cone,KIND=${ck}$) + call stdlib_${ci}$lassq( m*m, work, 1, scale, sum ) sa = scale*sqrt( sum ) - scale = real( czero,KIND=qp) - sum = real( cone,KIND=qp) - call stdlib_wlassq( m*m, work(m*m+1), 1, scale, sum ) + scale = real( czero,KIND=${ck}$) + sum = real( cone,KIND=${ck}$) + call stdlib_${ci}$lassq( m*m, work(m*m+1), 1, scale, sum ) sb = scale*sqrt( sum ) strong = sa<=thresha .and. sb<=threshb if( .not.strong )go to 20 end if ! if the swap is accepted ("weakly" and "strongly"), apply the ! equivalence transformations to the original matrix pair (a,b) - call stdlib_wrot( j1+1, a( 1, j1 ), 1, a( 1, j1+1 ), 1, cz,conjg( sz ) ) - call stdlib_wrot( j1+1, b( 1, j1 ), 1, b( 1, j1+1 ), 1, cz,conjg( sz ) ) - call stdlib_wrot( n-j1+1, a( j1, j1 ), lda, a( j1+1, j1 ), lda, cq, sq ) - call stdlib_wrot( n-j1+1, b( j1, j1 ), ldb, b( j1+1, j1 ), ldb, cq, sq ) + call stdlib_${ci}$rot( j1+1, a( 1, j1 ), 1, a( 1, j1+1 ), 1, cz,conjg( sz ) ) + call stdlib_${ci}$rot( j1+1, b( 1, j1 ), 1, b( 1, j1+1 ), 1, cz,conjg( sz ) ) + call stdlib_${ci}$rot( n-j1+1, a( j1, j1 ), lda, a( j1+1, j1 ), lda, cq, sq ) + call stdlib_${ci}$rot( n-j1+1, b( j1, j1 ), ldb, b( j1+1, j1 ), ldb, cq, sq ) ! set n1 by n2 (2,1) blocks to 0 a( j1+1, j1 ) = czero b( j1+1, j1 ) = czero ! accumulate transformations into q and z if requested. - if( wantz )call stdlib_wrot( n, z( 1, j1 ), 1, z( 1, j1+1 ), 1, cz,conjg( sz ) ) + if( wantz )call stdlib_${ci}$rot( n, z( 1, j1 ), 1, z( 1, j1+1 ), 1, cz,conjg( sz ) ) - if( wantq )call stdlib_wrot( n, q( 1, j1 ), 1, q( 1, j1+1 ), 1, cq,conjg( sq ) ) + if( wantq )call stdlib_${ci}$rot( n, q( 1, j1 ), 1, q( 1, j1+1 ), 1, cq,conjg( sq ) ) ! exit with info = 0 if swap was successfully performed. return @@ -70751,10 +70753,10 @@ module stdlib_linalg_lapack_w 20 continue info = 1 return - end subroutine stdlib_wtgex2 + end subroutine stdlib_${ci}$tgex2 - pure subroutine stdlib_wtgexc( wantq, wantz, n, a, lda, b, ldb, q, ldq, z,ldz, ifst, ilst, & + pure subroutine stdlib_${ci}$tgexc( wantq, wantz, n, a, lda, b, ldb, q, ldq, z,ldz, ifst, ilst, & !! ZTGEXC: reorders the generalized Schur decomposition of a complex !! matrix pair (A,B), using an unitary equivalence transformation !! (A, B) := Q * (A, B) * Z**H, so that the diagonal block of (A, B) with @@ -70775,7 +70777,7 @@ module stdlib_linalg_lapack_w integer(ilp), intent(inout) :: ilst integer(ilp), intent(out) :: info ! Array Arguments - complex(qp), intent(inout) :: a(lda,*), b(ldb,*), q(ldq,*), z(ldz,*) + complex(${ck}$), intent(inout) :: a(lda,*), b(ldb,*), q(ldq,*), z(ldz,*) ! ===================================================================== ! Local Scalars integer(ilp) :: here @@ -70810,7 +70812,7 @@ module stdlib_linalg_lapack_w here = ifst 10 continue ! swap with next one below - call stdlib_wtgex2( wantq, wantz, n, a, lda, b, ldb, q, ldq, z, ldz,here, info ) + call stdlib_${ci}$tgex2( wantq, wantz, n, a, lda, b, ldb, q, ldq, z, ldz,here, info ) if( info/=0 ) then ilst = here @@ -70823,7 +70825,7 @@ module stdlib_linalg_lapack_w here = ifst - 1 20 continue ! swap with next one above - call stdlib_wtgex2( wantq, wantz, n, a, lda, b, ldb, q, ldq, z, ldz,here, info ) + call stdlib_${ci}$tgex2( wantq, wantz, n, a, lda, b, ldb, q, ldq, z, ldz,here, info ) if( info/=0 ) then ilst = here @@ -70835,10 +70837,10 @@ module stdlib_linalg_lapack_w end if ilst = here return - end subroutine stdlib_wtgexc + end subroutine stdlib_${ci}$tgexc - pure subroutine stdlib_wtgsen( ijob, wantq, wantz, select, n, a, lda, b, ldb,alpha, beta, q, & + pure subroutine stdlib_${ci}$tgsen( ijob, wantq, wantz, select, n, a, lda, b, ldb,alpha, beta, q, & !! ZTGSEN: reorders the generalized Schur decomposition of a complex !! matrix pair (A, B) (in terms of an unitary equivalence trans- !! formation Q**H * (A, B) * Z), so that a selected cluster of eigenvalues @@ -70865,13 +70867,13 @@ module stdlib_linalg_lapack_w logical(lk), intent(in) :: wantq, wantz integer(ilp), intent(in) :: ijob, lda, ldb, ldq, ldz, liwork, lwork, n integer(ilp), intent(out) :: info, m - real(qp), intent(out) :: pl, pr + real(${ck}$), intent(out) :: pl, pr ! Array Arguments logical(lk), intent(in) :: select(*) integer(ilp), intent(out) :: iwork(*) - real(qp), intent(out) :: dif(*) - complex(qp), intent(inout) :: a(lda,*), b(ldb,*), q(ldq,*), z(ldz,*) - complex(qp), intent(out) :: alpha(*), beta(*), work(*) + real(${ck}$), intent(out) :: dif(*) + complex(${ck}$), intent(inout) :: a(lda,*), b(ldb,*), q(ldq,*), z(ldz,*) + complex(${ck}$), intent(out) :: alpha(*), beta(*), work(*) ! ===================================================================== ! Parameters integer(ilp), parameter :: idifjb = 3 @@ -70880,8 +70882,8 @@ module stdlib_linalg_lapack_w ! Local Scalars logical(lk) :: lquery, swap, wantd, wantd1, wantd2, wantp integer(ilp) :: i, ierr, ijb, k, kase, ks, liwmin, lwmin, mn2, n1, n2 - real(qp) :: dscale, dsum, rdscal, safmin - complex(qp) :: temp1, temp2 + real(${ck}$) :: dscale, dsum, rdscal, safmin + complex(${ck}$) :: temp1, temp2 ! Local Arrays integer(ilp) :: isave(3) ! Intrinsic Functions @@ -70959,8 +70961,8 @@ module stdlib_linalg_lapack_w dscale = zero dsum = one do i = 1, n - call stdlib_wlassq( n, a( 1, i ), 1, dscale, dsum ) - call stdlib_wlassq( n, b( 1, i ), 1, dscale, dsum ) + call stdlib_${ci}$lassq( n, a( 1, i ), 1, dscale, dsum ) + call stdlib_${ci}$lassq( n, b( 1, i ), 1, dscale, dsum ) end do dif( 1 ) = dscale*sqrt( dsum ) dif( 2 ) = dif( 1 ) @@ -70968,7 +70970,7 @@ module stdlib_linalg_lapack_w go to 70 end if ! get machine constant - safmin = stdlib_qlamch( 'S' ) + safmin = stdlib_${c2ri(ci)}$lamch( 'S' ) ! collect the selected blocks at the top-left corner of (a, b). ks = 0 do k = 1, n @@ -70977,7 +70979,7 @@ module stdlib_linalg_lapack_w ks = ks + 1 ! swap the k-th block to position ks. compute unitary q ! and z that will swap adjacent diagonal blocks in (a, b). - if( k/=ks )call stdlib_wtgexc( wantq, wantz, n, a, lda, b, ldb, q, ldq, z,ldz, k,& + if( k/=ks )call stdlib_${ci}$tgexc( wantq, wantz, n, a, lda, b, ldb, q, ldq, z,ldz, k,& ks, ierr ) if( ierr>0 ) then ! swap is rejected: exit. @@ -71001,17 +71003,17 @@ module stdlib_linalg_lapack_w n1 = m n2 = n - m i = n1 + 1 - call stdlib_wlacpy( 'FULL', n1, n2, a( 1, i ), lda, work, n1 ) - call stdlib_wlacpy( 'FULL', n1, n2, b( 1, i ), ldb, work( n1*n2+1 ),n1 ) + call stdlib_${ci}$lacpy( 'FULL', n1, n2, a( 1, i ), lda, work, n1 ) + call stdlib_${ci}$lacpy( 'FULL', n1, n2, b( 1, i ), ldb, work( n1*n2+1 ),n1 ) ijb = 0 - call stdlib_wtgsyl( 'N', ijb, n1, n2, a, lda, a( i, i ), lda, work,n1, b, ldb, b( i,& + call stdlib_${ci}$tgsyl( 'N', ijb, n1, n2, a, lda, a( i, i ), lda, work,n1, b, ldb, b( i,& i ), ldb, work( n1*n2+1 ), n1,dscale, dif( 1 ), work( n1*n2*2+1 ),lwork-2*n1*n2, & iwork, ierr ) ! estimate the reciprocal of norms of "projections" onto ! left and right eigenspaces rdscal = zero dsum = one - call stdlib_wlassq( n1*n2, work, 1, rdscal, dsum ) + call stdlib_${ci}$lassq( n1*n2, work, 1, rdscal, dsum ) pl = rdscal*sqrt( dsum ) if( pl==zero ) then pl = one @@ -71020,7 +71022,7 @@ module stdlib_linalg_lapack_w end if rdscal = zero dsum = one - call stdlib_wlassq( n1*n2, work( n1*n2+1 ), 1, rdscal, dsum ) + call stdlib_${ci}$lassq( n1*n2, work( n1*n2+1 ), 1, rdscal, dsum ) pr = rdscal*sqrt( dsum ) if( pr==zero ) then pr = one @@ -71036,16 +71038,16 @@ module stdlib_linalg_lapack_w i = n1 + 1 ijb = idifjb ! frobenius norm-based difu estimate. - call stdlib_wtgsyl( 'N', ijb, n1, n2, a, lda, a( i, i ), lda, work,n1, b, ldb, b(& + call stdlib_${ci}$tgsyl( 'N', ijb, n1, n2, a, lda, a( i, i ), lda, work,n1, b, ldb, b(& i, i ), ldb, work( n1*n2+1 ),n1, dscale, dif( 1 ), work( n1*n2*2+1 ),lwork-& 2*n1*n2, iwork, ierr ) ! frobenius norm-based difl estimate. - call stdlib_wtgsyl( 'N', ijb, n2, n1, a( i, i ), lda, a, lda, work,n2, b( i, i ),& + call stdlib_${ci}$tgsyl( 'N', ijb, n2, n1, a( i, i ), lda, a, lda, work,n2, b( i, i ),& ldb, b, ldb, work( n1*n2+1 ),n2, dscale, dif( 2 ), work( n1*n2*2+1 ),lwork-& 2*n1*n2, iwork, ierr ) else ! compute 1-norm-based estimates of difu and difl using - ! reversed communication with stdlib_wlacn2. in each step a + ! reversed communication with stdlib_${ci}$lacn2. in each step a ! generalized sylvester equation or a transposed variant ! is solved. kase = 0 @@ -71056,16 +71058,16 @@ module stdlib_linalg_lapack_w mn2 = 2*n1*n2 ! 1-norm-based estimate of difu. 40 continue - call stdlib_wlacn2( mn2, work( mn2+1 ), work, dif( 1 ), kase,isave ) + call stdlib_${ci}$lacn2( mn2, work( mn2+1 ), work, dif( 1 ), kase,isave ) if( kase/=0 ) then if( kase==1 ) then ! solve generalized sylvester equation - call stdlib_wtgsyl( 'N', ijb, n1, n2, a, lda, a( i, i ), lda,work, n1, b, & + call stdlib_${ci}$tgsyl( 'N', ijb, n1, n2, a, lda, a( i, i ), lda,work, n1, b, & ldb, b( i, i ), ldb,work( n1*n2+1 ), n1, dscale, dif( 1 ),work( n1*n2*2+1 )& , lwork-2*n1*n2, iwork,ierr ) else ! solve the transposed variant. - call stdlib_wtgsyl( 'C', ijb, n1, n2, a, lda, a( i, i ), lda,work, n1, b, & + call stdlib_${ci}$tgsyl( 'C', ijb, n1, n2, a, lda, a( i, i ), lda,work, n1, b, & ldb, b( i, i ), ldb,work( n1*n2+1 ), n1, dscale, dif( 1 ),work( n1*n2*2+1 )& , lwork-2*n1*n2, iwork,ierr ) end if @@ -71074,16 +71076,16 @@ module stdlib_linalg_lapack_w dif( 1 ) = dscale / dif( 1 ) ! 1-norm-based estimate of difl. 50 continue - call stdlib_wlacn2( mn2, work( mn2+1 ), work, dif( 2 ), kase,isave ) + call stdlib_${ci}$lacn2( mn2, work( mn2+1 ), work, dif( 2 ), kase,isave ) if( kase/=0 ) then if( kase==1 ) then ! solve generalized sylvester equation - call stdlib_wtgsyl( 'N', ijb, n2, n1, a( i, i ), lda, a, lda,work, n2, b( & + call stdlib_${ci}$tgsyl( 'N', ijb, n2, n1, a( i, i ), lda, a, lda,work, n2, b( & i, i ), ldb, b, ldb,work( n1*n2+1 ), n2, dscale, dif( 2 ),work( n1*n2*2+1 )& , lwork-2*n1*n2, iwork,ierr ) else ! solve the transposed variant. - call stdlib_wtgsyl( 'C', ijb, n2, n1, a( i, i ), lda, a, lda,work, n2, b, & + call stdlib_${ci}$tgsyl( 'C', ijb, n2, n1, a( i, i ), lda, a, lda,work, n2, b, & ldb, b( i, i ), ldb,work( n1*n2+1 ), n2, dscale, dif( 2 ),work( n1*n2*2+1 )& , lwork-2*n1*n2, iwork,ierr ) end if @@ -71101,11 +71103,11 @@ module stdlib_linalg_lapack_w temp1 = conjg( b( k, k ) / dscale ) temp2 = b( k, k ) / dscale b( k, k ) = dscale - call stdlib_wscal( n-k, temp1, b( k, k+1 ), ldb ) - call stdlib_wscal( n-k+1, temp1, a( k, k ), lda ) - if( wantq )call stdlib_wscal( n, temp2, q( 1, k ), 1 ) + call stdlib_${ci}$scal( n-k, temp1, b( k, k+1 ), ldb ) + call stdlib_${ci}$scal( n-k+1, temp1, a( k, k ), lda ) + if( wantq )call stdlib_${ci}$scal( n, temp2, q( 1, k ), 1 ) else - b( k, k ) = cmplx( zero, zero,KIND=qp) + b( k, k ) = cmplx( zero, zero,KIND=${ck}$) end if alpha( k ) = a( k, k ) beta( k ) = b( k, k ) @@ -71114,10 +71116,10 @@ module stdlib_linalg_lapack_w work( 1 ) = lwmin iwork( 1 ) = liwmin return - end subroutine stdlib_wtgsen + end subroutine stdlib_${ci}$tgsen - pure subroutine stdlib_wtgsja( jobu, jobv, jobq, m, p, n, k, l, a, lda, b,ldb, tola, tolb, & + pure subroutine stdlib_${ci}$tgsja( jobu, jobv, jobq, m, p, n, k, l, a, lda, b,ldb, tola, tolb, & !! ZTGSJA: computes the generalized singular value decomposition (GSVD) !! of two complex upper triangular (or trapezoidal) matrices A and B. !! On entry, it is assumed that matrices A and B have the following @@ -71188,23 +71190,23 @@ module stdlib_linalg_lapack_w character, intent(in) :: jobq, jobu, jobv integer(ilp), intent(out) :: info, ncycle integer(ilp), intent(in) :: k, l, lda, ldb, ldq, ldu, ldv, m, n, p - real(qp), intent(in) :: tola, tolb + real(${ck}$), intent(in) :: tola, tolb ! Array Arguments - real(qp), intent(out) :: alpha(*), beta(*) - complex(qp), intent(inout) :: a(lda,*), b(ldb,*), q(ldq,*), u(ldu,*), v(ldv,*) - complex(qp), intent(out) :: work(*) + real(${ck}$), intent(out) :: alpha(*), beta(*) + complex(${ck}$), intent(inout) :: a(lda,*), b(ldb,*), q(ldq,*), u(ldu,*), v(ldv,*) + complex(${ck}$), intent(out) :: work(*) ! ===================================================================== ! Parameters integer(ilp), parameter :: maxit = 40 - real(qp), parameter :: hugenum = huge(zero) + real(${ck}$), parameter :: hugenum = huge(zero) ! Local Scalars logical(lk) :: initq, initu, initv, upper, wantq, wantu, wantv integer(ilp) :: i, j, kcycle - real(qp) :: a1, a3, b1, b3, csq, csu, csv, error, gamma, rwk, ssmin - complex(qp) :: a2, b2, snq, snu, snv + real(${ck}$) :: a1, a3, b1, b3, csq, csu, csv, error, gamma, rwk, ssmin + complex(${ck}$) :: a2, b2, snq, snu, snv ! Intrinsic Functions intrinsic :: abs,real,conjg,max,min,huge ! Executable Statements @@ -71244,9 +71246,9 @@ module stdlib_linalg_lapack_w return end if ! initialize u, v and q, if necessary - if( initu )call stdlib_wlaset( 'FULL', m, m, czero, cone, u, ldu ) - if( initv )call stdlib_wlaset( 'FULL', p, p, czero, cone, v, ldv ) - if( initq )call stdlib_wlaset( 'FULL', n, n, czero, cone, q, ldq ) + if( initu )call stdlib_${ci}$laset( 'FULL', m, m, czero, cone, u, ldu ) + if( initv )call stdlib_${ci}$laset( 'FULL', p, p, czero, cone, v, ldv ) + if( initq )call stdlib_${ci}$laset( 'FULL', n, n, czero, cone, q, ldq ) ! loop until convergence upper = .false. loop_40: do kcycle = 1, maxit @@ -71256,10 +71258,10 @@ module stdlib_linalg_lapack_w a1 = zero a2 = czero a3 = zero - if( k+i<=m )a1 = real( a( k+i, n-l+i ),KIND=qp) - if( k+j<=m )a3 = real( a( k+j, n-l+j ),KIND=qp) - b1 = real( b( i, n-l+i ),KIND=qp) - b3 = real( b( j, n-l+j ),KIND=qp) + if( k+i<=m )a1 = real( a( k+i, n-l+i ),KIND=${ck}$) + if( k+j<=m )a3 = real( a( k+j, n-l+j ),KIND=${ck}$) + b1 = real( b( i, n-l+i ),KIND=${ck}$) + b3 = real( b( j, n-l+j ),KIND=${ck}$) if( upper ) then if( k+i<=m )a2 = a( k+i, n-l+j ) b2 = b( i, n-l+j ) @@ -71267,19 +71269,19 @@ module stdlib_linalg_lapack_w if( k+j<=m )a2 = a( k+j, n-l+i ) b2 = b( j, n-l+i ) end if - call stdlib_wlags2( upper, a1, a2, a3, b1, b2, b3, csu, snu,csv, snv, csq, & + call stdlib_${ci}$lags2( upper, a1, a2, a3, b1, b2, b3, csu, snu,csv, snv, csq, & snq ) ! update (k+i)-th and (k+j)-th rows of matrix a: u**h *a - if( k+j<=m )call stdlib_wrot( l, a( k+j, n-l+1 ), lda, a( k+i, n-l+1 ),lda, & + if( k+j<=m )call stdlib_${ci}$rot( l, a( k+j, n-l+1 ), lda, a( k+i, n-l+1 ),lda, & csu, conjg( snu ) ) ! update i-th and j-th rows of matrix b: v**h *b - call stdlib_wrot( l, b( j, n-l+1 ), ldb, b( i, n-l+1 ), ldb,csv, conjg( snv ) & + call stdlib_${ci}$rot( l, b( j, n-l+1 ), ldb, b( i, n-l+1 ), ldb,csv, conjg( snv ) & ) ! update (n-l+i)-th and (n-l+j)-th columns of matrices ! a and b: a*q and b*q - call stdlib_wrot( min( k+l, m ), a( 1, n-l+j ), 1,a( 1, n-l+i ), 1, csq, snq ) + call stdlib_${ci}$rot( min( k+l, m ), a( 1, n-l+j ), 1,a( 1, n-l+i ), 1, csq, snq ) - call stdlib_wrot( l, b( 1, n-l+j ), 1, b( 1, n-l+i ), 1, csq,snq ) + call stdlib_${ci}$rot( l, b( 1, n-l+j ), 1, b( 1, n-l+i ), 1, csq,snq ) if( upper ) then if( k+i<=m )a( k+i, n-l+j ) = czero b( i, n-l+j ) = czero @@ -71288,15 +71290,15 @@ module stdlib_linalg_lapack_w b( j, n-l+i ) = czero end if ! ensure that the diagonal elements of a and b are real. - if( k+i<=m )a( k+i, n-l+i ) = real( a( k+i, n-l+i ),KIND=qp) - if( k+j<=m )a( k+j, n-l+j ) = real( a( k+j, n-l+j ),KIND=qp) - b( i, n-l+i ) = real( b( i, n-l+i ),KIND=qp) - b( j, n-l+j ) = real( b( j, n-l+j ),KIND=qp) + if( k+i<=m )a( k+i, n-l+i ) = real( a( k+i, n-l+i ),KIND=${ck}$) + if( k+j<=m )a( k+j, n-l+j ) = real( a( k+j, n-l+j ),KIND=${ck}$) + b( i, n-l+i ) = real( b( i, n-l+i ),KIND=${ck}$) + b( j, n-l+j ) = real( b( j, n-l+j ),KIND=${ck}$) ! update unitary matrices u, v, q, if desired. - if( wantu .and. k+j<=m )call stdlib_wrot( m, u( 1, k+j ), 1, u( 1, k+i ), 1, & + if( wantu .and. k+j<=m )call stdlib_${ci}$rot( m, u( 1, k+j ), 1, u( 1, k+i ), 1, & csu,snu ) - if( wantv )call stdlib_wrot( p, v( 1, j ), 1, v( 1, i ), 1, csv, snv ) - if( wantq )call stdlib_wrot( n, q( 1, n-l+j ), 1, q( 1, n-l+i ), 1, csq,snq ) + if( wantv )call stdlib_${ci}$rot( p, v( 1, j ), 1, v( 1, i ), 1, csv, snv ) + if( wantq )call stdlib_${ci}$rot( n, q( 1, n-l+j ), 1, q( 1, n-l+i ), 1, csq,snq ) end do loop_10 end do loop_20 @@ -71307,9 +71309,9 @@ module stdlib_linalg_lapack_w ! rows of a and b. error = zero do i = 1, min( l, m-k ) - call stdlib_wcopy( l-i+1, a( k+i, n-l+i ), lda, work, 1 ) - call stdlib_wcopy( l-i+1, b( i, n-l+i ), ldb, work( l+1 ), 1 ) - call stdlib_wlapll( l-i+1, work, 1, work( l+1 ), 1, ssmin ) + call stdlib_${ci}$copy( l-i+1, a( k+i, n-l+i ), lda, work, 1 ) + call stdlib_${ci}$copy( l-i+1, b( i, n-l+i ), ldb, work( l+1 ), 1 ) + call stdlib_${ci}$lapll( l-i+1, work, 1, work( l+1 ), 1, ssmin ) error = max( error, ssmin ) end do if( abs( error )<=min( tola, tolb ) )go to 50 @@ -71328,25 +71330,25 @@ module stdlib_linalg_lapack_w beta( i ) = zero end do do i = 1, min( l, m-k ) - a1 = real( a( k+i, n-l+i ),KIND=qp) - b1 = real( b( i, n-l+i ),KIND=qp) + a1 = real( a( k+i, n-l+i ),KIND=${ck}$) + b1 = real( b( i, n-l+i ),KIND=${ck}$) gamma = b1 / a1 if( (gamma<=hugenum).and.(gamma>=-hugenum) ) then if( gamma=beta( k+i ) ) then - call stdlib_wdscal( l-i+1, one / alpha( k+i ), a( k+i, n-l+i ),lda ) + call stdlib_${ci}$dscal( l-i+1, one / alpha( k+i ), a( k+i, n-l+i ),lda ) else - call stdlib_wdscal( l-i+1, one / beta( k+i ), b( i, n-l+i ),ldb ) - call stdlib_wcopy( l-i+1, b( i, n-l+i ), ldb, a( k+i, n-l+i ),lda ) + call stdlib_${ci}$dscal( l-i+1, one / beta( k+i ), b( i, n-l+i ),ldb ) + call stdlib_${ci}$copy( l-i+1, b( i, n-l+i ), ldb, a( k+i, n-l+i ),lda ) end if else alpha( k+i ) = zero beta( k+i ) = one - call stdlib_wcopy( l-i+1, b( i, n-l+i ), ldb, a( k+i, n-l+i ),lda ) + call stdlib_${ci}$copy( l-i+1, b( i, n-l+i ), ldb, a( k+i, n-l+i ),lda ) end if end do ! post-assignment @@ -71363,10 +71365,10 @@ module stdlib_linalg_lapack_w 100 continue ncycle = kcycle return - end subroutine stdlib_wtgsja + end subroutine stdlib_${ci}$tgsja - pure subroutine stdlib_wtgsna( job, howmny, select, n, a, lda, b, ldb, vl,ldvl, vr, ldvr, s, & + pure subroutine stdlib_${ci}$tgsna( job, howmny, select, n, a, lda, b, ldb, vl,ldvl, vr, ldvr, s, & !! ZTGSNA: estimates reciprocal condition numbers for specified !! eigenvalues and/or eigenvectors of a matrix pair (A, B). !! (A, B) must be in generalized Schur canonical form, that is, A and @@ -71382,9 +71384,9 @@ module stdlib_linalg_lapack_w ! Array Arguments logical(lk), intent(in) :: select(*) integer(ilp), intent(out) :: iwork(*) - real(qp), intent(out) :: dif(*), s(*) - complex(qp), intent(in) :: a(lda,*), b(ldb,*), vl(ldvl,*), vr(ldvr,*) - complex(qp), intent(out) :: work(*) + real(${ck}$), intent(out) :: dif(*), s(*) + complex(${ck}$), intent(in) :: a(lda,*), b(ldb,*), vl(ldvl,*), vr(ldvr,*) + complex(${ck}$), intent(out) :: work(*) ! ===================================================================== ! Parameters integer(ilp), parameter :: idifjb = 3 @@ -71393,10 +71395,10 @@ module stdlib_linalg_lapack_w ! Local Scalars logical(lk) :: lquery, somcon, wantbh, wantdf, wants integer(ilp) :: i, ierr, ifst, ilst, k, ks, lwmin, n1, n2 - real(qp) :: bignum, cond, eps, lnrm, rnrm, scale, smlnum - complex(qp) :: yhax, yhbx + real(${ck}$) :: bignum, cond, eps, lnrm, rnrm, scale, smlnum + complex(${ck}$) :: yhax, yhbx ! Local Arrays - complex(qp) :: dummy(1), dummy1(1) + complex(${ck}$) :: dummy(1), dummy1(1) ! Intrinsic Functions intrinsic :: abs,cmplx,max ! Executable Statements @@ -71455,10 +71457,10 @@ module stdlib_linalg_lapack_w ! quick return if possible if( n==0 )return ! get machine constants - eps = stdlib_qlamch( 'P' ) - smlnum = stdlib_qlamch( 'S' ) / eps + eps = stdlib_${c2ri(ci)}$lamch( 'P' ) + smlnum = stdlib_${c2ri(ci)}$lamch( 'S' ) / eps bignum = one / smlnum - call stdlib_qlabad( smlnum, bignum ) + call stdlib_${c2ri(ci)}$labad( smlnum, bignum ) ks = 0 loop_20: do k = 1, n ! determine whether condition numbers are required for the k-th @@ -71470,15 +71472,15 @@ module stdlib_linalg_lapack_w if( wants ) then ! compute the reciprocal condition number of the k-th ! eigenvalue. - rnrm = stdlib_qznrm2( n, vr( 1, ks ), 1 ) - lnrm = stdlib_qznrm2( n, vl( 1, ks ), 1 ) - call stdlib_wgemv( 'N', n, n, cmplx( one, zero,KIND=qp), a, lda,vr( 1, ks ), 1, & - cmplx( zero, zero,KIND=qp), work, 1 ) - yhax = stdlib_wdotc( n, work, 1, vl( 1, ks ), 1 ) - call stdlib_wgemv( 'N', n, n, cmplx( one, zero,KIND=qp), b, ldb,vr( 1, ks ), 1, & - cmplx( zero, zero,KIND=qp), work, 1 ) - yhbx = stdlib_wdotc( n, work, 1, vl( 1, ks ), 1 ) - cond = stdlib_qlapy2( abs( yhax ), abs( yhbx ) ) + rnrm = stdlib_${c2ri(ci)}$znrm2( n, vr( 1, ks ), 1 ) + lnrm = stdlib_${c2ri(ci)}$znrm2( n, vl( 1, ks ), 1 ) + call stdlib_${ci}$gemv( 'N', n, n, cmplx( one, zero,KIND=${ck}$), a, lda,vr( 1, ks ), 1, & + cmplx( zero, zero,KIND=${ck}$), work, 1 ) + yhax = stdlib_${ci}$dotc( n, work, 1, vl( 1, ks ), 1 ) + call stdlib_${ci}$gemv( 'N', n, n, cmplx( one, zero,KIND=${ck}$), b, ldb,vr( 1, ks ), 1, & + cmplx( zero, zero,KIND=${ck}$), work, 1 ) + yhbx = stdlib_${ci}$dotc( n, work, 1, vl( 1, ks ), 1 ) + cond = stdlib_${c2ri(ci)}$lapy2( abs( yhax ), abs( yhbx ) ) if( cond==zero ) then s( ks ) = -one else @@ -71487,17 +71489,17 @@ module stdlib_linalg_lapack_w end if if( wantdf ) then if( n==1 ) then - dif( ks ) = stdlib_qlapy2( abs( a( 1, 1 ) ), abs( b( 1, 1 ) ) ) + dif( ks ) = stdlib_${c2ri(ci)}$lapy2( abs( a( 1, 1 ) ), abs( b( 1, 1 ) ) ) else ! estimate the reciprocal condition number of the k-th ! eigenvectors. ! copy the matrix (a, b) to the array work and move the ! (k,k)th pair to the (1,1) position. - call stdlib_wlacpy( 'FULL', n, n, a, lda, work, n ) - call stdlib_wlacpy( 'FULL', n, n, b, ldb, work( n*n+1 ), n ) + call stdlib_${ci}$lacpy( 'FULL', n, n, a, lda, work, n ) + call stdlib_${ci}$lacpy( 'FULL', n, n, b, ldb, work( n*n+1 ), n ) ifst = k ilst = 1 - call stdlib_wtgexc( .false., .false., n, work, n, work( n*n+1 ),n, dummy, 1, & + call stdlib_${ci}$tgexc( .false., .false., n, work, n, work( n*n+1 ),n, dummy, 1, & dummy1, 1, ifst, ilst, ierr ) if( ierr>0 ) then ! ill-conditioned problem - swap rejected. @@ -71511,7 +71513,7 @@ module stdlib_linalg_lapack_w n1 = 1 n2 = n - n1 i = n*n + 1 - call stdlib_wtgsyl( 'N', idifjb, n2, n1, work( n*n1+n1+1 ),n, work, n, & + call stdlib_${ci}$tgsyl( 'N', idifjb, n2, n1, work( n*n1+n1+1 ),n, work, n, & work( n1+1 ), n,work( n*n1+n1+i ), n, work( i ), n,work( n1+i ), n, scale, & dif( ks ), dummy,1, iwork, ierr ) end if @@ -71520,10 +71522,10 @@ module stdlib_linalg_lapack_w end do loop_20 work( 1 ) = lwmin return - end subroutine stdlib_wtgsna + end subroutine stdlib_${ci}$tgsna - pure subroutine stdlib_wtgsy2( trans, ijob, m, n, a, lda, b, ldb, c, ldc, d,ldd, e, lde, f, & + pure subroutine stdlib_${ci}$tgsy2( trans, ijob, m, n, a, lda, b, ldb, c, ldc, d,ldd, e, lde, f, & !! ZTGSY2: solves the generalized Sylvester equation !! A * R - L * B = scale * C (1) !! D * R - L * E = scale * F @@ -71557,11 +71559,11 @@ module stdlib_linalg_lapack_w character, intent(in) :: trans integer(ilp), intent(in) :: ijob, lda, ldb, ldc, ldd, lde, ldf, m, n integer(ilp), intent(out) :: info - real(qp), intent(inout) :: rdscal, rdsum - real(qp), intent(out) :: scale + real(${ck}$), intent(inout) :: rdscal, rdsum + real(${ck}$), intent(out) :: scale ! Array Arguments - complex(qp), intent(in) :: a(lda,*), b(ldb,*), d(ldd,*), e(lde,*) - complex(qp), intent(inout) :: c(ldc,*), f(ldf,*) + complex(${ck}$), intent(in) :: a(lda,*), b(ldb,*), d(ldd,*), e(lde,*) + complex(${ck}$), intent(inout) :: c(ldc,*), f(ldf,*) ! ===================================================================== ! Parameters integer(ilp), parameter :: ldz = 2 @@ -71570,11 +71572,11 @@ module stdlib_linalg_lapack_w ! Local Scalars logical(lk) :: notran integer(ilp) :: i, ierr, j, k - real(qp) :: scaloc - complex(qp) :: alpha + real(${ck}$) :: scaloc + complex(${ck}$) :: alpha ! Local Arrays integer(ilp) :: ipiv(ldz), jpiv(ldz) - complex(qp) :: rhs(ldz), z(ldz,ldz) + complex(${ck}$) :: rhs(ldz), z(ldz,ldz) ! Intrinsic Functions intrinsic :: cmplx,conjg,max ! Executable Statements @@ -71630,21 +71632,21 @@ module stdlib_linalg_lapack_w rhs( 1 ) = c( i, j ) rhs( 2 ) = f( i, j ) ! solve z * x = rhs - call stdlib_wgetc2( ldz, z, ldz, ipiv, jpiv, ierr ) + call stdlib_${ci}$getc2( ldz, z, ldz, ipiv, jpiv, ierr ) if( ierr>0 )info = ierr if( ijob==0 ) then - call stdlib_wgesc2( ldz, z, ldz, rhs, ipiv, jpiv, scaloc ) + call stdlib_${ci}$gesc2( ldz, z, ldz, rhs, ipiv, jpiv, scaloc ) if( scaloc/=one ) then do k = 1, n - call stdlib_wscal( m, cmplx( scaloc, zero,KIND=qp),c( 1, k ), 1 ) + call stdlib_${ci}$scal( m, cmplx( scaloc, zero,KIND=${ck}$),c( 1, k ), 1 ) - call stdlib_wscal( m, cmplx( scaloc, zero,KIND=qp),f( 1, k ), 1 ) + call stdlib_${ci}$scal( m, cmplx( scaloc, zero,KIND=${ck}$),f( 1, k ), 1 ) end do scale = scale*scaloc end if else - call stdlib_wlatdf( ijob, ldz, z, ldz, rhs, rdsum, rdscal,ipiv, jpiv ) + call stdlib_${ci}$latdf( ijob, ldz, z, ldz, rhs, rdsum, rdscal,ipiv, jpiv ) end if ! unpack solution vector(s) @@ -71653,13 +71655,13 @@ module stdlib_linalg_lapack_w ! substitute r(i, j) and l(i, j) into remaining equation. if( i>1 ) then alpha = -rhs( 1 ) - call stdlib_waxpy( i-1, alpha, a( 1, i ), 1, c( 1, j ), 1 ) - call stdlib_waxpy( i-1, alpha, d( 1, i ), 1, f( 1, j ), 1 ) + call stdlib_${ci}$axpy( i-1, alpha, a( 1, i ), 1, c( 1, j ), 1 ) + call stdlib_${ci}$axpy( i-1, alpha, d( 1, i ), 1, f( 1, j ), 1 ) end if if( j0 )info = ierr - call stdlib_wgesc2( ldz, z, ldz, rhs, ipiv, jpiv, scaloc ) + call stdlib_${ci}$gesc2( ldz, z, ldz, rhs, ipiv, jpiv, scaloc ) if( scaloc/=one ) then do k = 1, n - call stdlib_wscal( m, cmplx( scaloc, zero,KIND=qp), c( 1, k ),1 ) + call stdlib_${ci}$scal( m, cmplx( scaloc, zero,KIND=${ck}$), c( 1, k ),1 ) - call stdlib_wscal( m, cmplx( scaloc, zero,KIND=qp), f( 1, k ),1 ) + call stdlib_${ci}$scal( m, cmplx( scaloc, zero,KIND=${ck}$), f( 1, k ),1 ) end do scale = scale*scaloc @@ -71710,10 +71712,10 @@ module stdlib_linalg_lapack_w end do loop_80 end if return - end subroutine stdlib_wtgsy2 + end subroutine stdlib_${ci}$tgsy2 - pure subroutine stdlib_wtgsyl( trans, ijob, m, n, a, lda, b, ldb, c, ldc, d,ldd, e, lde, f, & + pure subroutine stdlib_${ci}$tgsyl( trans, ijob, m, n, a, lda, b, ldb, c, ldc, d,ldd, e, lde, f, & !! ZTGSYL: solves the generalized Sylvester equation: !! A * R - L * B = scale * C (1) !! D * R - L * E = scale * F @@ -71749,12 +71751,12 @@ module stdlib_linalg_lapack_w character, intent(in) :: trans integer(ilp), intent(in) :: ijob, lda, ldb, ldc, ldd, lde, ldf, lwork, m, n integer(ilp), intent(out) :: info - real(qp), intent(out) :: dif, scale + real(${ck}$), intent(out) :: dif, scale ! Array Arguments integer(ilp), intent(out) :: iwork(*) - complex(qp), intent(in) :: a(lda,*), b(ldb,*), d(ldd,*), e(lde,*) - complex(qp), intent(inout) :: c(ldc,*), f(ldf,*) - complex(qp), intent(out) :: work(*) + complex(${ck}$), intent(in) :: a(lda,*), b(ldb,*), d(ldd,*), e(lde,*) + complex(${ck}$), intent(inout) :: c(ldc,*), f(ldf,*) + complex(${ck}$), intent(out) :: work(*) ! ===================================================================== ! replaced various illegal calls to stdlib_zcopy by calls to stdlib_zlaset. ! sven hammarling, 1/5/02. @@ -71764,7 +71766,7 @@ module stdlib_linalg_lapack_w logical(lk) :: lquery, notran integer(ilp) :: i, ie, ifunc, iround, is, isolve, j, je, js, k, linfo, lwmin, mb, nb, & p, pq, q - real(qp) :: dscale, dsum, scale2, scaloc + real(${ck}$) :: dscale, dsum, scale2, scaloc ! Intrinsic Functions intrinsic :: real,cmplx,max,sqrt ! Executable Statements @@ -71837,8 +71839,8 @@ module stdlib_linalg_lapack_w if( notran ) then if( ijob>=3 ) then ifunc = ijob - 2 - call stdlib_wlaset( 'F', m, n, czero, czero, c, ldc ) - call stdlib_wlaset( 'F', m, n, czero, czero, f, ldf ) + call stdlib_${ci}$laset( 'F', m, n, czero, czero, c, ldc ) + call stdlib_${ci}$laset( 'F', m, n, czero, czero, f, ldf ) else if( ijob>=1 .and. notran ) then isolve = 2 end if @@ -71850,13 +71852,13 @@ module stdlib_linalg_lapack_w dscale = zero dsum = one pq = m*n - call stdlib_wtgsy2( trans, ifunc, m, n, a, lda, b, ldb, c, ldc, d,ldd, e, lde, f,& + call stdlib_${ci}$tgsy2( trans, ifunc, m, n, a, lda, b, ldb, c, ldc, d,ldd, e, lde, f,& ldf, scale, dsum, dscale,info ) if( dscale/=zero ) then if( ijob==1 .or. ijob==3 ) then - dif = sqrt( real( 2*m*n,KIND=qp) ) / ( dscale*sqrt( dsum ) ) + dif = sqrt( real( 2*m*n,KIND=${ck}$) ) / ( dscale*sqrt( dsum ) ) else - dif = sqrt( real( pq,KIND=qp) ) / ( dscale*sqrt( dsum ) ) + dif = sqrt( real( pq,KIND=${ck}$) ) / ( dscale*sqrt( dsum ) ) end if end if if( isolve==2 .and. iround==1 ) then @@ -71864,13 +71866,13 @@ module stdlib_linalg_lapack_w ifunc = ijob end if scale2 = scale - call stdlib_wlacpy( 'F', m, n, c, ldc, work, m ) - call stdlib_wlacpy( 'F', m, n, f, ldf, work( m*n+1 ), m ) - call stdlib_wlaset( 'F', m, n, czero, czero, c, ldc ) - call stdlib_wlaset( 'F', m, n, czero, czero, f, ldf ) + call stdlib_${ci}$lacpy( 'F', m, n, c, ldc, work, m ) + call stdlib_${ci}$lacpy( 'F', m, n, f, ldf, work( m*n+1 ), m ) + call stdlib_${ci}$laset( 'F', m, n, czero, czero, c, ldc ) + call stdlib_${ci}$laset( 'F', m, n, czero, czero, f, ldf ) else if( isolve==2 .and. iround==2 ) then - call stdlib_wlacpy( 'F', m, n, work, m, c, ldc ) - call stdlib_wlacpy( 'F', m, n, work( m*n+1 ), m, f, ldf ) + call stdlib_${ci}$lacpy( 'F', m, n, work, m, c, ldc ) + call stdlib_${ci}$lacpy( 'F', m, n, work( m*n+1 ), m, f, ldf ) scale = scale2 end if end do loop_30 @@ -71920,62 +71922,62 @@ module stdlib_linalg_lapack_w is = iwork( i ) ie = iwork( i+1 ) - 1 mb = ie - is + 1 - call stdlib_wtgsy2( trans, ifunc, mb, nb, a( is, is ), lda,b( js, js ), & + call stdlib_${ci}$tgsy2( trans, ifunc, mb, nb, a( is, is ), lda,b( js, js ), & ldb, c( is, js ), ldc,d( is, is ), ldd, e( js, js ), lde,f( is, js ), ldf, & scaloc, dsum, dscale,linfo ) if( linfo>0 )info = linfo pq = pq + mb*nb if( scaloc/=one ) then do k = 1, js - 1 - call stdlib_wscal( m, cmplx( scaloc, zero,KIND=qp),c( 1, k ), 1 ) + call stdlib_${ci}$scal( m, cmplx( scaloc, zero,KIND=${ck}$),c( 1, k ), 1 ) - call stdlib_wscal( m, cmplx( scaloc, zero,KIND=qp),f( 1, k ), 1 ) + call stdlib_${ci}$scal( m, cmplx( scaloc, zero,KIND=${ck}$),f( 1, k ), 1 ) end do do k = js, je - call stdlib_wscal( is-1, cmplx( scaloc, zero,KIND=qp),c( 1, k ), 1 ) + call stdlib_${ci}$scal( is-1, cmplx( scaloc, zero,KIND=${ck}$),c( 1, k ), 1 ) - call stdlib_wscal( is-1, cmplx( scaloc, zero,KIND=qp),f( 1, k ), 1 ) + call stdlib_${ci}$scal( is-1, cmplx( scaloc, zero,KIND=${ck}$),f( 1, k ), 1 ) end do do k = js, je - call stdlib_wscal( m-ie, cmplx( scaloc, zero,KIND=qp),c( ie+1, k ), & + call stdlib_${ci}$scal( m-ie, cmplx( scaloc, zero,KIND=${ck}$),c( ie+1, k ), & 1 ) - call stdlib_wscal( m-ie, cmplx( scaloc, zero,KIND=qp),f( ie+1, k ), & + call stdlib_${ci}$scal( m-ie, cmplx( scaloc, zero,KIND=${ck}$),f( ie+1, k ), & 1 ) end do do k = je + 1, n - call stdlib_wscal( m, cmplx( scaloc, zero,KIND=qp),c( 1, k ), 1 ) + call stdlib_${ci}$scal( m, cmplx( scaloc, zero,KIND=${ck}$),c( 1, k ), 1 ) - call stdlib_wscal( m, cmplx( scaloc, zero,KIND=qp),f( 1, k ), 1 ) + call stdlib_${ci}$scal( m, cmplx( scaloc, zero,KIND=${ck}$),f( 1, k ), 1 ) end do scale = scale*scaloc end if ! substitute r(i,j) and l(i,j) into remaining equation. if( i>1 ) then - call stdlib_wgemm( 'N', 'N', is-1, nb, mb,cmplx( -one, zero,KIND=qp), a(& - 1, is ), lda,c( is, js ), ldc, cmplx( one, zero,KIND=qp),c( 1, js ), & + call stdlib_${ci}$gemm( 'N', 'N', is-1, nb, mb,cmplx( -one, zero,KIND=${ck}$), a(& + 1, is ), lda,c( is, js ), ldc, cmplx( one, zero,KIND=${ck}$),c( 1, js ), & ldc ) - call stdlib_wgemm( 'N', 'N', is-1, nb, mb,cmplx( -one, zero,KIND=qp), d(& - 1, is ), ldd,c( is, js ), ldc, cmplx( one, zero,KIND=qp),f( 1, js ), & + call stdlib_${ci}$gemm( 'N', 'N', is-1, nb, mb,cmplx( -one, zero,KIND=${ck}$), d(& + 1, is ), ldd,c( is, js ), ldc, cmplx( one, zero,KIND=${ck}$),f( 1, js ), & ldf ) end if if( j0 )info = linfo if( scaloc/=one ) then do k = 1, js - 1 - call stdlib_wscal( m, cmplx( scaloc, zero,KIND=qp), c( 1, k ),1 ) + call stdlib_${ci}$scal( m, cmplx( scaloc, zero,KIND=${ck}$), c( 1, k ),1 ) - call stdlib_wscal( m, cmplx( scaloc, zero,KIND=qp), f( 1, k ),1 ) + call stdlib_${ci}$scal( m, cmplx( scaloc, zero,KIND=${ck}$), f( 1, k ),1 ) end do do k = js, je - call stdlib_wscal( is-1, cmplx( scaloc, zero,KIND=qp),c( 1, k ), 1 ) + call stdlib_${ci}$scal( is-1, cmplx( scaloc, zero,KIND=${ck}$),c( 1, k ), 1 ) - call stdlib_wscal( is-1, cmplx( scaloc, zero,KIND=qp),f( 1, k ), 1 ) + call stdlib_${ci}$scal( is-1, cmplx( scaloc, zero,KIND=${ck}$),f( 1, k ), 1 ) end do do k = js, je - call stdlib_wscal( m-ie, cmplx( scaloc, zero,KIND=qp),c( ie+1, k ), 1 ) + call stdlib_${ci}$scal( m-ie, cmplx( scaloc, zero,KIND=${ck}$),c( ie+1, k ), 1 ) - call stdlib_wscal( m-ie, cmplx( scaloc, zero,KIND=qp),f( ie+1, k ), 1 ) + call stdlib_${ci}$scal( m-ie, cmplx( scaloc, zero,KIND=${ck}$),f( ie+1, k ), 1 ) end do do k = je + 1, n - call stdlib_wscal( m, cmplx( scaloc, zero,KIND=qp), c( 1, k ),1 ) + call stdlib_${ci}$scal( m, cmplx( scaloc, zero,KIND=${ck}$), c( 1, k ),1 ) - call stdlib_wscal( m, cmplx( scaloc, zero,KIND=qp), f( 1, k ),1 ) + call stdlib_${ci}$scal( m, cmplx( scaloc, zero,KIND=${ck}$), f( 1, k ),1 ) end do scale = scale*scaloc end if ! substitute r(i,j) and l(i,j) into remaining equation. if( j>p+2 ) then - call stdlib_wgemm( 'N', 'C', mb, js-1, nb,cmplx( one, zero,KIND=qp), c( is,& - js ), ldc,b( 1, js ), ldb, cmplx( one, zero,KIND=qp),f( is, 1 ), ldf ) + call stdlib_${ci}$gemm( 'N', 'C', mb, js-1, nb,cmplx( one, zero,KIND=${ck}$), c( is,& + js ), ldc,b( 1, js ), ldb, cmplx( one, zero,KIND=${ck}$),f( is, 1 ), ldf ) - call stdlib_wgemm( 'N', 'C', mb, js-1, nb,cmplx( one, zero,KIND=qp), f( is,& - js ), ldf,e( 1, js ), lde, cmplx( one, zero,KIND=qp),f( is, 1 ), ldf ) + call stdlib_${ci}$gemm( 'N', 'C', mb, js-1, nb,cmplx( one, zero,KIND=${ck}$), f( is,& + js ), ldf,e( 1, js ), lde, cmplx( one, zero,KIND=${ck}$),f( is, 1 ), ldf ) end if if( i

0. if( anorm>zero ) then ! estimate the norm of the inverse of a. @@ -72138,24 +72140,24 @@ module stdlib_linalg_lapack_w end if kase = 0 10 continue - call stdlib_wlacn2( n, work( n+1 ), work, ainvnm, kase, isave ) + call stdlib_${ci}$lacn2( n, work( n+1 ), work, ainvnm, kase, isave ) if( kase/=0 ) then if( kase==kase1 ) then ! multiply by inv(a). - call stdlib_wlatps( uplo, 'NO TRANSPOSE', diag, normin, n, ap,work, scale, & + call stdlib_${ci}$latps( uplo, 'NO TRANSPOSE', diag, normin, n, ap,work, scale, & rwork, info ) else ! multiply by inv(a**h). - call stdlib_wlatps( uplo, 'CONJUGATE TRANSPOSE', diag, normin,n, ap, work, & + call stdlib_${ci}$latps( uplo, 'CONJUGATE TRANSPOSE', diag, normin,n, ap, work, & scale, rwork, info ) end if normin = 'Y' ! multiply by 1/scale if doing so will not cause overflow. if( scale/=one ) then - ix = stdlib_iwamax( n, work, 1 ) + ix = stdlib_i${ci}$amax( n, work, 1 ) xnorm = cabs1( work( ix ) ) if( scale 0. if( anorm>zero ) then ! estimate the norm of the inverse of a. @@ -73959,24 +73961,24 @@ module stdlib_linalg_lapack_w end if kase = 0 10 continue - call stdlib_wlacn2( n, work( n+1 ), work, ainvnm, kase, isave ) + call stdlib_${ci}$lacn2( n, work( n+1 ), work, ainvnm, kase, isave ) if( kase/=0 ) then if( kase==kase1 ) then ! multiply by inv(a). - call stdlib_wlatrs( uplo, 'NO TRANSPOSE', diag, normin, n, a,lda, work, scale,& + call stdlib_${ci}$latrs( uplo, 'NO TRANSPOSE', diag, normin, n, a,lda, work, scale,& rwork, info ) else ! multiply by inv(a**h). - call stdlib_wlatrs( uplo, 'CONJUGATE TRANSPOSE', diag, normin,n, a, lda, work,& + call stdlib_${ci}$latrs( uplo, 'CONJUGATE TRANSPOSE', diag, normin,n, a, lda, work,& scale, rwork, info ) end if normin = 'Y' ! multiply by 1/scale if doing so will not cause overflow. if( scale/=one ) then - ix = stdlib_iwamax( n, work, 1 ) + ix = stdlib_i${ci}$amax( n, work, 1 ) xnorm = cabs1( work( ix ) ) if( scale1 ) then - call stdlib_wlatrs( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', 'Y',ki-1, t, ldt, & + call stdlib_${ci}$latrs( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', 'Y',ki-1, t, ldt, & work( 1 ), scale, rwork,info ) work( ki ) = scale end if ! copy the vector x or q*x to vr and normalize. if( .not.over ) then - call stdlib_wcopy( ki, work( 1 ), 1, vr( 1, is ), 1 ) - ii = stdlib_iwamax( ki, vr( 1, is ), 1 ) + call stdlib_${ci}$copy( ki, work( 1 ), 1, vr( 1, is ), 1 ) + ii = stdlib_i${ci}$amax( ki, vr( 1, is ), 1 ) remax = one / cabs1( vr( ii, is ) ) - call stdlib_wdscal( ki, remax, vr( 1, is ), 1 ) + call stdlib_${ci}$dscal( ki, remax, vr( 1, is ), 1 ) do k = ki + 1, n vr( k, is ) = cmzero end do else - if( ki>1 )call stdlib_wgemv( 'N', n, ki-1, cmone, vr, ldvr, work( 1 ),1, & - cmplx( scale,KIND=qp), vr( 1, ki ), 1 ) - ii = stdlib_iwamax( n, vr( 1, ki ), 1 ) + if( ki>1 )call stdlib_${ci}$gemv( 'N', n, ki-1, cmone, vr, ldvr, work( 1 ),1, & + cmplx( scale,KIND=${ck}$), vr( 1, ki ), 1 ) + ii = stdlib_i${ci}$amax( n, vr( 1, ki ), 1 ) remax = one / cabs1( vr( ii, ki ) ) - call stdlib_wdscal( n, remax, vr( 1, ki ), 1 ) + call stdlib_${ci}$dscal( n, remax, vr( 1, ki ), 1 ) end if ! set back the original diagonal elements of t. do k = 1, ki - 1 @@ -74157,25 +74159,25 @@ module stdlib_linalg_lapack_w if( cabs1( t( k, k ) )= n + 2*n*nbmin ) then nb = (lwork - n) / (2*n) nb = min( nb, nbmax ) - call stdlib_wlaset( 'F', n, 1+2*nb, czero, czero, work, n ) + call stdlib_${ci}$laset( 'F', n, 1+2*nb, czero, czero, work, n ) else nb = 1 end if ! set the constants to control overflow. - unfl = stdlib_qlamch( 'SAFE MINIMUM' ) + unfl = stdlib_${c2ri(ci)}$lamch( 'SAFE MINIMUM' ) ovfl = one / unfl - call stdlib_qlabad( unfl, ovfl ) - ulp = stdlib_qlamch( 'PRECISION' ) + call stdlib_${c2ri(ci)}$labad( unfl, ovfl ) + ulp = stdlib_${c2ri(ci)}$lamch( 'PRECISION' ) smlnum = unfl*( n / ulp ) ! store the diagonal elements of t in working array work. do i = 1, n @@ -74310,7 +74312,7 @@ module stdlib_linalg_lapack_w ! part of t to control overflow in triangular solver. rwork( 1 ) = zero do j = 2, n - rwork( j ) = stdlib_qzasum( j-1, t( 1, j ), 1 ) + rwork( j ) = stdlib_${c2ri(ci)}$zasum( j-1, t( 1, j ), 1 ) end do if( rightv ) then ! ============================================================ @@ -74340,7 +74342,7 @@ module stdlib_linalg_lapack_w if( cabs1( t( k, k ) )1 ) then - call stdlib_wlatrs( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', 'Y',ki-1, t, ldt, & + call stdlib_${ci}$latrs( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', 'Y',ki-1, t, ldt, & work( 1 + iv*n ), scale,rwork, info ) work( ki + iv*n ) = scale end if @@ -74348,21 +74350,21 @@ module stdlib_linalg_lapack_w if( .not.over ) then ! ------------------------------ ! no back-transform: copy x to vr and normalize. - call stdlib_wcopy( ki, work( 1 + iv*n ), 1, vr( 1, is ), 1 ) - ii = stdlib_iwamax( ki, vr( 1, is ), 1 ) + call stdlib_${ci}$copy( ki, work( 1 + iv*n ), 1, vr( 1, is ), 1 ) + ii = stdlib_i${ci}$amax( ki, vr( 1, is ), 1 ) remax = one / cabs1( vr( ii, is ) ) - call stdlib_wdscal( ki, remax, vr( 1, is ), 1 ) + call stdlib_${ci}$dscal( ki, remax, vr( 1, is ), 1 ) do k = ki + 1, n vr( k, is ) = czero end do else if( nb==1 ) then ! ------------------------------ ! version 1: back-transform each vector with gemv, q*x. - if( ki>1 )call stdlib_wgemv( 'N', n, ki-1, cone, vr, ldvr,work( 1 + iv*n ), 1,& - cmplx( scale,KIND=qp),vr( 1, ki ), 1 ) - ii = stdlib_iwamax( n, vr( 1, ki ), 1 ) + if( ki>1 )call stdlib_${ci}$gemv( 'N', n, ki-1, cone, vr, ldvr,work( 1 + iv*n ), 1,& + cmplx( scale,KIND=${ck}$),vr( 1, ki ), 1 ) + ii = stdlib_i${ci}$amax( n, vr( 1, ki ), 1 ) remax = one / cabs1( vr( ii, ki ) ) - call stdlib_wdscal( n, remax, vr( 1, ki ), 1 ) + call stdlib_${ci}$dscal( n, remax, vr( 1, ki ), 1 ) else ! ------------------------------ ! version 2: back-transform block of vectors with gemm @@ -74374,15 +74376,15 @@ module stdlib_linalg_lapack_w ! when the number of vectors stored reaches nb, ! or if this was last vector, do the gemm if( (iv==1) .or. (ki==1) ) then - call stdlib_wgemm( 'N', 'N', n, nb-iv+1, ki+nb-iv, cone,vr, ldvr,work( 1 + & + call stdlib_${ci}$gemm( 'N', 'N', n, nb-iv+1, ki+nb-iv, cone,vr, ldvr,work( 1 + & (iv)*n ), n,czero,work( 1 + (nb+iv)*n ), n ) ! normalize vectors do k = iv, nb - ii = stdlib_iwamax( n, work( 1 + (nb+k)*n ), 1 ) + ii = stdlib_i${ci}$amax( n, work( 1 + (nb+k)*n ), 1 ) remax = one / cabs1( work( ii + (nb+k)*n ) ) - call stdlib_wdscal( n, remax, work( 1 + (nb+k)*n ), 1 ) + call stdlib_${ci}$dscal( n, remax, work( 1 + (nb+k)*n ), 1 ) end do - call stdlib_wlacpy( 'F', n, nb-iv+1,work( 1 + (nb+iv)*n ), n,vr( 1, ki ), & + call stdlib_${ci}$lacpy( 'F', n, nb-iv+1,work( 1 + (nb+iv)*n ), n,vr( 1, ki ), & ldvr ) iv = nb else @@ -74424,7 +74426,7 @@ module stdlib_linalg_lapack_w if( cabs1( t( k, k ) )one ) then if( db>bignum*da11 )scaloc = one / db end if - x11 = stdlib_wladiv( vec*cmplx( scaloc,KIND=qp), a11 ) + x11 = stdlib_${ci}$ladiv( vec*cmplx( scaloc,KIND=${ck}$), a11 ) if( scaloc/=one ) then do j = 1, n - call stdlib_wdscal( m, scaloc, c( 1, j ), 1 ) + call stdlib_${ci}$dscal( m, scaloc, c( 1, j ), 1 ) end do scale = scale*scaloc end if @@ -75209,25 +75211,25 @@ module stdlib_linalg_lapack_w ! i=1 j=1 loop_60: do l = 1, n do k = 1, m - suml = stdlib_wdotc( k-1, a( 1, k ), 1, c( 1, l ), 1 ) - sumr = stdlib_wdotu( l-1, c( k, 1 ), ldc, b( 1, l ), 1 ) + suml = stdlib_${ci}$dotc( k-1, a( 1, k ), 1, c( 1, l ), 1 ) + sumr = stdlib_${ci}$dotu( l-1, c( k, 1 ), ldc, b( 1, l ), 1 ) vec = c( k, l ) - ( suml+sgn*sumr ) scaloc = one a11 = conjg( a( k, k ) ) + sgn*b( l, l ) - da11 = abs( real( a11,KIND=qp) ) + abs( aimag( a11 ) ) + da11 = abs( real( a11,KIND=${ck}$) ) + abs( aimag( a11 ) ) if( da11<=smin ) then a11 = smin da11 = smin info = 1 end if - db = abs( real( vec,KIND=qp) ) + abs( aimag( vec ) ) + db = abs( real( vec,KIND=${ck}$) ) + abs( aimag( vec ) ) if( da11one ) then if( db>bignum*da11 )scaloc = one / db end if - x11 = stdlib_wladiv( vec*cmplx( scaloc,KIND=qp), a11 ) + x11 = stdlib_${ci}$ladiv( vec*cmplx( scaloc,KIND=${ck}$), a11 ) if( scaloc/=one ) then do j = 1, n - call stdlib_wdscal( m, scaloc, c( 1, j ), 1 ) + call stdlib_${ci}$dscal( m, scaloc, c( 1, j ), 1 ) end do scale = scale*scaloc end if @@ -75248,26 +75250,26 @@ module stdlib_linalg_lapack_w ! j=l+1 loop_90: do l = n, 1, -1 do k = 1, m - suml = stdlib_wdotc( k-1, a( 1, k ), 1, c( 1, l ), 1 ) - sumr = stdlib_wdotc( n-l, c( k, min( l+1, n ) ), ldc,b( l, min( l+1, n ) ), & + suml = stdlib_${ci}$dotc( k-1, a( 1, k ), 1, c( 1, l ), 1 ) + sumr = stdlib_${ci}$dotc( n-l, c( k, min( l+1, n ) ), ldc,b( l, min( l+1, n ) ), & ldb ) vec = c( k, l ) - ( suml+sgn*conjg( sumr ) ) scaloc = one a11 = conjg( a( k, k )+sgn*b( l, l ) ) - da11 = abs( real( a11,KIND=qp) ) + abs( aimag( a11 ) ) + da11 = abs( real( a11,KIND=${ck}$) ) + abs( aimag( a11 ) ) if( da11<=smin ) then a11 = smin da11 = smin info = 1 end if - db = abs( real( vec,KIND=qp) ) + abs( aimag( vec ) ) + db = abs( real( vec,KIND=${ck}$) ) + abs( aimag( vec ) ) if( da11one ) then if( db>bignum*da11 )scaloc = one / db end if - x11 = stdlib_wladiv( vec*cmplx( scaloc,KIND=qp), a11 ) + x11 = stdlib_${ci}$ladiv( vec*cmplx( scaloc,KIND=${ck}$), a11 ) if( scaloc/=one ) then do j = 1, n - call stdlib_wdscal( m, scaloc, c( 1, j ), 1 ) + call stdlib_${ci}$dscal( m, scaloc, c( 1, j ), 1 ) end do scale = scale*scaloc end if @@ -75285,27 +75287,27 @@ module stdlib_linalg_lapack_w ! i=k+1 j=l+1 loop_120: do l = n, 1, -1 do k = m, 1, -1 - suml = stdlib_wdotu( m-k, a( k, min( k+1, m ) ), lda,c( min( k+1, m ), l ), 1 & + suml = stdlib_${ci}$dotu( m-k, a( k, min( k+1, m ) ), lda,c( min( k+1, m ), l ), 1 & ) - sumr = stdlib_wdotc( n-l, c( k, min( l+1, n ) ), ldc,b( l, min( l+1, n ) ), & + sumr = stdlib_${ci}$dotc( n-l, c( k, min( l+1, n ) ), ldc,b( l, min( l+1, n ) ), & ldb ) vec = c( k, l ) - ( suml+sgn*conjg( sumr ) ) scaloc = one a11 = a( k, k ) + sgn*conjg( b( l, l ) ) - da11 = abs( real( a11,KIND=qp) ) + abs( aimag( a11 ) ) + da11 = abs( real( a11,KIND=${ck}$) ) + abs( aimag( a11 ) ) if( da11<=smin ) then a11 = smin da11 = smin info = 1 end if - db = abs( real( vec,KIND=qp) ) + abs( aimag( vec ) ) + db = abs( real( vec,KIND=${ck}$) ) + abs( aimag( vec ) ) if( da11one ) then if( db>bignum*da11 )scaloc = one / db end if - x11 = stdlib_wladiv( vec*cmplx( scaloc,KIND=qp), a11 ) + x11 = stdlib_${ci}$ladiv( vec*cmplx( scaloc,KIND=${ck}$), a11 ) if( scaloc/=one ) then do j = 1, n - call stdlib_wdscal( m, scaloc, c( 1, j ), 1 ) + call stdlib_${ci}$dscal( m, scaloc, c( 1, j ), 1 ) end do scale = scale*scaloc end if @@ -75314,10 +75316,10 @@ module stdlib_linalg_lapack_w end do loop_120 end if return - end subroutine stdlib_wtrsyl + end subroutine stdlib_${ci}$trsyl - pure subroutine stdlib_wtrti2( uplo, diag, n, a, lda, info ) + pure subroutine stdlib_${ci}$trti2( uplo, diag, n, a, lda, info ) !! ZTRTI2: computes the inverse of a complex upper or lower triangular !! matrix. !! This is the Level 2 BLAS version of the algorithm. @@ -75329,13 +75331,13 @@ module stdlib_linalg_lapack_w integer(ilp), intent(out) :: info integer(ilp), intent(in) :: lda, n ! Array Arguments - complex(qp), intent(inout) :: a(lda,*) + complex(${ck}$), intent(inout) :: a(lda,*) ! ===================================================================== ! Local Scalars logical(lk) :: nounit, upper integer(ilp) :: j - complex(qp) :: ajj + complex(${ck}$) :: ajj ! Intrinsic Functions intrinsic :: max ! Executable Statements @@ -75366,9 +75368,9 @@ module stdlib_linalg_lapack_w ajj = -cone end if ! compute elements 1:j-1 of j-th column. - call stdlib_wtrmv( 'UPPER', 'NO TRANSPOSE', diag, j-1, a, lda,a( 1, j ), 1 ) + call stdlib_${ci}$trmv( 'UPPER', 'NO TRANSPOSE', diag, j-1, a, lda,a( 1, j ), 1 ) - call stdlib_wscal( j-1, ajj, a( 1, j ), 1 ) + call stdlib_${ci}$scal( j-1, ajj, a( 1, j ), 1 ) end do else ! compute inverse of lower triangular matrix. @@ -75381,17 +75383,17 @@ module stdlib_linalg_lapack_w end if if( j=n ) then ! use unblocked code - call stdlib_wtrti2( uplo, diag, n, a, lda, info ) + call stdlib_${ci}$trti2( uplo, diag, n, a, lda, info ) else ! use blocked code if( upper ) then @@ -75450,12 +75452,12 @@ module stdlib_linalg_lapack_w do j = 1, n, nb jb = min( nb, n-j+1 ) ! compute rows 1:j-1 of current block column - call stdlib_wtrmm( 'LEFT', 'UPPER', 'NO TRANSPOSE', diag, j-1,jb, cone, a, & + call stdlib_${ci}$trmm( 'LEFT', 'UPPER', 'NO TRANSPOSE', diag, j-1,jb, cone, a, & lda, a( 1, j ), lda ) - call stdlib_wtrsm( 'RIGHT', 'UPPER', 'NO TRANSPOSE', diag, j-1,jb, -cone, a( & + call stdlib_${ci}$trsm( 'RIGHT', 'UPPER', 'NO TRANSPOSE', diag, j-1,jb, -cone, a( & j, j ), lda, a( 1, j ), lda ) ! compute inverse of current diagonal block - call stdlib_wtrti2( 'UPPER', diag, jb, a( j, j ), lda, info ) + call stdlib_${ci}$trti2( 'UPPER', diag, jb, a( j, j ), lda, info ) end do else ! compute inverse of lower triangular matrix @@ -75464,21 +75466,21 @@ module stdlib_linalg_lapack_w jb = min( nb, n-j+1 ) if( j+jb<=n ) then ! compute rows j+jb:n of current block column - call stdlib_wtrmm( 'LEFT', 'LOWER', 'NO TRANSPOSE', diag,n-j-jb+1, jb, & + call stdlib_${ci}$trmm( 'LEFT', 'LOWER', 'NO TRANSPOSE', diag,n-j-jb+1, jb, & cone, a( j+jb, j+jb ), lda,a( j+jb, j ), lda ) - call stdlib_wtrsm( 'RIGHT', 'LOWER', 'NO TRANSPOSE', diag,n-j-jb+1, jb, -& + call stdlib_${ci}$trsm( 'RIGHT', 'LOWER', 'NO TRANSPOSE', diag,n-j-jb+1, jb, -& cone, a( j, j ), lda,a( j+jb, j ), lda ) end if ! compute inverse of current diagonal block - call stdlib_wtrti2( 'LOWER', diag, jb, a( j, j ), lda, info ) + call stdlib_${ci}$trti2( 'LOWER', diag, jb, a( j, j ), lda, info ) end do end if end if return - end subroutine stdlib_wtrtri + end subroutine stdlib_${ci}$trtri - pure subroutine stdlib_wtrtrs( uplo, trans, diag, n, nrhs, a, lda, b, ldb,info ) + pure subroutine stdlib_${ci}$trtrs( uplo, trans, diag, n, nrhs, a, lda, b, ldb,info ) !! ZTRTRS: solves a triangular system of the form !! A * X = B, A**T * X = B, or A**H * X = B, !! where A is a triangular matrix of order N, and B is an N-by-NRHS @@ -75491,8 +75493,8 @@ module stdlib_linalg_lapack_w integer(ilp), intent(out) :: info integer(ilp), intent(in) :: lda, ldb, n, nrhs ! Array Arguments - complex(qp), intent(in) :: a(lda,*) - complex(qp), intent(inout) :: b(ldb,*) + complex(${ck}$), intent(in) :: a(lda,*) + complex(${ck}$), intent(inout) :: b(ldb,*) ! ===================================================================== ! Local Scalars @@ -75533,12 +75535,12 @@ module stdlib_linalg_lapack_w end if info = 0 ! solve a * x = b, a**t * x = b, or a**h * x = b. - call stdlib_wtrsm( 'LEFT', uplo, trans, diag, n, nrhs, cone, a, lda, b,ldb ) + call stdlib_${ci}$trsm( 'LEFT', uplo, trans, diag, n, nrhs, cone, a, lda, b,ldb ) return - end subroutine stdlib_wtrtrs + end subroutine stdlib_${ci}$trtrs - pure subroutine stdlib_wtrttf( transr, uplo, n, a, lda, arf, info ) + pure subroutine stdlib_${ci}$trttf( transr, uplo, n, a, lda, arf, info ) !! ZTRTTF: copies a triangular matrix A from standard full format (TR) !! to rectangular full packed format (TF) . ! -- lapack computational routine -- @@ -75549,8 +75551,8 @@ module stdlib_linalg_lapack_w integer(ilp), intent(out) :: info integer(ilp), intent(in) :: n, lda ! Array Arguments - complex(qp), intent(in) :: a(0:lda-1,0:*) - complex(qp), intent(out) :: arf(0:*) + complex(${ck}$), intent(in) :: a(0:lda-1,0:*) + complex(${ck}$), intent(out) :: arf(0:*) ! ===================================================================== ! Parameters ! Local Scalars @@ -75784,10 +75786,10 @@ module stdlib_linalg_lapack_w end if end if return - end subroutine stdlib_wtrttf + end subroutine stdlib_${ci}$trttf - pure subroutine stdlib_wtrttp( uplo, n, a, lda, ap, info ) + pure subroutine stdlib_${ci}$trttp( uplo, n, a, lda, ap, info ) !! ZTRTTP: copies a triangular matrix A from full format (TR) to standard !! packed format (TP). ! -- lapack computational routine -- @@ -75798,8 +75800,8 @@ module stdlib_linalg_lapack_w integer(ilp), intent(out) :: info integer(ilp), intent(in) :: n, lda ! Array Arguments - complex(qp), intent(in) :: a(lda,*) - complex(qp), intent(out) :: ap(*) + complex(${ck}$), intent(in) :: a(lda,*) + complex(${ck}$), intent(out) :: ap(*) ! ===================================================================== ! Parameters ! Local Scalars @@ -75838,10 +75840,10 @@ module stdlib_linalg_lapack_w end do end if return - end subroutine stdlib_wtrttp + end subroutine stdlib_${ci}$trttp - pure subroutine stdlib_wtzrzf( m, n, a, lda, tau, work, lwork, info ) + pure subroutine stdlib_${ci}$tzrzf( m, n, a, lda, tau, work, lwork, info ) !! ZTZRZF: reduces the M-by-N ( M<=N ) complex upper trapezoidal matrix A !! to upper triangular form by means of unitary transformations. !! The upper trapezoidal matrix A is factored as @@ -75855,8 +75857,8 @@ module stdlib_linalg_lapack_w integer(ilp), intent(out) :: info integer(ilp), intent(in) :: lda, lwork, m, n ! Array Arguments - complex(qp), intent(inout) :: a(lda,*) - complex(qp), intent(out) :: tau(*), work(*) + complex(${ck}$), intent(inout) :: a(lda,*) + complex(${ck}$), intent(out) :: tau(*), work(*) ! ===================================================================== ! Local Scalars @@ -75934,14 +75936,14 @@ module stdlib_linalg_lapack_w ib = min( m-i+1, nb ) ! compute the tz factorization of the current block ! a(i:i+ib-1,i:n) - call stdlib_wlatrz( ib, n-i+1, n-m, a( i, i ), lda, tau( i ),work ) + call stdlib_${ci}$latrz( ib, n-i+1, n-m, a( i, i ), lda, tau( i ),work ) if( i>1 ) then ! form the triangular factor of the block reflector ! h = h(i+ib-1) . . . h(i+1) h(i) - call stdlib_wlarzt( 'BACKWARD', 'ROWWISE', n-m, ib, a( i, m1 ),lda, tau( i ), & + call stdlib_${ci}$larzt( 'BACKWARD', 'ROWWISE', n-m, ib, a( i, m1 ),lda, tau( i ), & work, ldwork ) ! apply h to a(1:i-1,i:n) from the right - call stdlib_wlarzb( 'RIGHT', 'NO TRANSPOSE', 'BACKWARD','ROWWISE', i-1, n-i+1,& + call stdlib_${ci}$larzb( 'RIGHT', 'NO TRANSPOSE', 'BACKWARD','ROWWISE', i-1, n-i+1,& ib, n-m, a( i, m1 ),lda, work, ldwork, a( 1, i ), lda,work( ib+1 ), ldwork ) end if @@ -75951,13 +75953,13 @@ module stdlib_linalg_lapack_w mu = m end if ! use unblocked code to factor the last or only block - if( mu>0 )call stdlib_wlatrz( mu, n, n-m, a, lda, tau, work ) + if( mu>0 )call stdlib_${ci}$latrz( mu, n, n-m, a, lda, tau, work ) work( 1 ) = lwkopt return - end subroutine stdlib_wtzrzf + end subroutine stdlib_${ci}$tzrzf - subroutine stdlib_wunbdb( trans, signs, m, p, q, x11, ldx11, x12, ldx12,x21, ldx21, x22, & + subroutine stdlib_${ci}$unbdb( trans, signs, m, p, q, x11, ldx11, x12, ldx12,x21, ldx21, x22, & !! ZUNBDB: simultaneously bidiagonalizes the blocks of an M-by-M !! partitioned unitary matrix X: !! [ B11 | B12 0 0 ] @@ -75983,19 +75985,19 @@ module stdlib_linalg_lapack_w integer(ilp), intent(out) :: info integer(ilp), intent(in) :: ldx11, ldx12, ldx21, ldx22, lwork, m, p, q ! Array Arguments - real(qp), intent(out) :: phi(*), theta(*) - complex(qp), intent(out) :: taup1(*), taup2(*), tauq1(*), tauq2(*), work(*) - complex(qp), intent(inout) :: x11(ldx11,*), x12(ldx12,*), x21(ldx21,*), x22(ldx22,*) + real(${ck}$), intent(out) :: phi(*), theta(*) + complex(${ck}$), intent(out) :: taup1(*), taup2(*), tauq1(*), tauq2(*), work(*) + complex(${ck}$), intent(inout) :: x11(ldx11,*), x12(ldx12,*), x21(ldx21,*), x22(ldx22,*) ! ==================================================================== ! Parameters - real(qp), parameter :: realone = 1.0_qp + real(${ck}$), parameter :: realone = 1.0_${ck}$ ! Local Scalars logical(lk) :: colmajor, lquery integer(ilp) :: i, lworkmin, lworkopt - real(qp) :: z1, z2, z3, z4 + real(${ck}$) :: z1, z2, z3, z4 ! Intrinsic Functions intrinsic :: atan2,cos,max,min,sin intrinsic :: cmplx,conjg @@ -76058,229 +76060,229 @@ module stdlib_linalg_lapack_w ! reduce columns 1, ..., q of x11, x12, x21, and x22 do i = 1, q if( i == 1 ) then - call stdlib_wscal( p-i+1, cmplx( z1, 0.0_qp,KIND=qp), x11(i,i), 1 ) + call stdlib_${ci}$scal( p-i+1, cmplx( z1, 0.0_${ck}$,KIND=${ck}$), x11(i,i), 1 ) else - call stdlib_wscal( p-i+1, cmplx( z1*cos(phi(i-1)), 0.0_qp,KIND=qp),x11(i,i), & + call stdlib_${ci}$scal( p-i+1, cmplx( z1*cos(phi(i-1)), 0.0_${ck}$,KIND=${ck}$),x11(i,i), & 1 ) - call stdlib_waxpy( p-i+1, cmplx( -z1*z3*z4*sin(phi(i-1)),0.0_qp,KIND=qp), x12(& + call stdlib_${ci}$axpy( p-i+1, cmplx( -z1*z3*z4*sin(phi(i-1)),0.0_${ck}$,KIND=${ck}$), x12(& i,i-1), 1, x11(i,i), 1 ) end if if( i == 1 ) then - call stdlib_wscal( m-p-i+1, cmplx( z2, 0.0_qp,KIND=qp), x21(i,i), 1 ) + call stdlib_${ci}$scal( m-p-i+1, cmplx( z2, 0.0_${ck}$,KIND=${ck}$), x21(i,i), 1 ) else - call stdlib_wscal( m-p-i+1, cmplx( z2*cos(phi(i-1)), 0.0_qp,KIND=qp),x21(i,i),& + call stdlib_${ci}$scal( m-p-i+1, cmplx( z2*cos(phi(i-1)), 0.0_${ck}$,KIND=${ck}$),x21(i,i),& 1 ) - call stdlib_waxpy( m-p-i+1, cmplx( -z2*z3*z4*sin(phi(i-1)),0.0_qp,KIND=qp), & + call stdlib_${ci}$axpy( m-p-i+1, cmplx( -z2*z3*z4*sin(phi(i-1)),0.0_${ck}$,KIND=${ck}$), & x22(i,i-1), 1, x21(i,i), 1 ) end if - theta(i) = atan2( stdlib_qznrm2( m-p-i+1, x21(i,i), 1 ),stdlib_qznrm2( p-i+1, & + theta(i) = atan2( stdlib_${c2ri(ci)}$znrm2( m-p-i+1, x21(i,i), 1 ),stdlib_${c2ri(ci)}$znrm2( p-i+1, & x11(i,i), 1 ) ) if( p > i ) then - call stdlib_wlarfgp( p-i+1, x11(i,i), x11(i+1,i), 1, taup1(i) ) + call stdlib_${ci}$larfgp( p-i+1, x11(i,i), x11(i+1,i), 1, taup1(i) ) else if ( p == i ) then - call stdlib_wlarfgp( p-i+1, x11(i,i), x11(i,i), 1, taup1(i) ) + call stdlib_${ci}$larfgp( p-i+1, x11(i,i), x11(i,i), 1, taup1(i) ) end if x11(i,i) = cone if ( m-p > i ) then - call stdlib_wlarfgp( m-p-i+1, x21(i,i), x21(i+1,i), 1,taup2(i) ) + call stdlib_${ci}$larfgp( m-p-i+1, x21(i,i), x21(i+1,i), 1,taup2(i) ) else if ( m-p == i ) then - call stdlib_wlarfgp( m-p-i+1, x21(i,i), x21(i,i), 1,taup2(i) ) + call stdlib_${ci}$larfgp( m-p-i+1, x21(i,i), x21(i,i), 1,taup2(i) ) end if x21(i,i) = cone if ( q > i ) then - call stdlib_wlarf( 'L', p-i+1, q-i, x11(i,i), 1,conjg(taup1(i)), x11(i,i+1), & + call stdlib_${ci}$larf( 'L', p-i+1, q-i, x11(i,i), 1,conjg(taup1(i)), x11(i,i+1), & ldx11, work ) - call stdlib_wlarf( 'L', m-p-i+1, q-i, x21(i,i), 1,conjg(taup2(i)), x21(i,i+1),& + call stdlib_${ci}$larf( 'L', m-p-i+1, q-i, x21(i,i), 1,conjg(taup2(i)), x21(i,i+1),& ldx21, work ) end if if ( m-q+1 > i ) then - call stdlib_wlarf( 'L', p-i+1, m-q-i+1, x11(i,i), 1,conjg(taup1(i)), x12(i,i),& + call stdlib_${ci}$larf( 'L', p-i+1, m-q-i+1, x11(i,i), 1,conjg(taup1(i)), x12(i,i),& ldx12, work ) - call stdlib_wlarf( 'L', m-p-i+1, m-q-i+1, x21(i,i), 1,conjg(taup2(i)), x22(i,& + call stdlib_${ci}$larf( 'L', m-p-i+1, m-q-i+1, x21(i,i), 1,conjg(taup2(i)), x22(i,& i), ldx22, work ) end if if( i < q ) then - call stdlib_wscal( q-i, cmplx( -z1*z3*sin(theta(i)), 0.0_qp,KIND=qp),x11(i,i+& + call stdlib_${ci}$scal( q-i, cmplx( -z1*z3*sin(theta(i)), 0.0_${ck}$,KIND=${ck}$),x11(i,i+& 1), ldx11 ) - call stdlib_waxpy( q-i, cmplx( z2*z3*cos(theta(i)), 0.0_qp,KIND=qp),x21(i,i+1)& + call stdlib_${ci}$axpy( q-i, cmplx( z2*z3*cos(theta(i)), 0.0_${ck}$,KIND=${ck}$),x21(i,i+1)& , ldx21, x11(i,i+1), ldx11 ) end if - call stdlib_wscal( m-q-i+1, cmplx( -z1*z4*sin(theta(i)), 0.0_qp,KIND=qp),x12(i,i)& + call stdlib_${ci}$scal( m-q-i+1, cmplx( -z1*z4*sin(theta(i)), 0.0_${ck}$,KIND=${ck}$),x12(i,i)& , ldx12 ) - call stdlib_waxpy( m-q-i+1, cmplx( z2*z4*cos(theta(i)), 0.0_qp,KIND=qp),x22(i,i),& + call stdlib_${ci}$axpy( m-q-i+1, cmplx( z2*z4*cos(theta(i)), 0.0_${ck}$,KIND=${ck}$),x22(i,i),& ldx22, x12(i,i), ldx12 ) - if( i < q )phi(i) = atan2( stdlib_qznrm2( q-i, x11(i,i+1), ldx11 ),stdlib_qznrm2(& + if( i < q )phi(i) = atan2( stdlib_${c2ri(ci)}$znrm2( q-i, x11(i,i+1), ldx11 ),stdlib_${c2ri(ci)}$znrm2(& m-q-i+1, x12(i,i), ldx12 ) ) if( i < q ) then - call stdlib_wlacgv( q-i, x11(i,i+1), ldx11 ) + call stdlib_${ci}$lacgv( q-i, x11(i,i+1), ldx11 ) if ( i == q-1 ) then - call stdlib_wlarfgp( q-i, x11(i,i+1), x11(i,i+1), ldx11,tauq1(i) ) + call stdlib_${ci}$larfgp( q-i, x11(i,i+1), x11(i,i+1), ldx11,tauq1(i) ) else - call stdlib_wlarfgp( q-i, x11(i,i+1), x11(i,i+2), ldx11,tauq1(i) ) + call stdlib_${ci}$larfgp( q-i, x11(i,i+1), x11(i,i+2), ldx11,tauq1(i) ) end if x11(i,i+1) = cone end if if ( m-q+1 > i ) then - call stdlib_wlacgv( m-q-i+1, x12(i,i), ldx12 ) + call stdlib_${ci}$lacgv( m-q-i+1, x12(i,i), ldx12 ) if ( m-q == i ) then - call stdlib_wlarfgp( m-q-i+1, x12(i,i), x12(i,i), ldx12,tauq2(i) ) + call stdlib_${ci}$larfgp( m-q-i+1, x12(i,i), x12(i,i), ldx12,tauq2(i) ) else - call stdlib_wlarfgp( m-q-i+1, x12(i,i), x12(i,i+1), ldx12,tauq2(i) ) + call stdlib_${ci}$larfgp( m-q-i+1, x12(i,i), x12(i,i+1), ldx12,tauq2(i) ) end if end if x12(i,i) = cone if( i < q ) then - call stdlib_wlarf( 'R', p-i, q-i, x11(i,i+1), ldx11, tauq1(i),x11(i+1,i+1), & + call stdlib_${ci}$larf( 'R', p-i, q-i, x11(i,i+1), ldx11, tauq1(i),x11(i+1,i+1), & ldx11, work ) - call stdlib_wlarf( 'R', m-p-i, q-i, x11(i,i+1), ldx11, tauq1(i),x21(i+1,i+1), & + call stdlib_${ci}$larf( 'R', m-p-i, q-i, x11(i,i+1), ldx11, tauq1(i),x21(i+1,i+1), & ldx21, work ) end if if ( p > i ) then - call stdlib_wlarf( 'R', p-i, m-q-i+1, x12(i,i), ldx12, tauq2(i),x12(i+1,i), & + call stdlib_${ci}$larf( 'R', p-i, m-q-i+1, x12(i,i), ldx12, tauq2(i),x12(i+1,i), & ldx12, work ) end if if ( m-p > i ) then - call stdlib_wlarf( 'R', m-p-i, m-q-i+1, x12(i,i), ldx12,tauq2(i), x22(i+1,i), & + call stdlib_${ci}$larf( 'R', m-p-i, m-q-i+1, x12(i,i), ldx12,tauq2(i), x22(i+1,i), & ldx22, work ) end if - if( i < q )call stdlib_wlacgv( q-i, x11(i,i+1), ldx11 ) - call stdlib_wlacgv( m-q-i+1, x12(i,i), ldx12 ) + if( i < q )call stdlib_${ci}$lacgv( q-i, x11(i,i+1), ldx11 ) + call stdlib_${ci}$lacgv( m-q-i+1, x12(i,i), ldx12 ) end do ! reduce columns q + 1, ..., p of x12, x22 do i = q + 1, p - call stdlib_wscal( m-q-i+1, cmplx( -z1*z4, 0.0_qp,KIND=qp), x12(i,i),ldx12 ) + call stdlib_${ci}$scal( m-q-i+1, cmplx( -z1*z4, 0.0_${ck}$,KIND=${ck}$), x12(i,i),ldx12 ) - call stdlib_wlacgv( m-q-i+1, x12(i,i), ldx12 ) + call stdlib_${ci}$lacgv( m-q-i+1, x12(i,i), ldx12 ) if ( i >= m-q ) then - call stdlib_wlarfgp( m-q-i+1, x12(i,i), x12(i,i), ldx12,tauq2(i) ) + call stdlib_${ci}$larfgp( m-q-i+1, x12(i,i), x12(i,i), ldx12,tauq2(i) ) else - call stdlib_wlarfgp( m-q-i+1, x12(i,i), x12(i,i+1), ldx12,tauq2(i) ) + call stdlib_${ci}$larfgp( m-q-i+1, x12(i,i), x12(i,i+1), ldx12,tauq2(i) ) end if x12(i,i) = cone if ( p > i ) then - call stdlib_wlarf( 'R', p-i, m-q-i+1, x12(i,i), ldx12, tauq2(i),x12(i+1,i), & + call stdlib_${ci}$larf( 'R', p-i, m-q-i+1, x12(i,i), ldx12, tauq2(i),x12(i+1,i), & ldx12, work ) end if - if( m-p-q >= 1 )call stdlib_wlarf( 'R', m-p-q, m-q-i+1, x12(i,i), ldx12,tauq2(i),& + if( m-p-q >= 1 )call stdlib_${ci}$larf( 'R', m-p-q, m-q-i+1, x12(i,i), ldx12,tauq2(i),& x22(q+1,i), ldx22, work ) - call stdlib_wlacgv( m-q-i+1, x12(i,i), ldx12 ) + call stdlib_${ci}$lacgv( m-q-i+1, x12(i,i), ldx12 ) end do ! reduce columns p + 1, ..., m - q of x12, x22 do i = 1, m - p - q - call stdlib_wscal( m-p-q-i+1, cmplx( z2*z4, 0.0_qp,KIND=qp),x22(q+i,p+i), ldx22 ) + call stdlib_${ci}$scal( m-p-q-i+1, cmplx( z2*z4, 0.0_${ck}$,KIND=${ck}$),x22(q+i,p+i), ldx22 ) - call stdlib_wlacgv( m-p-q-i+1, x22(q+i,p+i), ldx22 ) - call stdlib_wlarfgp( m-p-q-i+1, x22(q+i,p+i), x22(q+i,p+i+1),ldx22, tauq2(p+i) ) + call stdlib_${ci}$lacgv( m-p-q-i+1, x22(q+i,p+i), ldx22 ) + call stdlib_${ci}$larfgp( m-p-q-i+1, x22(q+i,p+i), x22(q+i,p+i+1),ldx22, tauq2(p+i) ) x22(q+i,p+i) = cone - call stdlib_wlarf( 'R', m-p-q-i, m-p-q-i+1, x22(q+i,p+i), ldx22,tauq2(p+i), x22(& + call stdlib_${ci}$larf( 'R', m-p-q-i, m-p-q-i+1, x22(q+i,p+i), ldx22,tauq2(p+i), x22(& q+i+1,p+i), ldx22, work ) - call stdlib_wlacgv( m-p-q-i+1, x22(q+i,p+i), ldx22 ) + call stdlib_${ci}$lacgv( m-p-q-i+1, x22(q+i,p+i), ldx22 ) end do else ! reduce columns 1, ..., q of x11, x12, x21, x22 do i = 1, q if( i == 1 ) then - call stdlib_wscal( p-i+1, cmplx( z1, 0.0_qp,KIND=qp), x11(i,i),ldx11 ) + call stdlib_${ci}$scal( p-i+1, cmplx( z1, 0.0_${ck}$,KIND=${ck}$), x11(i,i),ldx11 ) else - call stdlib_wscal( p-i+1, cmplx( z1*cos(phi(i-1)), 0.0_qp,KIND=qp),x11(i,i), & + call stdlib_${ci}$scal( p-i+1, cmplx( z1*cos(phi(i-1)), 0.0_${ck}$,KIND=${ck}$),x11(i,i), & ldx11 ) - call stdlib_waxpy( p-i+1, cmplx( -z1*z3*z4*sin(phi(i-1)),0.0_qp,KIND=qp), x12(& + call stdlib_${ci}$axpy( p-i+1, cmplx( -z1*z3*z4*sin(phi(i-1)),0.0_${ck}$,KIND=${ck}$), x12(& i-1,i), ldx12, x11(i,i), ldx11 ) end if if( i == 1 ) then - call stdlib_wscal( m-p-i+1, cmplx( z2, 0.0_qp,KIND=qp), x21(i,i),ldx21 ) + call stdlib_${ci}$scal( m-p-i+1, cmplx( z2, 0.0_${ck}$,KIND=${ck}$), x21(i,i),ldx21 ) else - call stdlib_wscal( m-p-i+1, cmplx( z2*cos(phi(i-1)), 0.0_qp,KIND=qp),x21(i,i),& + call stdlib_${ci}$scal( m-p-i+1, cmplx( z2*cos(phi(i-1)), 0.0_${ck}$,KIND=${ck}$),x21(i,i),& ldx21 ) - call stdlib_waxpy( m-p-i+1, cmplx( -z2*z3*z4*sin(phi(i-1)),0.0_qp,KIND=qp), & + call stdlib_${ci}$axpy( m-p-i+1, cmplx( -z2*z3*z4*sin(phi(i-1)),0.0_${ck}$,KIND=${ck}$), & x22(i-1,i), ldx22, x21(i,i), ldx21 ) end if - theta(i) = atan2( stdlib_qznrm2( m-p-i+1, x21(i,i), ldx21 ),stdlib_qznrm2( p-i+1,& + theta(i) = atan2( stdlib_${c2ri(ci)}$znrm2( m-p-i+1, x21(i,i), ldx21 ),stdlib_${c2ri(ci)}$znrm2( p-i+1,& x11(i,i), ldx11 ) ) - call stdlib_wlacgv( p-i+1, x11(i,i), ldx11 ) - call stdlib_wlacgv( m-p-i+1, x21(i,i), ldx21 ) - call stdlib_wlarfgp( p-i+1, x11(i,i), x11(i,i+1), ldx11, taup1(i) ) + call stdlib_${ci}$lacgv( p-i+1, x11(i,i), ldx11 ) + call stdlib_${ci}$lacgv( m-p-i+1, x21(i,i), ldx21 ) + call stdlib_${ci}$larfgp( p-i+1, x11(i,i), x11(i,i+1), ldx11, taup1(i) ) x11(i,i) = cone if ( i == m-p ) then - call stdlib_wlarfgp( m-p-i+1, x21(i,i), x21(i,i), ldx21,taup2(i) ) + call stdlib_${ci}$larfgp( m-p-i+1, x21(i,i), x21(i,i), ldx21,taup2(i) ) else - call stdlib_wlarfgp( m-p-i+1, x21(i,i), x21(i,i+1), ldx21,taup2(i) ) + call stdlib_${ci}$larfgp( m-p-i+1, x21(i,i), x21(i,i+1), ldx21,taup2(i) ) end if x21(i,i) = cone - call stdlib_wlarf( 'R', q-i, p-i+1, x11(i,i), ldx11, taup1(i),x11(i+1,i), ldx11, & + call stdlib_${ci}$larf( 'R', q-i, p-i+1, x11(i,i), ldx11, taup1(i),x11(i+1,i), ldx11, & work ) - call stdlib_wlarf( 'R', m-q-i+1, p-i+1, x11(i,i), ldx11, taup1(i),x12(i,i), & + call stdlib_${ci}$larf( 'R', m-q-i+1, p-i+1, x11(i,i), ldx11, taup1(i),x12(i,i), & ldx12, work ) - call stdlib_wlarf( 'R', q-i, m-p-i+1, x21(i,i), ldx21, taup2(i),x21(i+1,i), & + call stdlib_${ci}$larf( 'R', q-i, m-p-i+1, x21(i,i), ldx21, taup2(i),x21(i+1,i), & ldx21, work ) - call stdlib_wlarf( 'R', m-q-i+1, m-p-i+1, x21(i,i), ldx21,taup2(i), x22(i,i), & + call stdlib_${ci}$larf( 'R', m-q-i+1, m-p-i+1, x21(i,i), ldx21,taup2(i), x22(i,i), & ldx22, work ) - call stdlib_wlacgv( p-i+1, x11(i,i), ldx11 ) - call stdlib_wlacgv( m-p-i+1, x21(i,i), ldx21 ) + call stdlib_${ci}$lacgv( p-i+1, x11(i,i), ldx11 ) + call stdlib_${ci}$lacgv( m-p-i+1, x21(i,i), ldx21 ) if( i < q ) then - call stdlib_wscal( q-i, cmplx( -z1*z3*sin(theta(i)), 0.0_qp,KIND=qp),x11(i+1,& + call stdlib_${ci}$scal( q-i, cmplx( -z1*z3*sin(theta(i)), 0.0_${ck}$,KIND=${ck}$),x11(i+1,& i), 1 ) - call stdlib_waxpy( q-i, cmplx( z2*z3*cos(theta(i)), 0.0_qp,KIND=qp),x21(i+1,i)& + call stdlib_${ci}$axpy( q-i, cmplx( z2*z3*cos(theta(i)), 0.0_${ck}$,KIND=${ck}$),x21(i+1,i)& , 1, x11(i+1,i), 1 ) end if - call stdlib_wscal( m-q-i+1, cmplx( -z1*z4*sin(theta(i)), 0.0_qp,KIND=qp),x12(i,i)& + call stdlib_${ci}$scal( m-q-i+1, cmplx( -z1*z4*sin(theta(i)), 0.0_${ck}$,KIND=${ck}$),x12(i,i)& , 1 ) - call stdlib_waxpy( m-q-i+1, cmplx( z2*z4*cos(theta(i)), 0.0_qp,KIND=qp),x22(i,i),& + call stdlib_${ci}$axpy( m-q-i+1, cmplx( z2*z4*cos(theta(i)), 0.0_${ck}$,KIND=${ck}$),x22(i,i),& 1, x12(i,i), 1 ) - if( i < q )phi(i) = atan2( stdlib_qznrm2( q-i, x11(i+1,i), 1 ),stdlib_qznrm2( m-& + if( i < q )phi(i) = atan2( stdlib_${c2ri(ci)}$znrm2( q-i, x11(i+1,i), 1 ),stdlib_${c2ri(ci)}$znrm2( m-& q-i+1, x12(i,i), 1 ) ) if( i < q ) then - call stdlib_wlarfgp( q-i, x11(i+1,i), x11(i+2,i), 1, tauq1(i) ) + call stdlib_${ci}$larfgp( q-i, x11(i+1,i), x11(i+2,i), 1, tauq1(i) ) x11(i+1,i) = cone end if - call stdlib_wlarfgp( m-q-i+1, x12(i,i), x12(i+1,i), 1, tauq2(i) ) + call stdlib_${ci}$larfgp( m-q-i+1, x12(i,i), x12(i+1,i), 1, tauq2(i) ) x12(i,i) = cone if( i < q ) then - call stdlib_wlarf( 'L', q-i, p-i, x11(i+1,i), 1,conjg(tauq1(i)), x11(i+1,i+1),& + call stdlib_${ci}$larf( 'L', q-i, p-i, x11(i+1,i), 1,conjg(tauq1(i)), x11(i+1,i+1),& ldx11, work ) - call stdlib_wlarf( 'L', q-i, m-p-i, x11(i+1,i), 1,conjg(tauq1(i)), x21(i+1,i+& + call stdlib_${ci}$larf( 'L', q-i, m-p-i, x11(i+1,i), 1,conjg(tauq1(i)), x21(i+1,i+& 1), ldx21, work ) end if - call stdlib_wlarf( 'L', m-q-i+1, p-i, x12(i,i), 1,conjg(tauq2(i)), x12(i,i+1), & + call stdlib_${ci}$larf( 'L', m-q-i+1, p-i, x12(i,i), 1,conjg(tauq2(i)), x12(i,i+1), & ldx12, work ) if ( m-p > i ) then - call stdlib_wlarf( 'L', m-q-i+1, m-p-i, x12(i,i), 1,conjg(tauq2(i)), x22(i,i+& + call stdlib_${ci}$larf( 'L', m-q-i+1, m-p-i, x12(i,i), 1,conjg(tauq2(i)), x22(i,i+& 1), ldx22, work ) end if end do ! reduce columns q + 1, ..., p of x12, x22 do i = q + 1, p - call stdlib_wscal( m-q-i+1, cmplx( -z1*z4, 0.0_qp,KIND=qp), x12(i,i), 1 ) - call stdlib_wlarfgp( m-q-i+1, x12(i,i), x12(i+1,i), 1, tauq2(i) ) + call stdlib_${ci}$scal( m-q-i+1, cmplx( -z1*z4, 0.0_${ck}$,KIND=${ck}$), x12(i,i), 1 ) + call stdlib_${ci}$larfgp( m-q-i+1, x12(i,i), x12(i+1,i), 1, tauq2(i) ) x12(i,i) = cone if ( p > i ) then - call stdlib_wlarf( 'L', m-q-i+1, p-i, x12(i,i), 1,conjg(tauq2(i)), x12(i,i+1),& + call stdlib_${ci}$larf( 'L', m-q-i+1, p-i, x12(i,i), 1,conjg(tauq2(i)), x12(i,i+1),& ldx12, work ) end if - if( m-p-q >= 1 )call stdlib_wlarf( 'L', m-q-i+1, m-p-q, x12(i,i), 1,conjg(tauq2(& + if( m-p-q >= 1 )call stdlib_${ci}$larf( 'L', m-q-i+1, m-p-q, x12(i,i), 1,conjg(tauq2(& i)), x22(i,q+1), ldx22, work ) end do ! reduce columns p + 1, ..., m - q of x12, x22 do i = 1, m - p - q - call stdlib_wscal( m-p-q-i+1, cmplx( z2*z4, 0.0_qp,KIND=qp),x22(p+i,q+i), 1 ) + call stdlib_${ci}$scal( m-p-q-i+1, cmplx( z2*z4, 0.0_${ck}$,KIND=${ck}$),x22(p+i,q+i), 1 ) - call stdlib_wlarfgp( m-p-q-i+1, x22(p+i,q+i), x22(p+i+1,q+i), 1,tauq2(p+i) ) + call stdlib_${ci}$larfgp( m-p-q-i+1, x22(p+i,q+i), x22(p+i+1,q+i), 1,tauq2(p+i) ) x22(p+i,q+i) = cone if ( m-p-q /= i ) then - call stdlib_wlarf( 'L', m-p-q-i+1, m-p-q-i, x22(p+i,q+i), 1,conjg(tauq2(p+i)),& + call stdlib_${ci}$larf( 'L', m-p-q-i+1, m-p-q-i, x22(p+i,q+i), 1,conjg(tauq2(p+i)),& x22(p+i,q+i+1), ldx22,work ) end if end do end if return - end subroutine stdlib_wunbdb + end subroutine stdlib_${ci}$unbdb - subroutine stdlib_wunbdb1( m, p, q, x11, ldx11, x21, ldx21, theta, phi,taup1, taup2, tauq1, & + subroutine stdlib_${ci}$unbdb1( m, p, q, x11, ldx11, x21, ldx21, theta, phi,taup1, taup2, tauq1, & !! ZUNBDB1: simultaneously bidiagonalizes the blocks of a tall and skinny !! matrix X with orthonomal columns: !! [ B11 ] @@ -76304,13 +76306,13 @@ module stdlib_linalg_lapack_w integer(ilp), intent(out) :: info integer(ilp), intent(in) :: lwork, m, p, q, ldx11, ldx21 ! Array Arguments - real(qp), intent(out) :: phi(*), theta(*) - complex(qp), intent(out) :: taup1(*), taup2(*), tauq1(*), work(*) - complex(qp), intent(inout) :: x11(ldx11,*), x21(ldx21,*) + real(${ck}$), intent(out) :: phi(*), theta(*) + complex(${ck}$), intent(out) :: taup1(*), taup2(*), tauq1(*), work(*) + complex(${ck}$), intent(inout) :: x11(ldx11,*), x21(ldx21,*) ! ==================================================================== ! Local Scalars - real(qp) :: c, s + real(${ck}$) :: c, s integer(ilp) :: childinfo, i, ilarf, iorbdb5, llarf, lorbdb5, lworkmin, & lworkopt logical(lk) :: lquery @@ -76352,40 +76354,40 @@ module stdlib_linalg_lapack_w end if ! reduce columns 1, ..., q of x11 and x21 do i = 1, q - call stdlib_wlarfgp( p-i+1, x11(i,i), x11(i+1,i), 1, taup1(i) ) - call stdlib_wlarfgp( m-p-i+1, x21(i,i), x21(i+1,i), 1, taup2(i) ) - theta(i) = atan2( real( x21(i,i),KIND=qp), real( x11(i,i),KIND=qp) ) + call stdlib_${ci}$larfgp( p-i+1, x11(i,i), x11(i+1,i), 1, taup1(i) ) + call stdlib_${ci}$larfgp( m-p-i+1, x21(i,i), x21(i+1,i), 1, taup2(i) ) + theta(i) = atan2( real( x21(i,i),KIND=${ck}$), real( x11(i,i),KIND=${ck}$) ) c = cos( theta(i) ) s = sin( theta(i) ) x11(i,i) = cone x21(i,i) = cone - call stdlib_wlarf( 'L', p-i+1, q-i, x11(i,i), 1, conjg(taup1(i)),x11(i,i+1), ldx11, & + call stdlib_${ci}$larf( 'L', p-i+1, q-i, x11(i,i), 1, conjg(taup1(i)),x11(i,i+1), ldx11, & work(ilarf) ) - call stdlib_wlarf( 'L', m-p-i+1, q-i, x21(i,i), 1, conjg(taup2(i)),x21(i,i+1), & + call stdlib_${ci}$larf( 'L', m-p-i+1, q-i, x21(i,i), 1, conjg(taup2(i)),x21(i,i+1), & ldx21, work(ilarf) ) if( i < q ) then - call stdlib_wdrot( q-i, x11(i,i+1), ldx11, x21(i,i+1), ldx21, c,s ) - call stdlib_wlacgv( q-i, x21(i,i+1), ldx21 ) - call stdlib_wlarfgp( q-i, x21(i,i+1), x21(i,i+2), ldx21, tauq1(i) ) - s = real( x21(i,i+1),KIND=qp) + call stdlib_${ci}$drot( q-i, x11(i,i+1), ldx11, x21(i,i+1), ldx21, c,s ) + call stdlib_${ci}$lacgv( q-i, x21(i,i+1), ldx21 ) + call stdlib_${ci}$larfgp( q-i, x21(i,i+1), x21(i,i+2), ldx21, tauq1(i) ) + s = real( x21(i,i+1),KIND=${ck}$) x21(i,i+1) = cone - call stdlib_wlarf( 'R', p-i, q-i, x21(i,i+1), ldx21, tauq1(i),x11(i+1,i+1), & + call stdlib_${ci}$larf( 'R', p-i, q-i, x21(i,i+1), ldx21, tauq1(i),x11(i+1,i+1), & ldx11, work(ilarf) ) - call stdlib_wlarf( 'R', m-p-i, q-i, x21(i,i+1), ldx21, tauq1(i),x21(i+1,i+1), & + call stdlib_${ci}$larf( 'R', m-p-i, q-i, x21(i,i+1), ldx21, tauq1(i),x21(i+1,i+1), & ldx21, work(ilarf) ) - call stdlib_wlacgv( q-i, x21(i,i+1), ldx21 ) - c = sqrt( stdlib_qznrm2( p-i, x11(i+1,i+1), 1 )**2+ stdlib_qznrm2( m-p-i, x21(i+& + call stdlib_${ci}$lacgv( q-i, x21(i,i+1), ldx21 ) + c = sqrt( stdlib_${c2ri(ci)}$znrm2( p-i, x11(i+1,i+1), 1 )**2+ stdlib_${c2ri(ci)}$znrm2( m-p-i, x21(i+& 1,i+1), 1 )**2 ) phi(i) = atan2( s, c ) - call stdlib_wunbdb5( p-i, m-p-i, q-i-1, x11(i+1,i+1), 1,x21(i+1,i+1), 1, x11(i+1,& + call stdlib_${ci}$unbdb5( p-i, m-p-i, q-i-1, x11(i+1,i+1), 1,x21(i+1,i+1), 1, x11(i+1,& i+2), ldx11,x21(i+1,i+2), ldx21, work(iorbdb5), lorbdb5,childinfo ) end if end do return - end subroutine stdlib_wunbdb1 + end subroutine stdlib_${ci}$unbdb1 - subroutine stdlib_wunbdb2( m, p, q, x11, ldx11, x21, ldx21, theta, phi,taup1, taup2, tauq1, & + subroutine stdlib_${ci}$unbdb2( m, p, q, x11, ldx11, x21, ldx21, theta, phi,taup1, taup2, tauq1, & !! ZUNBDB2: simultaneously bidiagonalizes the blocks of a tall and skinny !! matrix X with orthonomal columns: !! [ B11 ] @@ -76409,13 +76411,13 @@ module stdlib_linalg_lapack_w integer(ilp), intent(out) :: info integer(ilp), intent(in) :: lwork, m, p, q, ldx11, ldx21 ! Array Arguments - real(qp), intent(out) :: phi(*), theta(*) - complex(qp), intent(out) :: taup1(*), taup2(*), tauq1(*), work(*) - complex(qp), intent(inout) :: x11(ldx11,*), x21(ldx21,*) + real(${ck}$), intent(out) :: phi(*), theta(*) + complex(${ck}$), intent(out) :: taup1(*), taup2(*), tauq1(*), work(*) + complex(${ck}$), intent(inout) :: x11(ldx11,*), x21(ldx21,*) ! ==================================================================== ! Local Scalars - real(qp) :: c, s + real(${ck}$) :: c, s integer(ilp) :: childinfo, i, ilarf, iorbdb5, llarf, lorbdb5, lworkmin, & lworkopt logical(lk) :: lquery @@ -76458,49 +76460,49 @@ module stdlib_linalg_lapack_w ! reduce rows 1, ..., p of x11 and x21 do i = 1, p if( i > 1 ) then - call stdlib_wdrot( q-i+1, x11(i,i), ldx11, x21(i-1,i), ldx21, c,s ) + call stdlib_${ci}$drot( q-i+1, x11(i,i), ldx11, x21(i-1,i), ldx21, c,s ) end if - call stdlib_wlacgv( q-i+1, x11(i,i), ldx11 ) - call stdlib_wlarfgp( q-i+1, x11(i,i), x11(i,i+1), ldx11, tauq1(i) ) - c = real( x11(i,i),KIND=qp) + call stdlib_${ci}$lacgv( q-i+1, x11(i,i), ldx11 ) + call stdlib_${ci}$larfgp( q-i+1, x11(i,i), x11(i,i+1), ldx11, tauq1(i) ) + c = real( x11(i,i),KIND=${ck}$) x11(i,i) = cone - call stdlib_wlarf( 'R', p-i, q-i+1, x11(i,i), ldx11, tauq1(i),x11(i+1,i), ldx11, & + call stdlib_${ci}$larf( 'R', p-i, q-i+1, x11(i,i), ldx11, tauq1(i),x11(i+1,i), ldx11, & work(ilarf) ) - call stdlib_wlarf( 'R', m-p-i+1, q-i+1, x11(i,i), ldx11, tauq1(i),x21(i,i), ldx21, & + call stdlib_${ci}$larf( 'R', m-p-i+1, q-i+1, x11(i,i), ldx11, tauq1(i),x21(i,i), ldx21, & work(ilarf) ) - call stdlib_wlacgv( q-i+1, x11(i,i), ldx11 ) - s = sqrt( stdlib_qznrm2( p-i, x11(i+1,i), 1 )**2+ stdlib_qznrm2( m-p-i+1, x21(i,i), & + call stdlib_${ci}$lacgv( q-i+1, x11(i,i), ldx11 ) + s = sqrt( stdlib_${c2ri(ci)}$znrm2( p-i, x11(i+1,i), 1 )**2+ stdlib_${c2ri(ci)}$znrm2( m-p-i+1, x21(i,i), & 1 )**2 ) theta(i) = atan2( s, c ) - call stdlib_wunbdb5( p-i, m-p-i+1, q-i, x11(i+1,i), 1, x21(i,i), 1,x11(i+1,i+1), & + call stdlib_${ci}$unbdb5( p-i, m-p-i+1, q-i, x11(i+1,i), 1, x21(i,i), 1,x11(i+1,i+1), & ldx11, x21(i,i+1), ldx21,work(iorbdb5), lorbdb5, childinfo ) - call stdlib_wscal( p-i, cnegone, x11(i+1,i), 1 ) - call stdlib_wlarfgp( m-p-i+1, x21(i,i), x21(i+1,i), 1, taup2(i) ) + call stdlib_${ci}$scal( p-i, cnegone, x11(i+1,i), 1 ) + call stdlib_${ci}$larfgp( m-p-i+1, x21(i,i), x21(i+1,i), 1, taup2(i) ) if( i < p ) then - call stdlib_wlarfgp( p-i, x11(i+1,i), x11(i+2,i), 1, taup1(i) ) - phi(i) = atan2( real( x11(i+1,i),KIND=qp), real( x21(i,i),KIND=qp) ) + call stdlib_${ci}$larfgp( p-i, x11(i+1,i), x11(i+2,i), 1, taup1(i) ) + phi(i) = atan2( real( x11(i+1,i),KIND=${ck}$), real( x21(i,i),KIND=${ck}$) ) c = cos( phi(i) ) s = sin( phi(i) ) x11(i+1,i) = cone - call stdlib_wlarf( 'L', p-i, q-i, x11(i+1,i), 1, conjg(taup1(i)),x11(i+1,i+1), & + call stdlib_${ci}$larf( 'L', p-i, q-i, x11(i+1,i), 1, conjg(taup1(i)),x11(i+1,i+1), & ldx11, work(ilarf) ) end if x21(i,i) = cone - call stdlib_wlarf( 'L', m-p-i+1, q-i, x21(i,i), 1, conjg(taup2(i)),x21(i,i+1), & + call stdlib_${ci}$larf( 'L', m-p-i+1, q-i, x21(i,i), 1, conjg(taup2(i)),x21(i,i+1), & ldx21, work(ilarf) ) end do ! reduce the bottom-right portion of x21 to the identity matrix do i = p + 1, q - call stdlib_wlarfgp( m-p-i+1, x21(i,i), x21(i+1,i), 1, taup2(i) ) + call stdlib_${ci}$larfgp( m-p-i+1, x21(i,i), x21(i+1,i), 1, taup2(i) ) x21(i,i) = cone - call stdlib_wlarf( 'L', m-p-i+1, q-i, x21(i,i), 1, conjg(taup2(i)),x21(i,i+1), & + call stdlib_${ci}$larf( 'L', m-p-i+1, q-i, x21(i,i), 1, conjg(taup2(i)),x21(i,i+1), & ldx21, work(ilarf) ) end do return - end subroutine stdlib_wunbdb2 + end subroutine stdlib_${ci}$unbdb2 - subroutine stdlib_wunbdb3( m, p, q, x11, ldx11, x21, ldx21, theta, phi,taup1, taup2, tauq1, & + subroutine stdlib_${ci}$unbdb3( m, p, q, x11, ldx11, x21, ldx21, theta, phi,taup1, taup2, tauq1, & !! ZUNBDB3: simultaneously bidiagonalizes the blocks of a tall and skinny !! matrix X with orthonomal columns: !! [ B11 ] @@ -76524,13 +76526,13 @@ module stdlib_linalg_lapack_w integer(ilp), intent(out) :: info integer(ilp), intent(in) :: lwork, m, p, q, ldx11, ldx21 ! Array Arguments - real(qp), intent(out) :: phi(*), theta(*) - complex(qp), intent(out) :: taup1(*), taup2(*), tauq1(*), work(*) - complex(qp), intent(inout) :: x11(ldx11,*), x21(ldx21,*) + real(${ck}$), intent(out) :: phi(*), theta(*) + complex(${ck}$), intent(out) :: taup1(*), taup2(*), tauq1(*), work(*) + complex(${ck}$), intent(inout) :: x11(ldx11,*), x21(ldx21,*) ! ==================================================================== ! Local Scalars - real(qp) :: c, s + real(${ck}$) :: c, s integer(ilp) :: childinfo, i, ilarf, iorbdb5, llarf, lorbdb5, lworkmin, & lworkopt logical(lk) :: lquery @@ -76573,48 +76575,48 @@ module stdlib_linalg_lapack_w ! reduce rows 1, ..., m-p of x11 and x21 do i = 1, m-p if( i > 1 ) then - call stdlib_wdrot( q-i+1, x11(i-1,i), ldx11, x21(i,i), ldx11, c,s ) + call stdlib_${ci}$drot( q-i+1, x11(i-1,i), ldx11, x21(i,i), ldx11, c,s ) end if - call stdlib_wlacgv( q-i+1, x21(i,i), ldx21 ) - call stdlib_wlarfgp( q-i+1, x21(i,i), x21(i,i+1), ldx21, tauq1(i) ) - s = real( x21(i,i),KIND=qp) + call stdlib_${ci}$lacgv( q-i+1, x21(i,i), ldx21 ) + call stdlib_${ci}$larfgp( q-i+1, x21(i,i), x21(i,i+1), ldx21, tauq1(i) ) + s = real( x21(i,i),KIND=${ck}$) x21(i,i) = cone - call stdlib_wlarf( 'R', p-i+1, q-i+1, x21(i,i), ldx21, tauq1(i),x11(i,i), ldx11, & + call stdlib_${ci}$larf( 'R', p-i+1, q-i+1, x21(i,i), ldx21, tauq1(i),x11(i,i), ldx11, & work(ilarf) ) - call stdlib_wlarf( 'R', m-p-i, q-i+1, x21(i,i), ldx21, tauq1(i),x21(i+1,i), ldx21, & + call stdlib_${ci}$larf( 'R', m-p-i, q-i+1, x21(i,i), ldx21, tauq1(i),x21(i+1,i), ldx21, & work(ilarf) ) - call stdlib_wlacgv( q-i+1, x21(i,i), ldx21 ) - c = sqrt( stdlib_qznrm2( p-i+1, x11(i,i), 1 )**2+ stdlib_qznrm2( m-p-i, x21(i+1,i), & + call stdlib_${ci}$lacgv( q-i+1, x21(i,i), ldx21 ) + c = sqrt( stdlib_${c2ri(ci)}$znrm2( p-i+1, x11(i,i), 1 )**2+ stdlib_${c2ri(ci)}$znrm2( m-p-i, x21(i+1,i), & 1 )**2 ) theta(i) = atan2( s, c ) - call stdlib_wunbdb5( p-i+1, m-p-i, q-i, x11(i,i), 1, x21(i+1,i), 1,x11(i,i+1), & + call stdlib_${ci}$unbdb5( p-i+1, m-p-i, q-i, x11(i,i), 1, x21(i+1,i), 1,x11(i,i+1), & ldx11, x21(i+1,i+1), ldx21,work(iorbdb5), lorbdb5, childinfo ) - call stdlib_wlarfgp( p-i+1, x11(i,i), x11(i+1,i), 1, taup1(i) ) + call stdlib_${ci}$larfgp( p-i+1, x11(i,i), x11(i+1,i), 1, taup1(i) ) if( i < m-p ) then - call stdlib_wlarfgp( m-p-i, x21(i+1,i), x21(i+2,i), 1, taup2(i) ) - phi(i) = atan2( real( x21(i+1,i),KIND=qp), real( x11(i,i),KIND=qp) ) + call stdlib_${ci}$larfgp( m-p-i, x21(i+1,i), x21(i+2,i), 1, taup2(i) ) + phi(i) = atan2( real( x21(i+1,i),KIND=${ck}$), real( x11(i,i),KIND=${ck}$) ) c = cos( phi(i) ) s = sin( phi(i) ) x21(i+1,i) = cone - call stdlib_wlarf( 'L', m-p-i, q-i, x21(i+1,i), 1,conjg(taup2(i)), x21(i+1,i+1), & + call stdlib_${ci}$larf( 'L', m-p-i, q-i, x21(i+1,i), 1,conjg(taup2(i)), x21(i+1,i+1), & ldx21,work(ilarf) ) end if x11(i,i) = cone - call stdlib_wlarf( 'L', p-i+1, q-i, x11(i,i), 1, conjg(taup1(i)),x11(i,i+1), ldx11, & + call stdlib_${ci}$larf( 'L', p-i+1, q-i, x11(i,i), 1, conjg(taup1(i)),x11(i,i+1), ldx11, & work(ilarf) ) end do ! reduce the bottom-right portion of x11 to the identity matrix do i = m-p + 1, q - call stdlib_wlarfgp( p-i+1, x11(i,i), x11(i+1,i), 1, taup1(i) ) + call stdlib_${ci}$larfgp( p-i+1, x11(i,i), x11(i+1,i), 1, taup1(i) ) x11(i,i) = cone - call stdlib_wlarf( 'L', p-i+1, q-i, x11(i,i), 1, conjg(taup1(i)),x11(i,i+1), ldx11, & + call stdlib_${ci}$larf( 'L', p-i+1, q-i, x11(i,i), 1, conjg(taup1(i)),x11(i,i+1), ldx11, & work(ilarf) ) end do return - end subroutine stdlib_wunbdb3 + end subroutine stdlib_${ci}$unbdb3 - subroutine stdlib_wunbdb4( m, p, q, x11, ldx11, x21, ldx21, theta, phi,taup1, taup2, tauq1, & + subroutine stdlib_${ci}$unbdb4( m, p, q, x11, ldx11, x21, ldx21, theta, phi,taup1, taup2, tauq1, & !! ZUNBDB4: simultaneously bidiagonalizes the blocks of a tall and skinny !! matrix X with orthonomal columns: !! [ B11 ] @@ -76638,13 +76640,13 @@ module stdlib_linalg_lapack_w integer(ilp), intent(out) :: info integer(ilp), intent(in) :: lwork, m, p, q, ldx11, ldx21 ! Array Arguments - real(qp), intent(out) :: phi(*), theta(*) - complex(qp), intent(out) :: phantom(*), taup1(*), taup2(*), tauq1(*), work(*) - complex(qp), intent(inout) :: x11(ldx11,*), x21(ldx21,*) + real(${ck}$), intent(out) :: phi(*), theta(*) + complex(${ck}$), intent(out) :: phantom(*), taup1(*), taup2(*), tauq1(*), work(*) + complex(${ck}$), intent(inout) :: x11(ldx11,*), x21(ldx21,*) ! ==================================================================== ! Local Scalars - real(qp) :: c, s + real(${ck}$) :: c, s integer(ilp) :: childinfo, i, ilarf, iorbdb5, j, llarf, lorbdb5, lworkmin, & lworkopt logical(lk) :: lquery @@ -76691,79 +76693,79 @@ module stdlib_linalg_lapack_w do j = 1, m phantom(j) = czero end do - call stdlib_wunbdb5( p, m-p, q, phantom(1), 1, phantom(p+1), 1,x11, ldx11, x21, & + call stdlib_${ci}$unbdb5( p, m-p, q, phantom(1), 1, phantom(p+1), 1,x11, ldx11, x21, & ldx21, work(iorbdb5),lorbdb5, childinfo ) - call stdlib_wscal( p, cnegone, phantom(1), 1 ) - call stdlib_wlarfgp( p, phantom(1), phantom(2), 1, taup1(1) ) - call stdlib_wlarfgp( m-p, phantom(p+1), phantom(p+2), 1, taup2(1) ) - theta(i) = atan2( real( phantom(1),KIND=qp), real( phantom(p+1),KIND=qp) ) + call stdlib_${ci}$scal( p, cnegone, phantom(1), 1 ) + call stdlib_${ci}$larfgp( p, phantom(1), phantom(2), 1, taup1(1) ) + call stdlib_${ci}$larfgp( m-p, phantom(p+1), phantom(p+2), 1, taup2(1) ) + theta(i) = atan2( real( phantom(1),KIND=${ck}$), real( phantom(p+1),KIND=${ck}$) ) c = cos( theta(i) ) s = sin( theta(i) ) phantom(1) = cone phantom(p+1) = cone - call stdlib_wlarf( 'L', p, q, phantom(1), 1, conjg(taup1(1)), x11,ldx11, work(& + call stdlib_${ci}$larf( 'L', p, q, phantom(1), 1, conjg(taup1(1)), x11,ldx11, work(& ilarf) ) - call stdlib_wlarf( 'L', m-p, q, phantom(p+1), 1, conjg(taup2(1)),x21, ldx21, & + call stdlib_${ci}$larf( 'L', m-p, q, phantom(p+1), 1, conjg(taup2(1)),x21, ldx21, & work(ilarf) ) else - call stdlib_wunbdb5( p-i+1, m-p-i+1, q-i+1, x11(i,i-1), 1,x21(i,i-1), 1, x11(i,i)& + call stdlib_${ci}$unbdb5( p-i+1, m-p-i+1, q-i+1, x11(i,i-1), 1,x21(i,i-1), 1, x11(i,i)& , ldx11, x21(i,i),ldx21, work(iorbdb5), lorbdb5, childinfo ) - call stdlib_wscal( p-i+1, cnegone, x11(i,i-1), 1 ) - call stdlib_wlarfgp( p-i+1, x11(i,i-1), x11(i+1,i-1), 1, taup1(i) ) - call stdlib_wlarfgp( m-p-i+1, x21(i,i-1), x21(i+1,i-1), 1,taup2(i) ) - theta(i) = atan2( real( x11(i,i-1),KIND=qp), real( x21(i,i-1),KIND=qp) ) + call stdlib_${ci}$scal( p-i+1, cnegone, x11(i,i-1), 1 ) + call stdlib_${ci}$larfgp( p-i+1, x11(i,i-1), x11(i+1,i-1), 1, taup1(i) ) + call stdlib_${ci}$larfgp( m-p-i+1, x21(i,i-1), x21(i+1,i-1), 1,taup2(i) ) + theta(i) = atan2( real( x11(i,i-1),KIND=${ck}$), real( x21(i,i-1),KIND=${ck}$) ) c = cos( theta(i) ) s = sin( theta(i) ) x11(i,i-1) = cone x21(i,i-1) = cone - call stdlib_wlarf( 'L', p-i+1, q-i+1, x11(i,i-1), 1,conjg(taup1(i)), x11(i,i), & + call stdlib_${ci}$larf( 'L', p-i+1, q-i+1, x11(i,i-1), 1,conjg(taup1(i)), x11(i,i), & ldx11, work(ilarf) ) - call stdlib_wlarf( 'L', m-p-i+1, q-i+1, x21(i,i-1), 1,conjg(taup2(i)), x21(i,i), & + call stdlib_${ci}$larf( 'L', m-p-i+1, q-i+1, x21(i,i-1), 1,conjg(taup2(i)), x21(i,i), & ldx21, work(ilarf) ) end if - call stdlib_wdrot( q-i+1, x11(i,i), ldx11, x21(i,i), ldx21, s, -c ) - call stdlib_wlacgv( q-i+1, x21(i,i), ldx21 ) - call stdlib_wlarfgp( q-i+1, x21(i,i), x21(i,i+1), ldx21, tauq1(i) ) - c = real( x21(i,i),KIND=qp) + call stdlib_${ci}$drot( q-i+1, x11(i,i), ldx11, x21(i,i), ldx21, s, -c ) + call stdlib_${ci}$lacgv( q-i+1, x21(i,i), ldx21 ) + call stdlib_${ci}$larfgp( q-i+1, x21(i,i), x21(i,i+1), ldx21, tauq1(i) ) + c = real( x21(i,i),KIND=${ck}$) x21(i,i) = cone - call stdlib_wlarf( 'R', p-i, q-i+1, x21(i,i), ldx21, tauq1(i),x11(i+1,i), ldx11, & + call stdlib_${ci}$larf( 'R', p-i, q-i+1, x21(i,i), ldx21, tauq1(i),x11(i+1,i), ldx11, & work(ilarf) ) - call stdlib_wlarf( 'R', m-p-i, q-i+1, x21(i,i), ldx21, tauq1(i),x21(i+1,i), ldx21, & + call stdlib_${ci}$larf( 'R', m-p-i, q-i+1, x21(i,i), ldx21, tauq1(i),x21(i+1,i), ldx21, & work(ilarf) ) - call stdlib_wlacgv( q-i+1, x21(i,i), ldx21 ) + call stdlib_${ci}$lacgv( q-i+1, x21(i,i), ldx21 ) if( i < m-q ) then - s = sqrt( stdlib_qznrm2( p-i, x11(i+1,i), 1 )**2+ stdlib_qznrm2( m-p-i, x21(i+1,& + s = sqrt( stdlib_${c2ri(ci)}$znrm2( p-i, x11(i+1,i), 1 )**2+ stdlib_${c2ri(ci)}$znrm2( m-p-i, x21(i+1,& i), 1 )**2 ) phi(i) = atan2( s, c ) end if end do ! reduce the bottom-right portion of x11 to [ i 0 ] do i = m - q + 1, p - call stdlib_wlacgv( q-i+1, x11(i,i), ldx11 ) - call stdlib_wlarfgp( q-i+1, x11(i,i), x11(i,i+1), ldx11, tauq1(i) ) + call stdlib_${ci}$lacgv( q-i+1, x11(i,i), ldx11 ) + call stdlib_${ci}$larfgp( q-i+1, x11(i,i), x11(i,i+1), ldx11, tauq1(i) ) x11(i,i) = cone - call stdlib_wlarf( 'R', p-i, q-i+1, x11(i,i), ldx11, tauq1(i),x11(i+1,i), ldx11, & + call stdlib_${ci}$larf( 'R', p-i, q-i+1, x11(i,i), ldx11, tauq1(i),x11(i+1,i), ldx11, & work(ilarf) ) - call stdlib_wlarf( 'R', q-p, q-i+1, x11(i,i), ldx11, tauq1(i),x21(m-q+1,i), ldx21, & + call stdlib_${ci}$larf( 'R', q-p, q-i+1, x11(i,i), ldx11, tauq1(i),x21(m-q+1,i), ldx21, & work(ilarf) ) - call stdlib_wlacgv( q-i+1, x11(i,i), ldx11 ) + call stdlib_${ci}$lacgv( q-i+1, x11(i,i), ldx11 ) end do ! reduce the bottom-right portion of x21 to [ 0 i ] do i = p + 1, q - call stdlib_wlacgv( q-i+1, x21(m-q+i-p,i), ldx21 ) - call stdlib_wlarfgp( q-i+1, x21(m-q+i-p,i), x21(m-q+i-p,i+1), ldx21,tauq1(i) ) + call stdlib_${ci}$lacgv( q-i+1, x21(m-q+i-p,i), ldx21 ) + call stdlib_${ci}$larfgp( q-i+1, x21(m-q+i-p,i), x21(m-q+i-p,i+1), ldx21,tauq1(i) ) x21(m-q+i-p,i) = cone - call stdlib_wlarf( 'R', q-i, q-i+1, x21(m-q+i-p,i), ldx21, tauq1(i),x21(m-q+i-p+1,i)& + call stdlib_${ci}$larf( 'R', q-i, q-i+1, x21(m-q+i-p,i), ldx21, tauq1(i),x21(m-q+i-p+1,i)& , ldx21, work(ilarf) ) - call stdlib_wlacgv( q-i+1, x21(m-q+i-p,i), ldx21 ) + call stdlib_${ci}$lacgv( q-i+1, x21(m-q+i-p,i), ldx21 ) end do return - end subroutine stdlib_wunbdb4 + end subroutine stdlib_${ci}$unbdb4 - pure subroutine stdlib_wunbdb5( m1, m2, n, x1, incx1, x2, incx2, q1, ldq1, q2,ldq2, work, & + pure subroutine stdlib_${ci}$unbdb5( m1, m2, n, x1, incx1, x2, incx2, q1, ldq1, q2,ldq2, work, & !! ZUNBDB5: orthogonalizes the column vector !! X = [ X1 ] !! [ X2 ] @@ -76783,9 +76785,9 @@ module stdlib_linalg_lapack_w integer(ilp), intent(in) :: incx1, incx2, ldq1, ldq2, lwork, m1, m2, n integer(ilp), intent(out) :: info ! Array Arguments - complex(qp), intent(in) :: q1(ldq1,*), q2(ldq2,*) - complex(qp), intent(out) :: work(*) - complex(qp), intent(inout) :: x1(*), x2(*) + complex(${ck}$), intent(in) :: q1(ldq1,*), q2(ldq2,*) + complex(${ck}$), intent(out) :: work(*) + complex(${ck}$), intent(inout) :: x1(*), x2(*) ! ===================================================================== ! Local Scalars @@ -76817,10 +76819,10 @@ module stdlib_linalg_lapack_w return end if ! project x onto the orthogonal complement of q - call stdlib_wunbdb6( m1, m2, n, x1, incx1, x2, incx2, q1, ldq1, q2, ldq2,work, lwork, & + call stdlib_${ci}$unbdb6( m1, m2, n, x1, incx1, x2, incx2, q1, ldq1, q2, ldq2,work, lwork, & childinfo ) ! if the projection is nonzero, then return - if( stdlib_qznrm2(m1,x1,incx1) /= czero.or. stdlib_qznrm2(m2,x2,incx2) /= czero ) & + if( stdlib_${c2ri(ci)}$znrm2(m1,x1,incx1) /= czero.or. stdlib_${c2ri(ci)}$znrm2(m2,x2,incx2) /= czero ) & then return end if @@ -76834,9 +76836,9 @@ module stdlib_linalg_lapack_w do j = 1, m2 x2(j) = czero end do - call stdlib_wunbdb6( m1, m2, n, x1, incx1, x2, incx2, q1, ldq1, q2,ldq2, work, & + call stdlib_${ci}$unbdb6( m1, m2, n, x1, incx1, x2, incx2, q1, ldq1, q2,ldq2, work, & lwork, childinfo ) - if( stdlib_qznrm2(m1,x1,incx1) /= czero.or. stdlib_qznrm2(m2,x2,incx2) /= czero ) & + if( stdlib_${c2ri(ci)}$znrm2(m1,x1,incx1) /= czero.or. stdlib_${c2ri(ci)}$znrm2(m2,x2,incx2) /= czero ) & then return end if @@ -76851,18 +76853,18 @@ module stdlib_linalg_lapack_w x2(j) = czero end do x2(i) = cone - call stdlib_wunbdb6( m1, m2, n, x1, incx1, x2, incx2, q1, ldq1, q2,ldq2, work, & + call stdlib_${ci}$unbdb6( m1, m2, n, x1, incx1, x2, incx2, q1, ldq1, q2,ldq2, work, & lwork, childinfo ) - if( stdlib_qznrm2(m1,x1,incx1) /= czero.or. stdlib_qznrm2(m2,x2,incx2) /= czero ) & + if( stdlib_${c2ri(ci)}$znrm2(m1,x1,incx1) /= czero.or. stdlib_${c2ri(ci)}$znrm2(m2,x2,incx2) /= czero ) & then return end if end do return - end subroutine stdlib_wunbdb5 + end subroutine stdlib_${ci}$unbdb5 - pure subroutine stdlib_wunbdb6( m1, m2, n, x1, incx1, x2, incx2, q1, ldq1, q2,ldq2, work, & + pure subroutine stdlib_${ci}$unbdb6( m1, m2, n, x1, incx1, x2, incx2, q1, ldq1, q2,ldq2, work, & !! ZUNBDB6: orthogonalizes the column vector !! X = [ X1 ] !! [ X2 ] @@ -76880,19 +76882,19 @@ module stdlib_linalg_lapack_w integer(ilp), intent(in) :: incx1, incx2, ldq1, ldq2, lwork, m1, m2, n integer(ilp), intent(out) :: info ! Array Arguments - complex(qp), intent(in) :: q1(ldq1,*), q2(ldq2,*) - complex(qp), intent(out) :: work(*) - complex(qp), intent(inout) :: x1(*), x2(*) + complex(${ck}$), intent(in) :: q1(ldq1,*), q2(ldq2,*) + complex(${ck}$), intent(out) :: work(*) + complex(${ck}$), intent(inout) :: x1(*), x2(*) ! ===================================================================== ! Parameters - real(qp), parameter :: alphasq = 0.01_qp - real(qp), parameter :: realone = 1.0_qp - real(qp), parameter :: realzero = 0.0_qp + real(${ck}$), parameter :: alphasq = 0.01_${ck}$ + real(${ck}$), parameter :: realone = 1.0_${ck}$ + real(${ck}$), parameter :: realzero = 0.0_${ck}$ ! Local Scalars integer(ilp) :: i - real(qp) :: normsq1, normsq2, scl1, scl2, ssq1, ssq2 + real(${ck}$) :: normsq1, normsq2, scl1, scl2, ssq1, ssq2 ! Intrinsic Function intrinsic :: max ! Executable Statements @@ -76923,27 +76925,27 @@ module stdlib_linalg_lapack_w ! space scl1 = realzero ssq1 = realone - call stdlib_wlassq( m1, x1, incx1, scl1, ssq1 ) + call stdlib_${ci}$lassq( m1, x1, incx1, scl1, ssq1 ) scl2 = realzero ssq2 = realone - call stdlib_wlassq( m2, x2, incx2, scl2, ssq2 ) + call stdlib_${ci}$lassq( m2, x2, incx2, scl2, ssq2 ) normsq1 = scl1**2*ssq1 + scl2**2*ssq2 if( m1 == 0 ) then do i = 1, n work(i) = czero end do else - call stdlib_wgemv( 'C', m1, n, cone, q1, ldq1, x1, incx1, czero, work,1 ) + call stdlib_${ci}$gemv( 'C', m1, n, cone, q1, ldq1, x1, incx1, czero, work,1 ) end if - call stdlib_wgemv( 'C', m2, n, cone, q2, ldq2, x2, incx2, cone, work, 1 ) - call stdlib_wgemv( 'N', m1, n, cnegone, q1, ldq1, work, 1, cone, x1,incx1 ) - call stdlib_wgemv( 'N', m2, n, cnegone, q2, ldq2, work, 1, cone, x2,incx2 ) + call stdlib_${ci}$gemv( 'C', m2, n, cone, q2, ldq2, x2, incx2, cone, work, 1 ) + call stdlib_${ci}$gemv( 'N', m1, n, cnegone, q1, ldq1, work, 1, cone, x1,incx1 ) + call stdlib_${ci}$gemv( 'N', m2, n, cnegone, q2, ldq2, work, 1, cone, x2,incx2 ) scl1 = realzero ssq1 = realone - call stdlib_wlassq( m1, x1, incx1, scl1, ssq1 ) + call stdlib_${ci}$lassq( m1, x1, incx1, scl1, ssq1 ) scl2 = realzero ssq2 = realone - call stdlib_wlassq( m2, x2, incx2, scl2, ssq2 ) + call stdlib_${ci}$lassq( m2, x2, incx2, scl2, ssq2 ) normsq2 = scl1**2*ssq1 + scl2**2*ssq2 ! if projection is sufficiently large in norm, then stop. ! if projection is czero, then stop. @@ -76963,17 +76965,17 @@ module stdlib_linalg_lapack_w work(i) = czero end do else - call stdlib_wgemv( 'C', m1, n, cone, q1, ldq1, x1, incx1, czero, work,1 ) + call stdlib_${ci}$gemv( 'C', m1, n, cone, q1, ldq1, x1, incx1, czero, work,1 ) end if - call stdlib_wgemv( 'C', m2, n, cone, q2, ldq2, x2, incx2, cone, work, 1 ) - call stdlib_wgemv( 'N', m1, n, cnegone, q1, ldq1, work, 1, cone, x1,incx1 ) - call stdlib_wgemv( 'N', m2, n, cnegone, q2, ldq2, work, 1, cone, x2,incx2 ) + call stdlib_${ci}$gemv( 'C', m2, n, cone, q2, ldq2, x2, incx2, cone, work, 1 ) + call stdlib_${ci}$gemv( 'N', m1, n, cnegone, q1, ldq1, work, 1, cone, x1,incx1 ) + call stdlib_${ci}$gemv( 'N', m2, n, cnegone, q2, ldq2, work, 1, cone, x2,incx2 ) scl1 = realzero ssq1 = realone - call stdlib_wlassq( m1, x1, incx1, scl1, ssq1 ) + call stdlib_${ci}$lassq( m1, x1, incx1, scl1, ssq1 ) scl2 = realzero ssq2 = realone - call stdlib_wlassq( m1, x1, incx1, scl1, ssq1 ) + call stdlib_${ci}$lassq( m1, x1, incx1, scl1, ssq1 ) normsq2 = scl1**2*ssq1 + scl2**2*ssq2 ! if second projection is sufficiently large in norm, then do ! nothing more. alternatively, if it shrunk significantly, then @@ -76987,10 +76989,10 @@ module stdlib_linalg_lapack_w end do end if return - end subroutine stdlib_wunbdb6 + end subroutine stdlib_${ci}$unbdb6 - recursive subroutine stdlib_wuncsd( jobu1, jobu2, jobv1t, jobv2t, trans,signs, m, p, q, x11, & + recursive subroutine stdlib_${ci}$uncsd( jobu1, jobu2, jobv1t, jobv2t, trans,signs, m, p, q, x11, & !! ZUNCSD: computes the CS decomposition of an M-by-M partitioned !! unitary matrix X: !! [ I 0 0 | 0 0 0 ] @@ -77016,11 +77018,11 @@ module stdlib_linalg_lapack_w lrwork, lwork, m, p, q ! Array Arguments integer(ilp), intent(out) :: iwork(*) - real(qp), intent(out) :: theta(*) - real(qp), intent(out) :: rwork(*) - complex(qp), intent(out) :: u1(ldu1,*), u2(ldu2,*), v1t(ldv1t,*), v2t(ldv2t,*), work(*) + real(${ck}$), intent(out) :: theta(*) + real(${ck}$), intent(out) :: rwork(*) + complex(${ck}$), intent(out) :: u1(ldu1,*), u2(ldu2,*), v1t(ldv1t,*), v2t(ldv2t,*), work(*) - complex(qp), intent(inout) :: x11(ldx11,*), x12(ldx12,*), x21(ldx21,*), x22(ldx22,*) + complex(${ck}$), intent(inout) :: x11(ldx11,*), x12(ldx12,*), x21(ldx21,*), x22(ldx22,*) ! =================================================================== @@ -77090,7 +77092,7 @@ module stdlib_linalg_lapack_w else signst = 'D' end if - call stdlib_wuncsd( jobv1t, jobv2t, jobu1, jobu2, transt, signst, m,q, p, x11, & + call stdlib_${ci}$uncsd( jobv1t, jobv2t, jobu1, jobu2, transt, signst, m,q, p, x11, & ldx11, x21, ldx21, x12, ldx12, x22,ldx22, theta, v1t, ldv1t, v2t, ldv2t, u1, ldu1,& u2, ldu2, work, lwork, rwork, lrwork, iwork,info ) return @@ -77103,7 +77105,7 @@ module stdlib_linalg_lapack_w else signst = 'D' end if - call stdlib_wuncsd( jobu2, jobu1, jobv2t, jobv1t, trans, signst, m,m-p, m-q, x22, & + call stdlib_${ci}$uncsd( jobu2, jobu1, jobv2t, jobv1t, trans, signst, m,m-p, m-q, x22, & ldx22, x21, ldx21, x12, ldx12, x11,ldx11, theta, u2, ldu2, u1, ldu1, v2t, ldv2t, & v1t,ldv1t, work, lwork, rwork, lrwork, iwork, info ) return @@ -77121,7 +77123,7 @@ module stdlib_linalg_lapack_w ib22d = ib21e + max( 1, q - 1 ) ib22e = ib22d + max( 1, q ) ibbcsd = ib22e + max( 1, q - 1 ) - call stdlib_wbbcsd( jobu1, jobu2, jobv1t, jobv2t, trans, m, p, q,theta, theta, u1, & + call stdlib_${ci}$bbcsd( jobu1, jobu2, jobv1t, jobv2t, trans, m, p, q,theta, theta, u1, & ldu1, u2, ldu2, v1t, ldv1t,v2t, ldv2t, theta, theta, theta, theta, theta,theta, & theta, theta, rwork, -1, childinfo ) lbbcsdworkopt = int( rwork(1),KIND=ilp) @@ -77135,15 +77137,15 @@ module stdlib_linalg_lapack_w itauq1 = itaup2 + max( 1, m - p ) itauq2 = itauq1 + max( 1, q ) iorgqr = itauq2 + max( 1, m - q ) - call stdlib_wungqr( m-q, m-q, m-q, u1, max(1,m-q), u1, work, -1,childinfo ) + call stdlib_${ci}$ungqr( m-q, m-q, m-q, u1, max(1,m-q), u1, work, -1,childinfo ) lorgqrworkopt = int( work(1),KIND=ilp) lorgqrworkmin = max( 1, m - q ) iorglq = itauq2 + max( 1, m - q ) - call stdlib_wunglq( m-q, m-q, m-q, u1, max(1,m-q), u1, work, -1,childinfo ) + call stdlib_${ci}$unglq( m-q, m-q, m-q, u1, max(1,m-q), u1, work, -1,childinfo ) lorglqworkopt = int( work(1),KIND=ilp) lorglqworkmin = max( 1, m - q ) iorbdb = itauq2 + max( 1, m - q ) - call stdlib_wunbdb( trans, signs, m, p, q, x11, ldx11, x12, ldx12,x21, ldx21, x22, & + call stdlib_${ci}$unbdb( trans, signs, m, p, q, x11, ldx11, x12, ldx12,x21, ldx21, x22, & ldx22, theta, theta, u1, u2,v1t, v2t, work, -1, childinfo ) lorbdbworkopt = int( work(1),KIND=ilp) lorbdbworkmin = lorbdbworkopt @@ -77171,77 +77173,77 @@ module stdlib_linalg_lapack_w return end if ! transform to bidiagonal block form - call stdlib_wunbdb( trans, signs, m, p, q, x11, ldx11, x12, ldx12, x21,ldx21, x22, & + call stdlib_${ci}$unbdb( trans, signs, m, p, q, x11, ldx11, x12, ldx12, x21,ldx21, x22, & ldx22, theta, rwork(iphi), work(itaup1),work(itaup2), work(itauq1), work(itauq2),work(& iorbdb), lorbdbwork, childinfo ) ! accumulate householder reflectors if( colmajor ) then if( wantu1 .and. p > 0 ) then - call stdlib_wlacpy( 'L', p, q, x11, ldx11, u1, ldu1 ) - call stdlib_wungqr( p, p, q, u1, ldu1, work(itaup1), work(iorgqr),lorgqrwork, & + call stdlib_${ci}$lacpy( 'L', p, q, x11, ldx11, u1, ldu1 ) + call stdlib_${ci}$ungqr( p, p, q, u1, ldu1, work(itaup1), work(iorgqr),lorgqrwork, & info) end if if( wantu2 .and. m-p > 0 ) then - call stdlib_wlacpy( 'L', m-p, q, x21, ldx21, u2, ldu2 ) - call stdlib_wungqr( m-p, m-p, q, u2, ldu2, work(itaup2),work(iorgqr), lorgqrwork,& + call stdlib_${ci}$lacpy( 'L', m-p, q, x21, ldx21, u2, ldu2 ) + call stdlib_${ci}$ungqr( m-p, m-p, q, u2, ldu2, work(itaup2),work(iorgqr), lorgqrwork,& info ) end if if( wantv1t .and. q > 0 ) then - call stdlib_wlacpy( 'U', q-1, q-1, x11(1,2), ldx11, v1t(2,2),ldv1t ) + call stdlib_${ci}$lacpy( 'U', q-1, q-1, x11(1,2), ldx11, v1t(2,2),ldv1t ) v1t(1, 1) = cone do j = 2, q v1t(1,j) = czero v1t(j,1) = czero end do - call stdlib_wunglq( q-1, q-1, q-1, v1t(2,2), ldv1t, work(itauq1),work(iorglq), & + call stdlib_${ci}$unglq( q-1, q-1, q-1, v1t(2,2), ldv1t, work(itauq1),work(iorglq), & lorglqwork, info ) end if if( wantv2t .and. m-q > 0 ) then - call stdlib_wlacpy( 'U', p, m-q, x12, ldx12, v2t, ldv2t ) + call stdlib_${ci}$lacpy( 'U', p, m-q, x12, ldx12, v2t, ldv2t ) if( m-p > q) then - call stdlib_wlacpy( 'U', m-p-q, m-p-q, x22(q+1,p+1), ldx22,v2t(p+1,p+1), & + call stdlib_${ci}$lacpy( 'U', m-p-q, m-p-q, x22(q+1,p+1), ldx22,v2t(p+1,p+1), & ldv2t ) end if if( m > q ) then - call stdlib_wunglq( m-q, m-q, m-q, v2t, ldv2t, work(itauq2),work(iorglq), & + call stdlib_${ci}$unglq( m-q, m-q, m-q, v2t, ldv2t, work(itauq2),work(iorglq), & lorglqwork, info ) end if end if else if( wantu1 .and. p > 0 ) then - call stdlib_wlacpy( 'U', q, p, x11, ldx11, u1, ldu1 ) - call stdlib_wunglq( p, p, q, u1, ldu1, work(itaup1), work(iorglq),lorglqwork, & + call stdlib_${ci}$lacpy( 'U', q, p, x11, ldx11, u1, ldu1 ) + call stdlib_${ci}$unglq( p, p, q, u1, ldu1, work(itaup1), work(iorglq),lorglqwork, & info) end if if( wantu2 .and. m-p > 0 ) then - call stdlib_wlacpy( 'U', q, m-p, x21, ldx21, u2, ldu2 ) - call stdlib_wunglq( m-p, m-p, q, u2, ldu2, work(itaup2),work(iorglq), lorglqwork,& + call stdlib_${ci}$lacpy( 'U', q, m-p, x21, ldx21, u2, ldu2 ) + call stdlib_${ci}$unglq( m-p, m-p, q, u2, ldu2, work(itaup2),work(iorglq), lorglqwork,& info ) end if if( wantv1t .and. q > 0 ) then - call stdlib_wlacpy( 'L', q-1, q-1, x11(2,1), ldx11, v1t(2,2),ldv1t ) + call stdlib_${ci}$lacpy( 'L', q-1, q-1, x11(2,1), ldx11, v1t(2,2),ldv1t ) v1t(1, 1) = cone do j = 2, q v1t(1,j) = czero v1t(j,1) = czero end do - call stdlib_wungqr( q-1, q-1, q-1, v1t(2,2), ldv1t, work(itauq1),work(iorgqr), & + call stdlib_${ci}$ungqr( q-1, q-1, q-1, v1t(2,2), ldv1t, work(itauq1),work(iorgqr), & lorgqrwork, info ) end if if( wantv2t .and. m-q > 0 ) then p1 = min( p+1, m ) q1 = min( q+1, m ) - call stdlib_wlacpy( 'L', m-q, p, x12, ldx12, v2t, ldv2t ) + call stdlib_${ci}$lacpy( 'L', m-q, p, x12, ldx12, v2t, ldv2t ) if( m > p+q ) then - call stdlib_wlacpy( 'L', m-p-q, m-p-q, x22(p1,q1), ldx22,v2t(p+1,p+1), ldv2t ) + call stdlib_${ci}$lacpy( 'L', m-p-q, m-p-q, x22(p1,q1), ldx22,v2t(p+1,p+1), ldv2t ) end if - call stdlib_wungqr( m-q, m-q, m-q, v2t, ldv2t, work(itauq2),work(iorgqr), & + call stdlib_${ci}$ungqr( m-q, m-q, m-q, v2t, ldv2t, work(itauq2),work(iorgqr), & lorgqrwork, info ) end if end if ! compute the csd of the matrix in bidiagonal-block form - call stdlib_wbbcsd( jobu1, jobu2, jobv1t, jobv2t, trans, m, p, q, theta,rwork(iphi), & + call stdlib_${ci}$bbcsd( jobu1, jobu2, jobv1t, jobv2t, trans, m, p, q, theta,rwork(iphi), & u1, ldu1, u2, ldu2, v1t, ldv1t, v2t,ldv2t, rwork(ib11d), rwork(ib11e), rwork(ib12d),& rwork(ib12e), rwork(ib21d), rwork(ib21e),rwork(ib22d), rwork(ib22e), rwork(ibbcsd),& lbbcsdwork, info ) @@ -77257,9 +77259,9 @@ module stdlib_linalg_lapack_w iwork(i) = i - q end do if( colmajor ) then - call stdlib_wlapmt( .false., m-p, m-p, u2, ldu2, iwork ) + call stdlib_${ci}$lapmt( .false., m-p, m-p, u2, ldu2, iwork ) else - call stdlib_wlapmr( .false., m-p, m-p, u2, ldu2, iwork ) + call stdlib_${ci}$lapmr( .false., m-p, m-p, u2, ldu2, iwork ) end if end if if( m > 0 .and. wantv2t ) then @@ -77270,17 +77272,17 @@ module stdlib_linalg_lapack_w iwork(i) = i - p end do if( .not. colmajor ) then - call stdlib_wlapmt( .false., m-q, m-q, v2t, ldv2t, iwork ) + call stdlib_${ci}$lapmt( .false., m-q, m-q, v2t, ldv2t, iwork ) else - call stdlib_wlapmr( .false., m-q, m-q, v2t, ldv2t, iwork ) + call stdlib_${ci}$lapmr( .false., m-q, m-q, v2t, ldv2t, iwork ) end if end if return - ! end stdlib_wuncsd - end subroutine stdlib_wuncsd + ! end stdlib_${ci}$uncsd + end subroutine stdlib_${ci}$uncsd - subroutine stdlib_wuncsd2by1( jobu1, jobu2, jobv1t, m, p, q, x11, ldx11,x21, ldx21, theta, & + subroutine stdlib_${ci}$uncsd2by1( jobu1, jobu2, jobv1t, m, p, q, x11, ldx11,x21, ldx21, theta, & !! ZUNCSD2BY1: computes the CS decomposition of an M-by-Q matrix X with !! orthonormal columns that has been partitioned into a 2-by-1 block !! structure: @@ -77307,10 +77309,10 @@ module stdlib_linalg_lapack_w integer(ilp), intent(in) :: lrwork integer(ilp) :: lrworkmin, lrworkopt ! Array Arguments - real(qp), intent(out) :: rwork(*) - real(qp), intent(out) :: theta(*) - complex(qp), intent(out) :: u1(ldu1,*), u2(ldu2,*), v1t(ldv1t,*), work(*) - complex(qp), intent(inout) :: x11(ldx11,*), x21(ldx21,*) + real(${ck}$), intent(out) :: rwork(*) + real(${ck}$), intent(out) :: theta(*) + complex(${ck}$), intent(out) :: u1(ldu1,*), u2(ldu2,*), v1t(ldv1t,*), work(*) + complex(${ck}$), intent(inout) :: x11(ldx11,*), x21(ldx21,*) integer(ilp), intent(out) :: iwork(*) ! ===================================================================== @@ -77321,8 +77323,8 @@ module stdlib_linalg_lapack_w r logical(lk) :: lquery, wantu1, wantu2, wantv1t ! Local Arrays - real(qp) :: dum(1) - complex(qp) :: cdum(1,1) + real(${ck}$) :: dum(1) + complex(${ck}$) :: cdum(1,1) ! Intrinsic Function intrinsic :: int,max,min ! Executable Statements @@ -77359,7 +77361,7 @@ module stdlib_linalg_lapack_w ! | taup2 (max(1,m-p)) | ! | tauq1 (max(1,q)) | ! |-----------------------------------------| - ! | stdlib_wunbdb work | stdlib_wungqr work | stdlib_wunglq work | + ! | stdlib_${ci}$unbdb work | stdlib_${ci}$ungqr work | stdlib_${ci}$unglq work | ! | | | | ! | | | | ! | | | | @@ -77379,7 +77381,7 @@ module stdlib_linalg_lapack_w ! | b21e (r-1) | ! | b22d (r) | ! | b22e (r-1) | - ! | stdlib_wbbcsd rwork | + ! | stdlib_${ci}$bbcsd rwork | ! |------------------| if( info == 0 ) then iphi = 2 @@ -77403,100 +77405,100 @@ module stdlib_linalg_lapack_w lorglqmin = 1 lorglqopt = 1 if( r == q ) then - call stdlib_wunbdb1( m, p, q, x11, ldx11, x21, ldx21, theta, dum,cdum, cdum, & + call stdlib_${ci}$unbdb1( m, p, q, x11, ldx11, x21, ldx21, theta, dum,cdum, cdum, & cdum, work, -1, childinfo ) lorbdb = int( work(1),KIND=ilp) if( wantu1 .and. p > 0 ) then - call stdlib_wungqr( p, p, q, u1, ldu1, cdum, work(1), -1,childinfo ) + call stdlib_${ci}$ungqr( p, p, q, u1, ldu1, cdum, work(1), -1,childinfo ) lorgqrmin = max( lorgqrmin, p ) lorgqropt = max( lorgqropt, int( work(1),KIND=ilp) ) endif if( wantu2 .and. m-p > 0 ) then - call stdlib_wungqr( m-p, m-p, q, u2, ldu2, cdum, work(1), -1,childinfo ) + call stdlib_${ci}$ungqr( m-p, m-p, q, u2, ldu2, cdum, work(1), -1,childinfo ) lorgqrmin = max( lorgqrmin, m-p ) lorgqropt = max( lorgqropt, int( work(1),KIND=ilp) ) end if if( wantv1t .and. q > 0 ) then - call stdlib_wunglq( q-1, q-1, q-1, v1t, ldv1t,cdum, work(1), -1, childinfo ) + call stdlib_${ci}$unglq( q-1, q-1, q-1, v1t, ldv1t,cdum, work(1), -1, childinfo ) lorglqmin = max( lorglqmin, q-1 ) lorglqopt = max( lorglqopt, int( work(1),KIND=ilp) ) end if - call stdlib_wbbcsd( jobu1, jobu2, jobv1t, 'N', 'N', m, p, q, theta,dum, u1, ldu1,& + call stdlib_${ci}$bbcsd( jobu1, jobu2, jobv1t, 'N', 'N', m, p, q, theta,dum, u1, ldu1,& u2, ldu2, v1t, ldv1t, cdum, 1,dum, dum, dum, dum, dum, dum, dum, dum,rwork(1), -& 1, childinfo ) lbbcsd = int( rwork(1),KIND=ilp) else if( r == p ) then - call stdlib_wunbdb2( m, p, q, x11, ldx11, x21, ldx21, theta, dum,cdum, cdum, & + call stdlib_${ci}$unbdb2( m, p, q, x11, ldx11, x21, ldx21, theta, dum,cdum, cdum, & cdum, work(1), -1, childinfo ) lorbdb = int( work(1),KIND=ilp) if( wantu1 .and. p > 0 ) then - call stdlib_wungqr( p-1, p-1, p-1, u1(2,2), ldu1, cdum, work(1),-1, childinfo & + call stdlib_${ci}$ungqr( p-1, p-1, p-1, u1(2,2), ldu1, cdum, work(1),-1, childinfo & ) lorgqrmin = max( lorgqrmin, p-1 ) lorgqropt = max( lorgqropt, int( work(1),KIND=ilp) ) end if if( wantu2 .and. m-p > 0 ) then - call stdlib_wungqr( m-p, m-p, q, u2, ldu2, cdum, work(1), -1,childinfo ) + call stdlib_${ci}$ungqr( m-p, m-p, q, u2, ldu2, cdum, work(1), -1,childinfo ) lorgqrmin = max( lorgqrmin, m-p ) lorgqropt = max( lorgqropt, int( work(1),KIND=ilp) ) end if if( wantv1t .and. q > 0 ) then - call stdlib_wunglq( q, q, r, v1t, ldv1t, cdum, work(1), -1,childinfo ) + call stdlib_${ci}$unglq( q, q, r, v1t, ldv1t, cdum, work(1), -1,childinfo ) lorglqmin = max( lorglqmin, q ) lorglqopt = max( lorglqopt, int( work(1),KIND=ilp) ) end if - call stdlib_wbbcsd( jobv1t, 'N', jobu1, jobu2, 'T', m, q, p, theta,dum, v1t, & + call stdlib_${ci}$bbcsd( jobv1t, 'N', jobu1, jobu2, 'T', m, q, p, theta,dum, v1t, & ldv1t, cdum, 1, u1, ldu1, u2, ldu2,dum, dum, dum, dum, dum, dum, dum, dum,rwork(& 1), -1, childinfo ) lbbcsd = int( rwork(1),KIND=ilp) else if( r == m-p ) then - call stdlib_wunbdb3( m, p, q, x11, ldx11, x21, ldx21, theta, dum,cdum, cdum, & + call stdlib_${ci}$unbdb3( m, p, q, x11, ldx11, x21, ldx21, theta, dum,cdum, cdum, & cdum, work(1), -1, childinfo ) lorbdb = int( work(1),KIND=ilp) if( wantu1 .and. p > 0 ) then - call stdlib_wungqr( p, p, q, u1, ldu1, cdum, work(1), -1,childinfo ) + call stdlib_${ci}$ungqr( p, p, q, u1, ldu1, cdum, work(1), -1,childinfo ) lorgqrmin = max( lorgqrmin, p ) lorgqropt = max( lorgqropt, int( work(1),KIND=ilp) ) end if if( wantu2 .and. m-p > 0 ) then - call stdlib_wungqr( m-p-1, m-p-1, m-p-1, u2(2,2), ldu2, cdum,work(1), -1, & + call stdlib_${ci}$ungqr( m-p-1, m-p-1, m-p-1, u2(2,2), ldu2, cdum,work(1), -1, & childinfo ) lorgqrmin = max( lorgqrmin, m-p-1 ) lorgqropt = max( lorgqropt, int( work(1),KIND=ilp) ) end if if( wantv1t .and. q > 0 ) then - call stdlib_wunglq( q, q, r, v1t, ldv1t, cdum, work(1), -1,childinfo ) + call stdlib_${ci}$unglq( q, q, r, v1t, ldv1t, cdum, work(1), -1,childinfo ) lorglqmin = max( lorglqmin, q ) lorglqopt = max( lorglqopt, int( work(1),KIND=ilp) ) end if - call stdlib_wbbcsd( 'N', jobv1t, jobu2, jobu1, 'T', m, m-q, m-p,theta, dum, cdum,& + call stdlib_${ci}$bbcsd( 'N', jobv1t, jobu2, jobu1, 'T', m, m-q, m-p,theta, dum, cdum,& 1, v1t, ldv1t, u2, ldu2, u1,ldu1, dum, dum, dum, dum, dum, dum, dum, dum,rwork(& 1), -1, childinfo ) lbbcsd = int( rwork(1),KIND=ilp) else - call stdlib_wunbdb4( m, p, q, x11, ldx11, x21, ldx21, theta, dum,cdum, cdum, & + call stdlib_${ci}$unbdb4( m, p, q, x11, ldx11, x21, ldx21, theta, dum,cdum, cdum, & cdum, cdum, work(1), -1, childinfo) lorbdb = m + int( work(1),KIND=ilp) if( wantu1 .and. p > 0 ) then - call stdlib_wungqr( p, p, m-q, u1, ldu1, cdum, work(1), -1,childinfo ) + call stdlib_${ci}$ungqr( p, p, m-q, u1, ldu1, cdum, work(1), -1,childinfo ) lorgqrmin = max( lorgqrmin, p ) lorgqropt = max( lorgqropt, int( work(1),KIND=ilp) ) end if if( wantu2 .and. m-p > 0 ) then - call stdlib_wungqr( m-p, m-p, m-q, u2, ldu2, cdum, work(1), -1,childinfo ) + call stdlib_${ci}$ungqr( m-p, m-p, m-q, u2, ldu2, cdum, work(1), -1,childinfo ) lorgqrmin = max( lorgqrmin, m-p ) lorgqropt = max( lorgqropt, int( work(1),KIND=ilp) ) end if if( wantv1t .and. q > 0 ) then - call stdlib_wunglq( q, q, q, v1t, ldv1t, cdum, work(1), -1,childinfo ) + call stdlib_${ci}$unglq( q, q, q, v1t, ldv1t, cdum, work(1), -1,childinfo ) lorglqmin = max( lorglqmin, q ) lorglqopt = max( lorglqopt, int( work(1),KIND=ilp) ) end if - call stdlib_wbbcsd( jobu2, jobu1, 'N', jobv1t, 'N', m, m-p, m-q,theta, dum, u2, & + call stdlib_${ci}$bbcsd( jobu2, jobu1, 'N', jobv1t, 'N', m, m-p, m-q,theta, dum, u2, & ldu2, u1, ldu1, cdum, 1, v1t,ldv1t, dum, dum, dum, dum, dum, dum, dum, dum,rwork(& 1), -1, childinfo ) lbbcsd = int( rwork(1),KIND=ilp) @@ -77527,17 +77529,17 @@ module stdlib_linalg_lapack_w if( r == q ) then ! case 1: r = q ! simultaneously bidiagonalize x11 and x21 - call stdlib_wunbdb1( m, p, q, x11, ldx11, x21, ldx21, theta,rwork(iphi), work(& + call stdlib_${ci}$unbdb1( m, p, q, x11, ldx11, x21, ldx21, theta,rwork(iphi), work(& itaup1), work(itaup2),work(itauq1), work(iorbdb), lorbdb, childinfo ) ! accumulate householder reflectors if( wantu1 .and. p > 0 ) then - call stdlib_wlacpy( 'L', p, q, x11, ldx11, u1, ldu1 ) - call stdlib_wungqr( p, p, q, u1, ldu1, work(itaup1), work(iorgqr),lorgqr, & + call stdlib_${ci}$lacpy( 'L', p, q, x11, ldx11, u1, ldu1 ) + call stdlib_${ci}$ungqr( p, p, q, u1, ldu1, work(itaup1), work(iorgqr),lorgqr, & childinfo ) end if if( wantu2 .and. m-p > 0 ) then - call stdlib_wlacpy( 'L', m-p, q, x21, ldx21, u2, ldu2 ) - call stdlib_wungqr( m-p, m-p, q, u2, ldu2, work(itaup2),work(iorgqr), lorgqr, & + call stdlib_${ci}$lacpy( 'L', m-p, q, x21, ldx21, u2, ldu2 ) + call stdlib_${ci}$ungqr( m-p, m-p, q, u2, ldu2, work(itaup2),work(iorgqr), lorgqr, & childinfo ) end if if( wantv1t .and. q > 0 ) then @@ -77546,12 +77548,12 @@ module stdlib_linalg_lapack_w v1t(1,j) = czero v1t(j,1) = czero end do - call stdlib_wlacpy( 'U', q-1, q-1, x21(1,2), ldx21, v1t(2,2),ldv1t ) - call stdlib_wunglq( q-1, q-1, q-1, v1t(2,2), ldv1t, work(itauq1),work(iorglq), & + call stdlib_${ci}$lacpy( 'U', q-1, q-1, x21(1,2), ldx21, v1t(2,2),ldv1t ) + call stdlib_${ci}$unglq( q-1, q-1, q-1, v1t(2,2), ldv1t, work(itauq1),work(iorglq), & lorglq, childinfo ) end if ! simultaneously diagonalize x11 and x21. - call stdlib_wbbcsd( jobu1, jobu2, jobv1t, 'N', 'N', m, p, q, theta,rwork(iphi), u1, & + call stdlib_${ci}$bbcsd( jobu1, jobu2, jobv1t, 'N', 'N', m, p, q, theta,rwork(iphi), u1, & ldu1, u2, ldu2, v1t, ldv1t, cdum,1, rwork(ib11d), rwork(ib11e), rwork(ib12d),rwork(& ib12e), rwork(ib21d), rwork(ib21e),rwork(ib22d), rwork(ib22e), rwork(ibbcsd),lrwork-& ibbcsd+1, childinfo ) @@ -77564,12 +77566,12 @@ module stdlib_linalg_lapack_w do i = q + 1, m - p iwork(i) = i - q end do - call stdlib_wlapmt( .false., m-p, m-p, u2, ldu2, iwork ) + call stdlib_${ci}$lapmt( .false., m-p, m-p, u2, ldu2, iwork ) end if else if( r == p ) then ! case 2: r = p ! simultaneously bidiagonalize x11 and x21 - call stdlib_wunbdb2( m, p, q, x11, ldx11, x21, ldx21, theta,rwork(iphi), work(& + call stdlib_${ci}$unbdb2( m, p, q, x11, ldx11, x21, ldx21, theta,rwork(iphi), work(& itaup1), work(itaup2),work(itauq1), work(iorbdb), lorbdb, childinfo ) ! accumulate householder reflectors if( wantu1 .and. p > 0 ) then @@ -77578,22 +77580,22 @@ module stdlib_linalg_lapack_w u1(1,j) = czero u1(j,1) = czero end do - call stdlib_wlacpy( 'L', p-1, p-1, x11(2,1), ldx11, u1(2,2), ldu1 ) - call stdlib_wungqr( p-1, p-1, p-1, u1(2,2), ldu1, work(itaup1),work(iorgqr), & + call stdlib_${ci}$lacpy( 'L', p-1, p-1, x11(2,1), ldx11, u1(2,2), ldu1 ) + call stdlib_${ci}$ungqr( p-1, p-1, p-1, u1(2,2), ldu1, work(itaup1),work(iorgqr), & lorgqr, childinfo ) end if if( wantu2 .and. m-p > 0 ) then - call stdlib_wlacpy( 'L', m-p, q, x21, ldx21, u2, ldu2 ) - call stdlib_wungqr( m-p, m-p, q, u2, ldu2, work(itaup2),work(iorgqr), lorgqr, & + call stdlib_${ci}$lacpy( 'L', m-p, q, x21, ldx21, u2, ldu2 ) + call stdlib_${ci}$ungqr( m-p, m-p, q, u2, ldu2, work(itaup2),work(iorgqr), lorgqr, & childinfo ) end if if( wantv1t .and. q > 0 ) then - call stdlib_wlacpy( 'U', p, q, x11, ldx11, v1t, ldv1t ) - call stdlib_wunglq( q, q, r, v1t, ldv1t, work(itauq1),work(iorglq), lorglq, & + call stdlib_${ci}$lacpy( 'U', p, q, x11, ldx11, v1t, ldv1t ) + call stdlib_${ci}$unglq( q, q, r, v1t, ldv1t, work(itauq1),work(iorglq), lorglq, & childinfo ) end if ! simultaneously diagonalize x11 and x21. - call stdlib_wbbcsd( jobv1t, 'N', jobu1, jobu2, 'T', m, q, p, theta,rwork(iphi), v1t,& + call stdlib_${ci}$bbcsd( jobv1t, 'N', jobu1, jobu2, 'T', m, q, p, theta,rwork(iphi), v1t,& ldv1t, cdum, 1, u1, ldu1, u2,ldu2, rwork(ib11d), rwork(ib11e), rwork(ib12d),rwork(& ib12e), rwork(ib21d), rwork(ib21e),rwork(ib22d), rwork(ib22e), rwork(ibbcsd), & lbbcsd,childinfo ) @@ -77606,17 +77608,17 @@ module stdlib_linalg_lapack_w do i = q + 1, m - p iwork(i) = i - q end do - call stdlib_wlapmt( .false., m-p, m-p, u2, ldu2, iwork ) + call stdlib_${ci}$lapmt( .false., m-p, m-p, u2, ldu2, iwork ) end if else if( r == m-p ) then ! case 3: r = m-p ! simultaneously bidiagonalize x11 and x21 - call stdlib_wunbdb3( m, p, q, x11, ldx11, x21, ldx21, theta,rwork(iphi), work(& + call stdlib_${ci}$unbdb3( m, p, q, x11, ldx11, x21, ldx21, theta,rwork(iphi), work(& itaup1), work(itaup2),work(itauq1), work(iorbdb), lorbdb, childinfo ) ! accumulate householder reflectors if( wantu1 .and. p > 0 ) then - call stdlib_wlacpy( 'L', p, q, x11, ldx11, u1, ldu1 ) - call stdlib_wungqr( p, p, q, u1, ldu1, work(itaup1), work(iorgqr),lorgqr, & + call stdlib_${ci}$lacpy( 'L', p, q, x11, ldx11, u1, ldu1 ) + call stdlib_${ci}$ungqr( p, p, q, u1, ldu1, work(itaup1), work(iorgqr),lorgqr, & childinfo ) end if if( wantu2 .and. m-p > 0 ) then @@ -77625,17 +77627,17 @@ module stdlib_linalg_lapack_w u2(1,j) = czero u2(j,1) = czero end do - call stdlib_wlacpy( 'L', m-p-1, m-p-1, x21(2,1), ldx21, u2(2,2),ldu2 ) - call stdlib_wungqr( m-p-1, m-p-1, m-p-1, u2(2,2), ldu2,work(itaup2), work(iorgqr)& + call stdlib_${ci}$lacpy( 'L', m-p-1, m-p-1, x21(2,1), ldx21, u2(2,2),ldu2 ) + call stdlib_${ci}$ungqr( m-p-1, m-p-1, m-p-1, u2(2,2), ldu2,work(itaup2), work(iorgqr)& , lorgqr, childinfo ) end if if( wantv1t .and. q > 0 ) then - call stdlib_wlacpy( 'U', m-p, q, x21, ldx21, v1t, ldv1t ) - call stdlib_wunglq( q, q, r, v1t, ldv1t, work(itauq1),work(iorglq), lorglq, & + call stdlib_${ci}$lacpy( 'U', m-p, q, x21, ldx21, v1t, ldv1t ) + call stdlib_${ci}$unglq( q, q, r, v1t, ldv1t, work(itauq1),work(iorglq), lorglq, & childinfo ) end if ! simultaneously diagonalize x11 and x21. - call stdlib_wbbcsd( 'N', jobv1t, jobu2, jobu1, 'T', m, m-q, m-p,theta, rwork(iphi), & + call stdlib_${ci}$bbcsd( 'N', jobv1t, jobu2, jobu1, 'T', m, m-q, m-p,theta, rwork(iphi), & cdum, 1, v1t, ldv1t, u2, ldu2,u1, ldu1, rwork(ib11d), rwork(ib11e),rwork(ib12d), & rwork(ib12e), rwork(ib21d),rwork(ib21e), rwork(ib22d), rwork(ib22e),rwork(ibbcsd), & lbbcsd, childinfo ) @@ -77649,50 +77651,50 @@ module stdlib_linalg_lapack_w iwork(i) = i - r end do if( wantu1 ) then - call stdlib_wlapmt( .false., p, q, u1, ldu1, iwork ) + call stdlib_${ci}$lapmt( .false., p, q, u1, ldu1, iwork ) end if if( wantv1t ) then - call stdlib_wlapmr( .false., q, q, v1t, ldv1t, iwork ) + call stdlib_${ci}$lapmr( .false., q, q, v1t, ldv1t, iwork ) end if end if else ! case 4: r = m-q ! simultaneously bidiagonalize x11 and x21 - call stdlib_wunbdb4( m, p, q, x11, ldx11, x21, ldx21, theta,rwork(iphi), work(& + call stdlib_${ci}$unbdb4( m, p, q, x11, ldx11, x21, ldx21, theta,rwork(iphi), work(& itaup1), work(itaup2),work(itauq1), work(iorbdb), work(iorbdb+m),lorbdb-m, & childinfo ) ! accumulate householder reflectors if( wantu2 .and. m-p > 0 ) then - call stdlib_wcopy( m-p, work(iorbdb+p), 1, u2, 1 ) + call stdlib_${ci}$copy( m-p, work(iorbdb+p), 1, u2, 1 ) end if if( wantu1 .and. p > 0 ) then - call stdlib_wcopy( p, work(iorbdb), 1, u1, 1 ) + call stdlib_${ci}$copy( p, work(iorbdb), 1, u1, 1 ) do j = 2, p u1(1,j) = czero end do - call stdlib_wlacpy( 'L', p-1, m-q-1, x11(2,1), ldx11, u1(2,2),ldu1 ) - call stdlib_wungqr( p, p, m-q, u1, ldu1, work(itaup1),work(iorgqr), lorgqr, & + call stdlib_${ci}$lacpy( 'L', p-1, m-q-1, x11(2,1), ldx11, u1(2,2),ldu1 ) + call stdlib_${ci}$ungqr( p, p, m-q, u1, ldu1, work(itaup1),work(iorgqr), lorgqr, & childinfo ) end if if( wantu2 .and. m-p > 0 ) then do j = 2, m-p u2(1,j) = czero end do - call stdlib_wlacpy( 'L', m-p-1, m-q-1, x21(2,1), ldx21, u2(2,2),ldu2 ) - call stdlib_wungqr( m-p, m-p, m-q, u2, ldu2, work(itaup2),work(iorgqr), lorgqr, & + call stdlib_${ci}$lacpy( 'L', m-p-1, m-q-1, x21(2,1), ldx21, u2(2,2),ldu2 ) + call stdlib_${ci}$ungqr( m-p, m-p, m-q, u2, ldu2, work(itaup2),work(iorgqr), lorgqr, & childinfo ) end if if( wantv1t .and. q > 0 ) then - call stdlib_wlacpy( 'U', m-q, q, x21, ldx21, v1t, ldv1t ) - call stdlib_wlacpy( 'U', p-(m-q), q-(m-q), x11(m-q+1,m-q+1), ldx11,v1t(m-q+1,m-q+& + call stdlib_${ci}$lacpy( 'U', m-q, q, x21, ldx21, v1t, ldv1t ) + call stdlib_${ci}$lacpy( 'U', p-(m-q), q-(m-q), x11(m-q+1,m-q+1), ldx11,v1t(m-q+1,m-q+& 1), ldv1t ) - call stdlib_wlacpy( 'U', -p+q, q-p, x21(m-q+1,p+1), ldx21,v1t(p+1,p+1), ldv1t ) + call stdlib_${ci}$lacpy( 'U', -p+q, q-p, x21(m-q+1,p+1), ldx21,v1t(p+1,p+1), ldv1t ) - call stdlib_wunglq( q, q, q, v1t, ldv1t, work(itauq1),work(iorglq), lorglq, & + call stdlib_${ci}$unglq( q, q, q, v1t, ldv1t, work(itauq1),work(iorglq), lorglq, & childinfo ) end if ! simultaneously diagonalize x11 and x21. - call stdlib_wbbcsd( jobu2, jobu1, 'N', jobv1t, 'N', m, m-p, m-q,theta, rwork(iphi), & + call stdlib_${ci}$bbcsd( jobu2, jobu1, 'N', jobv1t, 'N', m, m-p, m-q,theta, rwork(iphi), & u2, ldu2, u1, ldu1, cdum, 1,v1t, ldv1t, rwork(ib11d), rwork(ib11e),rwork(ib12d), & rwork(ib12e), rwork(ib21d),rwork(ib21e), rwork(ib22d), rwork(ib22e),rwork(ibbcsd), & lbbcsd, childinfo ) @@ -77706,18 +77708,18 @@ module stdlib_linalg_lapack_w iwork(i) = i - r end do if( wantu1 ) then - call stdlib_wlapmt( .false., p, p, u1, ldu1, iwork ) + call stdlib_${ci}$lapmt( .false., p, p, u1, ldu1, iwork ) end if if( wantv1t ) then - call stdlib_wlapmr( .false., p, q, v1t, ldv1t, iwork ) + call stdlib_${ci}$lapmr( .false., p, q, v1t, ldv1t, iwork ) end if end if end if return - end subroutine stdlib_wuncsd2by1 + end subroutine stdlib_${ci}$uncsd2by1 - pure subroutine stdlib_wung2l( m, n, k, a, lda, tau, work, info ) + pure subroutine stdlib_${ci}$ung2l( m, n, k, a, lda, tau, work, info ) !! ZUNG2L: generates an m by n complex matrix Q with orthonormal columns, !! which is defined as the last n columns of a product of k elementary !! reflectors of order m @@ -77730,9 +77732,9 @@ module stdlib_linalg_lapack_w integer(ilp), intent(out) :: info integer(ilp), intent(in) :: k, lda, m, n ! Array Arguments - complex(qp), intent(inout) :: a(lda,*) - complex(qp), intent(in) :: tau(*) - complex(qp), intent(out) :: work(*) + complex(${ck}$), intent(inout) :: a(lda,*) + complex(${ck}$), intent(in) :: tau(*) + complex(${ck}$), intent(out) :: work(*) ! ===================================================================== ! Local Scalars @@ -77768,9 +77770,9 @@ module stdlib_linalg_lapack_w ii = n - k + i ! apply h(i) to a(1:m-k+i,1:n-k+i) from the left a( m-n+ii, ii ) = cone - call stdlib_wlarf( 'LEFT', m-n+ii, ii-1, a( 1, ii ), 1, tau( i ), a,lda, work ) + call stdlib_${ci}$larf( 'LEFT', m-n+ii, ii-1, a( 1, ii ), 1, tau( i ), a,lda, work ) - call stdlib_wscal( m-n+ii-1, -tau( i ), a( 1, ii ), 1 ) + call stdlib_${ci}$scal( m-n+ii-1, -tau( i ), a( 1, ii ), 1 ) a( m-n+ii, ii ) = cone - tau( i ) ! set a(m-k+i+1:m,n-k+i) to czero do l = m - n + ii + 1, m @@ -77778,10 +77780,10 @@ module stdlib_linalg_lapack_w end do end do return - end subroutine stdlib_wung2l + end subroutine stdlib_${ci}$ung2l - pure subroutine stdlib_wung2r( m, n, k, a, lda, tau, work, info ) + pure subroutine stdlib_${ci}$ung2r( m, n, k, a, lda, tau, work, info ) !! ZUNG2R: generates an m by n complex matrix Q with orthonormal columns, !! which is defined as the first n columns of a product of k elementary !! reflectors of order m @@ -77794,9 +77796,9 @@ module stdlib_linalg_lapack_w integer(ilp), intent(out) :: info integer(ilp), intent(in) :: k, lda, m, n ! Array Arguments - complex(qp), intent(inout) :: a(lda,*) - complex(qp), intent(in) :: tau(*) - complex(qp), intent(out) :: work(*) + complex(${ck}$), intent(inout) :: a(lda,*) + complex(${ck}$), intent(in) :: tau(*) + complex(${ck}$), intent(out) :: work(*) ! ===================================================================== ! Local Scalars @@ -77832,10 +77834,10 @@ module stdlib_linalg_lapack_w ! apply h(i) to a(i:m,i:n) from the left if( i=k ) then - call stdlib_wungqr( m, n, k, a, lda, tau, work, -1, iinfo ) + call stdlib_${ci}$ungqr( m, n, k, a, lda, tau, work, -1, iinfo ) else if( m>1 ) then - call stdlib_wungqr( m-1, m-1, m-1, a, lda, tau, work, -1,iinfo ) + call stdlib_${ci}$ungqr( m-1, m-1, m-1, a, lda, tau, work, -1,iinfo ) end if end if else if( k1 ) then - call stdlib_wunglq( n-1, n-1, n-1, a, lda, tau, work, -1,iinfo ) + call stdlib_${ci}$unglq( n-1, n-1, n-1, a, lda, tau, work, -1,iinfo ) end if end if end if - lwkopt = real( work( 1 ),KIND=qp) + lwkopt = real( work( 1 ),KIND=${ck}$) lwkopt = max (lwkopt, mn) end if if( info/=0 ) then @@ -77936,11 +77938,11 @@ module stdlib_linalg_lapack_w return end if if( wantq ) then - ! form q, determined by a call to stdlib_wgebrd to reduce an m-by-k + ! form q, determined by a call to stdlib_${ci}$gebrd to reduce an m-by-k ! matrix if( m>=k ) then ! if m >= k, assume m >= n >= k - call stdlib_wungqr( m, n, k, a, lda, tau, work, lwork, iinfo ) + call stdlib_${ci}$ungqr( m, n, k, a, lda, tau, work, lwork, iinfo ) else ! if m < k, assume m = n ! shift the vectors which define the elementary reflectors cone @@ -77958,16 +77960,16 @@ module stdlib_linalg_lapack_w end do if( m>1 ) then ! form q(2:m,2:m) - call stdlib_wungqr( m-1, m-1, m-1, a( 2, 2 ), lda, tau, work,lwork, iinfo ) + call stdlib_${ci}$ungqr( m-1, m-1, m-1, a( 2, 2 ), lda, tau, work,lwork, iinfo ) end if end if else - ! form p**h, determined by a call to stdlib_wgebrd to reduce a k-by-n + ! form p**h, determined by a call to stdlib_${ci}$gebrd to reduce a k-by-n ! matrix if( k= n, assume m = n ! shift the vectors which define the elementary reflectors cone @@ -77985,17 +77987,17 @@ module stdlib_linalg_lapack_w end do if( n>1 ) then ! form p**h(2:n,2:n) - call stdlib_wunglq( n-1, n-1, n-1, a( 2, 2 ), lda, tau, work,lwork, iinfo ) + call stdlib_${ci}$unglq( n-1, n-1, n-1, a( 2, 2 ), lda, tau, work,lwork, iinfo ) end if end if end if work( 1 ) = lwkopt return - end subroutine stdlib_wungbr + end subroutine stdlib_${ci}$ungbr - pure subroutine stdlib_wunghr( n, ilo, ihi, a, lda, tau, work, lwork, info ) + pure subroutine stdlib_${ci}$unghr( n, ilo, ihi, a, lda, tau, work, lwork, info ) !! ZUNGHR: generates a complex unitary matrix Q which is defined as the !! product of IHI-ILO elementary reflectors of order N, as returned by !! ZGEHRD: @@ -78007,9 +78009,9 @@ module stdlib_linalg_lapack_w integer(ilp), intent(in) :: ihi, ilo, lda, lwork, n integer(ilp), intent(out) :: info ! Array Arguments - complex(qp), intent(inout) :: a(lda,*) - complex(qp), intent(in) :: tau(*) - complex(qp), intent(out) :: work(*) + complex(${ck}$), intent(inout) :: a(lda,*) + complex(${ck}$), intent(in) :: tau(*) + complex(${ck}$), intent(out) :: work(*) ! ===================================================================== ! Local Scalars @@ -78077,15 +78079,15 @@ module stdlib_linalg_lapack_w end do if( nh>0 ) then ! generate q(ilo+1:ihi,ilo+1:ihi) - call stdlib_wungqr( nh, nh, nh, a( ilo+1, ilo+1 ), lda, tau( ilo ),work, lwork, & + call stdlib_${ci}$ungqr( nh, nh, nh, a( ilo+1, ilo+1 ), lda, tau( ilo ),work, lwork, & iinfo ) end if work( 1 ) = lwkopt return - end subroutine stdlib_wunghr + end subroutine stdlib_${ci}$unghr - pure subroutine stdlib_wungl2( m, n, k, a, lda, tau, work, info ) + pure subroutine stdlib_${ci}$ungl2( m, n, k, a, lda, tau, work, info ) !! ZUNGL2: generates an m-by-n complex matrix Q with orthonormal rows, !! which is defined as the first m rows of a product of k elementary !! reflectors of order n @@ -78098,9 +78100,9 @@ module stdlib_linalg_lapack_w integer(ilp), intent(out) :: info integer(ilp), intent(in) :: k, lda, m, n ! Array Arguments - complex(qp), intent(inout) :: a(lda,*) - complex(qp), intent(in) :: tau(*) - complex(qp), intent(out) :: work(*) + complex(${ck}$), intent(inout) :: a(lda,*) + complex(${ck}$), intent(in) :: tau(*) + complex(${ck}$), intent(out) :: work(*) ! ===================================================================== ! Local Scalars @@ -78137,14 +78139,14 @@ module stdlib_linalg_lapack_w do i = k, 1, -1 ! apply h(i)**h to a(i:m,i:n) from the right if( i0 ) then ! use blocked code @@ -78250,15 +78252,15 @@ module stdlib_linalg_lapack_w if( i+ib<=m ) then ! form the triangular factor of the block reflector ! h = h(i) h(i+1) . . . h(i+ib-1) - call stdlib_wlarft( 'FORWARD', 'ROWWISE', n-i+1, ib, a( i, i ),lda, tau( i ), & + call stdlib_${ci}$larft( 'FORWARD', 'ROWWISE', n-i+1, ib, a( i, i ),lda, tau( i ), & work, ldwork ) ! apply h**h to a(i+ib:m,i:n) from the right - call stdlib_wlarfb( 'RIGHT', 'CONJUGATE TRANSPOSE', 'FORWARD','ROWWISE', m-i-& + call stdlib_${ci}$larfb( 'RIGHT', 'CONJUGATE TRANSPOSE', 'FORWARD','ROWWISE', m-i-& ib+1, n-i+1, ib, a( i, i ),lda, work, ldwork, a( i+ib, i ), lda,work( ib+1 ), & ldwork ) end if ! apply h**h to columns i:n of current block - call stdlib_wungl2( ib, n-i+1, ib, a( i, i ), lda, tau( i ), work,iinfo ) + call stdlib_${ci}$ungl2( ib, n-i+1, ib, a( i, i ), lda, tau( i ), work,iinfo ) ! set columns 1:i-1 of current block to czero do j = 1, i - 1 do l = i, i + ib - 1 @@ -78269,10 +78271,10 @@ module stdlib_linalg_lapack_w end if work( 1 ) = iws return - end subroutine stdlib_wunglq + end subroutine stdlib_${ci}$unglq - pure subroutine stdlib_wungql( m, n, k, a, lda, tau, work, lwork, info ) + pure subroutine stdlib_${ci}$ungql( m, n, k, a, lda, tau, work, lwork, info ) !! ZUNGQL: generates an M-by-N complex matrix Q with orthonormal columns, !! which is defined as the last N columns of a product of K elementary !! reflectors of order M @@ -78285,9 +78287,9 @@ module stdlib_linalg_lapack_w integer(ilp), intent(out) :: info integer(ilp), intent(in) :: k, lda, lwork, m, n ! Array Arguments - complex(qp), intent(inout) :: a(lda,*) - complex(qp), intent(in) :: tau(*) - complex(qp), intent(out) :: work(*) + complex(${ck}$), intent(inout) :: a(lda,*) + complex(${ck}$), intent(in) :: tau(*) + complex(${ck}$), intent(out) :: work(*) ! ===================================================================== ! Local Scalars @@ -78362,7 +78364,7 @@ module stdlib_linalg_lapack_w kk = 0 end if ! use unblocked code for the first or only block. - call stdlib_wung2l( m-kk, n-kk, k-kk, a, lda, tau, work, iinfo ) + call stdlib_${ci}$ung2l( m-kk, n-kk, k-kk, a, lda, tau, work, iinfo ) if( kk>0 ) then ! use blocked code do i = k - kk + 1, k, nb @@ -78370,15 +78372,15 @@ module stdlib_linalg_lapack_w if( n-k+i>1 ) then ! form the triangular factor of the block reflector ! h = h(i+ib-1) . . . h(i+1) h(i) - call stdlib_wlarft( 'BACKWARD', 'COLUMNWISE', m-k+i+ib-1, ib,a( 1, n-k+i ), & + call stdlib_${ci}$larft( 'BACKWARD', 'COLUMNWISE', m-k+i+ib-1, ib,a( 1, n-k+i ), & lda, tau( i ), work, ldwork ) ! apply h to a(1:m-k+i+ib-1,1:n-k+i-1) from the left - call stdlib_wlarfb( 'LEFT', 'NO TRANSPOSE', 'BACKWARD','COLUMNWISE', m-k+i+ib-& + call stdlib_${ci}$larfb( 'LEFT', 'NO TRANSPOSE', 'BACKWARD','COLUMNWISE', m-k+i+ib-& 1, n-k+i-1, ib,a( 1, n-k+i ), lda, work, ldwork, a, lda,work( ib+1 ), ldwork ) end if ! apply h to rows 1:m-k+i+ib-1 of current block - call stdlib_wung2l( m-k+i+ib-1, ib, ib, a( 1, n-k+i ), lda,tau( i ), work, iinfo & + call stdlib_${ci}$ung2l( m-k+i+ib-1, ib, ib, a( 1, n-k+i ), lda,tau( i ), work, iinfo & ) ! set rows m-k+i+ib:m of current block to czero do j = n - k + i, n - k + i + ib - 1 @@ -78390,10 +78392,10 @@ module stdlib_linalg_lapack_w end if work( 1 ) = iws return - end subroutine stdlib_wungql + end subroutine stdlib_${ci}$ungql - pure subroutine stdlib_wungqr( m, n, k, a, lda, tau, work, lwork, info ) + pure subroutine stdlib_${ci}$ungqr( m, n, k, a, lda, tau, work, lwork, info ) !! ZUNGQR: generates an M-by-N complex matrix Q with orthonormal columns, !! which is defined as the first N columns of a product of K elementary !! reflectors of order M @@ -78406,9 +78408,9 @@ module stdlib_linalg_lapack_w integer(ilp), intent(out) :: info integer(ilp), intent(in) :: k, lda, lwork, m, n ! Array Arguments - complex(qp), intent(inout) :: a(lda,*) - complex(qp), intent(in) :: tau(*) - complex(qp), intent(out) :: work(*) + complex(${ck}$), intent(inout) :: a(lda,*) + complex(${ck}$), intent(in) :: tau(*) + complex(${ck}$), intent(out) :: work(*) ! ===================================================================== ! Local Scalars @@ -78478,7 +78480,7 @@ module stdlib_linalg_lapack_w kk = 0 end if ! use unblocked code for the last or only block. - if( kk0 ) then ! use blocked code @@ -78487,15 +78489,15 @@ module stdlib_linalg_lapack_w if( i+ib<=n ) then ! form the triangular factor of the block reflector ! h = h(i) h(i+1) . . . h(i+ib-1) - call stdlib_wlarft( 'FORWARD', 'COLUMNWISE', m-i+1, ib,a( i, i ), lda, tau( i & + call stdlib_${ci}$larft( 'FORWARD', 'COLUMNWISE', m-i+1, ib,a( i, i ), lda, tau( i & ), work, ldwork ) ! apply h to a(i:m,i+ib:n) from the left - call stdlib_wlarfb( 'LEFT', 'NO TRANSPOSE', 'FORWARD','COLUMNWISE', m-i+1, n-& + call stdlib_${ci}$larfb( 'LEFT', 'NO TRANSPOSE', 'FORWARD','COLUMNWISE', m-i+1, n-& i-ib+1, ib,a( i, i ), lda, work, ldwork, a( i, i+ib ),lda, work( ib+1 ), & ldwork ) end if ! apply h to rows i:m of current block - call stdlib_wung2r( m-i+1, ib, ib, a( i, i ), lda, tau( i ), work,iinfo ) + call stdlib_${ci}$ung2r( m-i+1, ib, ib, a( i, i ), lda, tau( i ), work,iinfo ) ! set rows 1:i-1 of current block to czero do j = i, i + ib - 1 do l = 1, i - 1 @@ -78506,10 +78508,10 @@ module stdlib_linalg_lapack_w end if work( 1 ) = iws return - end subroutine stdlib_wungqr + end subroutine stdlib_${ci}$ungqr - pure subroutine stdlib_wungr2( m, n, k, a, lda, tau, work, info ) + pure subroutine stdlib_${ci}$ungr2( m, n, k, a, lda, tau, work, info ) !! ZUNGR2: generates an m by n complex matrix Q with orthonormal rows, !! which is defined as the last m rows of a product of k elementary !! reflectors of order n @@ -78522,9 +78524,9 @@ module stdlib_linalg_lapack_w integer(ilp), intent(out) :: info integer(ilp), intent(in) :: k, lda, m, n ! Array Arguments - complex(qp), intent(inout) :: a(lda,*) - complex(qp), intent(in) :: tau(*) - complex(qp), intent(out) :: work(*) + complex(${ck}$), intent(inout) :: a(lda,*) + complex(${ck}$), intent(in) :: tau(*) + complex(${ck}$), intent(out) :: work(*) ! ===================================================================== ! Local Scalars @@ -78561,12 +78563,12 @@ module stdlib_linalg_lapack_w do i = 1, k ii = m - k + i ! apply h(i)**h to a(1:m-k+i,1:n-k+i) from the right - call stdlib_wlacgv( n-m+ii-1, a( ii, 1 ), lda ) + call stdlib_${ci}$lacgv( n-m+ii-1, a( ii, 1 ), lda ) a( ii, n-m+ii ) = cone - call stdlib_wlarf( 'RIGHT', ii-1, n-m+ii, a( ii, 1 ), lda,conjg( tau( i ) ), a, lda,& + call stdlib_${ci}$larf( 'RIGHT', ii-1, n-m+ii, a( ii, 1 ), lda,conjg( tau( i ) ), a, lda,& work ) - call stdlib_wscal( n-m+ii-1, -tau( i ), a( ii, 1 ), lda ) - call stdlib_wlacgv( n-m+ii-1, a( ii, 1 ), lda ) + call stdlib_${ci}$scal( n-m+ii-1, -tau( i ), a( ii, 1 ), lda ) + call stdlib_${ci}$lacgv( n-m+ii-1, a( ii, 1 ), lda ) a( ii, n-m+ii ) = cone - conjg( tau( i ) ) ! set a(m-k+i,n-k+i+1:n) to czero do l = n - m + ii + 1, n @@ -78574,10 +78576,10 @@ module stdlib_linalg_lapack_w end do end do return - end subroutine stdlib_wungr2 + end subroutine stdlib_${ci}$ungr2 - pure subroutine stdlib_wungrq( m, n, k, a, lda, tau, work, lwork, info ) + pure subroutine stdlib_${ci}$ungrq( m, n, k, a, lda, tau, work, lwork, info ) !! ZUNGRQ: generates an M-by-N complex matrix Q with orthonormal rows, !! which is defined as the last M rows of a product of K elementary !! reflectors of order N @@ -78590,9 +78592,9 @@ module stdlib_linalg_lapack_w integer(ilp), intent(out) :: info integer(ilp), intent(in) :: k, lda, lwork, m, n ! Array Arguments - complex(qp), intent(inout) :: a(lda,*) - complex(qp), intent(in) :: tau(*) - complex(qp), intent(out) :: work(*) + complex(${ck}$), intent(inout) :: a(lda,*) + complex(${ck}$), intent(in) :: tau(*) + complex(${ck}$), intent(out) :: work(*) ! ===================================================================== ! Local Scalars @@ -78667,7 +78669,7 @@ module stdlib_linalg_lapack_w kk = 0 end if ! use unblocked code for the first or only block. - call stdlib_wungr2( m-kk, n-kk, k-kk, a, lda, tau, work, iinfo ) + call stdlib_${ci}$ungr2( m-kk, n-kk, k-kk, a, lda, tau, work, iinfo ) if( kk>0 ) then ! use blocked code do i = k - kk + 1, k, nb @@ -78676,15 +78678,15 @@ module stdlib_linalg_lapack_w if( ii>1 ) then ! form the triangular factor of the block reflector ! h = h(i+ib-1) . . . h(i+1) h(i) - call stdlib_wlarft( 'BACKWARD', 'ROWWISE', n-k+i+ib-1, ib,a( ii, 1 ), lda, & + call stdlib_${ci}$larft( 'BACKWARD', 'ROWWISE', n-k+i+ib-1, ib,a( ii, 1 ), lda, & tau( i ), work, ldwork ) ! apply h**h to a(1:m-k+i-1,1:n-k+i+ib-1) from the right - call stdlib_wlarfb( 'RIGHT', 'CONJUGATE TRANSPOSE', 'BACKWARD','ROWWISE', ii-& + call stdlib_${ci}$larfb( 'RIGHT', 'CONJUGATE TRANSPOSE', 'BACKWARD','ROWWISE', ii-& 1, n-k+i+ib-1, ib, a( ii, 1 ),lda, work, ldwork, a, lda, work( ib+1 ),ldwork ) end if ! apply h**h to columns 1:n-k+i+ib-1 of current block - call stdlib_wungr2( ib, n-k+i+ib-1, ib, a( ii, 1 ), lda, tau( i ),work, iinfo ) + call stdlib_${ci}$ungr2( ib, n-k+i+ib-1, ib, a( ii, 1 ), lda, tau( i ),work, iinfo ) ! set columns n-k+i+ib:n of current block to czero do l = n - k + i + ib, n @@ -78696,10 +78698,10 @@ module stdlib_linalg_lapack_w end if work( 1 ) = iws return - end subroutine stdlib_wungrq + end subroutine stdlib_${ci}$ungrq - pure subroutine stdlib_wungtr( uplo, n, a, lda, tau, work, lwork, info ) + pure subroutine stdlib_${ci}$ungtr( uplo, n, a, lda, tau, work, lwork, info ) !! ZUNGTR: generates a complex unitary matrix Q which is defined as the !! product of n-1 elementary reflectors of order N, as returned by !! ZHETRD: @@ -78713,9 +78715,9 @@ module stdlib_linalg_lapack_w integer(ilp), intent(out) :: info integer(ilp), intent(in) :: lda, lwork, n ! Array Arguments - complex(qp), intent(inout) :: a(lda,*) - complex(qp), intent(in) :: tau(*) - complex(qp), intent(out) :: work(*) + complex(${ck}$), intent(inout) :: a(lda,*) + complex(${ck}$), intent(in) :: tau(*) + complex(${ck}$), intent(out) :: work(*) ! ===================================================================== ! Local Scalars @@ -78758,7 +78760,7 @@ module stdlib_linalg_lapack_w return end if if( upper ) then - ! q was determined by a call to stdlib_whetrd with uplo = 'u' + ! q was determined by a call to stdlib_${ci}$hetrd with uplo = 'u' ! shift the vectors which define the elementary reflectors cone ! column to the left, and set the last row and column of q to ! those of the unit matrix @@ -78773,9 +78775,9 @@ module stdlib_linalg_lapack_w end do a( n, n ) = cone ! generate q(1:n-1,1:n-1) - call stdlib_wungql( n-1, n-1, n-1, a, lda, tau, work, lwork, iinfo ) + call stdlib_${ci}$ungql( n-1, n-1, n-1, a, lda, tau, work, lwork, iinfo ) else - ! q was determined by a call to stdlib_whetrd with uplo = 'l'. + ! q was determined by a call to stdlib_${ci}$hetrd with uplo = 'l'. ! shift the vectors which define the elementary reflectors cone ! column to the right, and set the first row and column of q to ! those of the unit matrix @@ -78791,16 +78793,16 @@ module stdlib_linalg_lapack_w end do if( n>1 ) then ! generate q(2:n,2:n) - call stdlib_wungqr( n-1, n-1, n-1, a( 2, 2 ), lda, tau, work,lwork, iinfo ) + call stdlib_${ci}$ungqr( n-1, n-1, n-1, a( 2, 2 ), lda, tau, work,lwork, iinfo ) end if end if work( 1 ) = lwkopt return - end subroutine stdlib_wungtr + end subroutine stdlib_${ci}$ungtr - pure subroutine stdlib_wungtsqr( m, n, mb, nb, a, lda, t, ldt, work, lwork,info ) + pure subroutine stdlib_${ci}$ungtsqr( m, n, mb, nb, a, lda, t, ldt, work, lwork,info ) !! ZUNGTSQR: generates an M-by-N complex matrix Q_out with orthonormal !! columns, which are the first N columns of a product of comlpex unitary !! matrices of order M which are returned by ZLATSQR @@ -78813,9 +78815,9 @@ module stdlib_linalg_lapack_w integer(ilp), intent(out) :: info integer(ilp), intent(in) :: lda, ldt, lwork, m, n, mb, nb ! Array Arguments - complex(qp), intent(inout) :: a(lda,*) - complex(qp), intent(in) :: t(ldt,*) - complex(qp), intent(out) :: work(*) + complex(${ck}$), intent(inout) :: a(lda,*) + complex(${ck}$), intent(in) :: t(ldt,*) + complex(${ck}$), intent(out) :: work(*) ! ===================================================================== ! Local Scalars @@ -78842,15 +78844,15 @@ module stdlib_linalg_lapack_w else ! test the input lwork for the dimension of the array work. ! this workspace is used to store array c(ldc, n) and work(lwork) - ! in the call to stdlib_wlamtsqr. see the documentation for stdlib_wlamtsqr. + ! in the call to stdlib_${ci}$lamtsqr. see the documentation for stdlib_${ci}$lamtsqr. if( lwork<2 .and. (.not.lquery) ) then info = -10 else ! set block size for column blocks nblocal = min( nb, n ) ! lwork = -1, then set the size for the array c(ldc,n) - ! in stdlib_wlamtsqr call and set the optimal size of the work array - ! work(lwork) in stdlib_wlamtsqr call. + ! in stdlib_${ci}$lamtsqr call and set the optimal size of the work array + ! work(lwork) in stdlib_${ci}$lamtsqr call. ldc = m lc = ldc*n lw = n * nblocal @@ -78865,40 +78867,40 @@ module stdlib_linalg_lapack_w call stdlib_xerbla( 'ZUNGTSQR', -info ) return else if ( lquery ) then - work( 1 ) = cmplx( lworkopt,KIND=qp) + work( 1 ) = cmplx( lworkopt,KIND=${ck}$) return end if ! quick return if possible if( min( m, n )==0 ) then - work( 1 ) = cmplx( lworkopt,KIND=qp) + work( 1 ) = cmplx( lworkopt,KIND=${ck}$) return end if ! (1) form explicitly the tall-skinny m-by-n left submatrix q1_in ! of m-by-m orthogonal matrix q_in, which is implicitly stored in ! the subdiagonal part of input array a and in the input array t. - ! perform by the following operation using the routine stdlib_wlamtsqr. + ! perform by the following operation using the routine stdlib_${ci}$lamtsqr. ! q1_in = q_in * ( i ), where i is a n-by-n identity matrix, ! ( 0 ) 0 is a (m-n)-by-n zero matrix. ! (1a) form m-by-n matrix in the array work(1:ldc*n) with ones ! on the diagonal and zeros elsewhere. - call stdlib_wlaset( 'F', m, n, czero, cone, work, ldc ) + call stdlib_${ci}$laset( 'F', m, n, czero, cone, work, ldc ) ! (1b) on input, work(1:ldc*n) stores ( i ); ! ( 0 ) ! on output, work(1:ldc*n) stores q1_in. - call stdlib_wlamtsqr( 'L', 'N', m, n, n, mb, nblocal, a, lda, t, ldt,work, ldc, work( & + call stdlib_${ci}$lamtsqr( 'L', 'N', m, n, n, mb, nblocal, a, lda, t, ldt,work, ldc, work( & lc+1 ), lw, iinfo ) ! (2) copy the result from the part of the work array (1:m,1:n) ! with the leading dimension ldc that starts at work(1) into ! the output array a(1:m,1:n) column-by-column. do j = 1, n - call stdlib_wcopy( m, work( (j-1)*ldc + 1 ), 1, a( 1, j ), 1 ) + call stdlib_${ci}$copy( m, work( (j-1)*ldc + 1 ), 1, a( 1, j ), 1 ) end do - work( 1 ) = cmplx( lworkopt,KIND=qp) + work( 1 ) = cmplx( lworkopt,KIND=${ck}$) return - end subroutine stdlib_wungtsqr + end subroutine stdlib_${ci}$ungtsqr - pure subroutine stdlib_wungtsqr_row( m, n, mb, nb, a, lda, t, ldt, work,lwork, info ) + pure subroutine stdlib_${ci}$ungtsqr_row( m, n, mb, nb, a, lda, t, ldt, work,lwork, info ) !! ZUNGTSQR_ROW: generates an M-by-N complex matrix Q_out with !! orthonormal columns from the output of ZLATSQR. These N orthonormal !! columns are the first N columns of a product of complex unitary @@ -78921,9 +78923,9 @@ module stdlib_linalg_lapack_w integer(ilp), intent(out) :: info integer(ilp), intent(in) :: lda, ldt, lwork, m, n, mb, nb ! Array Arguments - complex(qp), intent(inout) :: a(lda,*) - complex(qp), intent(in) :: t(ldt,*) - complex(qp), intent(out) :: work(*) + complex(${ck}$), intent(inout) :: a(lda,*) + complex(${ck}$), intent(in) :: t(ldt,*) + complex(${ck}$), intent(out) :: work(*) ! ===================================================================== ! Local Scalars @@ -78931,7 +78933,7 @@ module stdlib_linalg_lapack_w integer(ilp) :: nblocal, mb2, m_plus_one, itmp, ib_bottom, lworkopt, & num_all_row_blocks, jb_t, ib, imb, kb, kb_last, knb, mb1 ! Local Arrays - complex(qp) :: dummy(1,1) + complex(${ck}$) :: dummy(1,1) ! Intrinsic Functions intrinsic :: cmplx,max,min ! Executable Statements @@ -78963,17 +78965,17 @@ module stdlib_linalg_lapack_w call stdlib_xerbla( 'ZUNGTSQR_ROW', -info ) return else if ( lquery ) then - work( 1 ) = cmplx( lworkopt,KIND=qp) + work( 1 ) = cmplx( lworkopt,KIND=${ck}$) return end if ! quick return if possible if( min( m, n )==0 ) then - work( 1 ) = cmplx( lworkopt,KIND=qp) + work( 1 ) = cmplx( lworkopt,KIND=${ck}$) return end if ! (0) set the upper-triangular part of the matrix a to zero and ! its diagonal elements to one. - call stdlib_wlaset('U', m, n, czero, cone, a, lda ) + call stdlib_${ci}$laset('U', m, n, czero, cone, a, lda ) ! kb_last is the column index of the last column block reflector ! in the matrices t and v. kb_last = ( ( n-1 ) / nblocal ) * nblocal + 1 @@ -79009,7 +79011,7 @@ module stdlib_linalg_lapack_w ! determine the size of the current column block knb in ! the matrices t and v. knb = min( nblocal, n - kb + 1 ) - call stdlib_wlarfb_gett( 'I', imb, n-kb+1, knb,t( 1, jb_t+kb-1 ), ldt, a( kb, & + call stdlib_${ci}$larfb_gett( 'I', imb, n-kb+1, knb,t( 1, jb_t+kb-1 ), ldt, a( kb, & kb ), lda,a( ib, kb ), lda, work, knb ) end do end do @@ -79029,19 +79031,19 @@ module stdlib_linalg_lapack_w ! in stdlib_dlarfb_gett parameters, when m=0, then the matrix b ! does not exist, hence we need to pass a dummy array ! reference dummy(1,1) to b with lddummy=1. - call stdlib_wlarfb_gett( 'N', 0, n-kb+1, knb,t( 1, kb ), ldt, a( kb, kb ), lda,& + call stdlib_${ci}$larfb_gett( 'N', 0, n-kb+1, knb,t( 1, kb ), ldt, a( kb, kb ), lda,& dummy( 1, 1 ), 1, work, knb ) else - call stdlib_wlarfb_gett( 'N', mb1-kb-knb+1, n-kb+1, knb,t( 1, kb ), ldt, a( kb, & + call stdlib_${ci}$larfb_gett( 'N', mb1-kb-knb+1, n-kb+1, knb,t( 1, kb ), ldt, a( kb, & kb ), lda,a( kb+knb, kb), lda, work, knb ) end if end do - work( 1 ) = cmplx( lworkopt,KIND=qp) + work( 1 ) = cmplx( lworkopt,KIND=${ck}$) return - end subroutine stdlib_wungtsqr_row + end subroutine stdlib_${ci}$ungtsqr_row - pure subroutine stdlib_wunhr_col( m, n, nb, a, lda, t, ldt, d, info ) + pure subroutine stdlib_${ci}$unhr_col( m, n, nb, a, lda, t, ldt, d, info ) !! ZUNHR_COL: takes an M-by-N complex matrix Q_in with orthonormal columns !! as input, stored in A, and performs Householder Reconstruction (HR), !! i.e. reconstructs Householder vectors V(i) implicitly representing @@ -79058,8 +79060,8 @@ module stdlib_linalg_lapack_w integer(ilp), intent(out) :: info integer(ilp), intent(in) :: lda, ldt, m, n, nb ! Array Arguments - complex(qp), intent(inout) :: a(lda,*) - complex(qp), intent(out) :: d(*), t(ldt,*) + complex(${ck}$), intent(inout) :: a(lda,*) + complex(${ck}$), intent(out) :: d(*), t(ldt,*) ! ===================================================================== ! Local Scalars @@ -79097,10 +79099,10 @@ module stdlib_linalg_lapack_w ! ( 0 ) ( v2 ) ! where 0 is an (m-n)-by-n zero matrix. ! (1-1) factor v1 and u. - call stdlib_wlaunhr_col_getrfnp( n, n, a, lda, d, iinfo ) + call stdlib_${ci}$launhr_col_getrfnp( n, n, a, lda, d, iinfo ) ! (1-2) solve for v2. if( m>n ) then - call stdlib_wtrsm( 'R', 'U', 'N', 'N', m-n, n, cone, a, lda,a( n+1, 1 ), lda ) + call stdlib_${ci}$trsm( 'R', 'U', 'N', 'N', m-n, n, cone, a, lda,a( n+1, 1 ), lda ) end if ! (2) reconstruct the block reflector t stored in t(1:nb, 1:n) @@ -79120,7 +79122,7 @@ module stdlib_linalg_lapack_w ! column-by-column, total jnb*(jnb+1)/2 elements. jbtemp1 = jb - 1 do j = jb, jb+jnb-1 - call stdlib_wcopy( j-jbtemp1, a( jb, j ), 1, t( 1, j ), 1 ) + call stdlib_${ci}$copy( j-jbtemp1, a( jb, j ), 1, t( 1, j ), 1 ) end do ! (2-2) perform on the upper-triangular part of the current ! jnb-by-jnb diagonal block u(jb) (of the n-by-n matrix u) stored @@ -79134,7 +79136,7 @@ module stdlib_linalg_lapack_w ! s(jb), i.e. s(j,j) that is stored in the array element d(j). do j = jb, jb+jnb-1 if( d( j )==cone ) then - call stdlib_wscal( j-jbtemp1, -cone, t( 1, j ), 1 ) + call stdlib_${ci}$scal( j-jbtemp1, -cone, t( 1, j ), 1 ) end if end do ! (2-3) perform the triangular solve for the current block @@ -79158,11 +79160,11 @@ module stdlib_linalg_lapack_w ! upper-triangular block t(jb): ! t(jb) * (v1(jb)**t) = (-1)*u(jb)*s(jb). ! even though the blocks x(jb) and b(jb) are upper- - ! triangular, the routine stdlib_wtrsm will access all jnb**2 + ! triangular, the routine stdlib_${ci}$trsm will access all jnb**2 ! elements of the square t(1:jnb,jb:jb+jnb-1). therefore, ! we need to set to zero the elements of the block ! t(1:jnb,jb:jb+jnb-1) below the diagonal before the call - ! to stdlib_wtrsm. + ! to stdlib_${ci}$trsm. ! (2-3a) set the elements to zero. jbtemp2 = jb - 2 do j = jb, jb+jnb-2 @@ -79171,14 +79173,14 @@ module stdlib_linalg_lapack_w end do end do ! (2-3b) perform the triangular solve. - call stdlib_wtrsm( 'R', 'L', 'C', 'U', jnb, jnb, cone,a( jb, jb ), lda, t( 1, jb ), & + call stdlib_${ci}$trsm( 'R', 'L', 'C', 'U', jnb, jnb, cone,a( jb, jb ), lda, t( 1, jb ), & ldt ) end do return - end subroutine stdlib_wunhr_col + end subroutine stdlib_${ci}$unhr_col - pure subroutine stdlib_wunm22( side, trans, m, n, n1, n2, q, ldq, c, ldc,work, lwork, info ) + pure subroutine stdlib_${ci}$unm22( side, trans, m, n, n1, n2, q, ldq, c, ldc,work, lwork, info ) ! -- lapack computational routine -- ! -- lapack is a software package provided by univ. of tennessee, -- @@ -79188,9 +79190,9 @@ module stdlib_linalg_lapack_w integer(ilp), intent(in) :: m, n, n1, n2, ldq, ldc, lwork integer(ilp), intent(out) :: info ! Array Arguments - complex(qp), intent(in) :: q(ldq,*) - complex(qp), intent(inout) :: c(ldc,*) - complex(qp), intent(out) :: work(*) + complex(${ck}$), intent(in) :: q(ldq,*) + complex(${ck}$), intent(inout) :: c(ldc,*) + complex(${ck}$), intent(out) :: work(*) ! ===================================================================== ! Local Scalars @@ -79235,7 +79237,7 @@ module stdlib_linalg_lapack_w end if if( info==0 ) then lwkopt = m*n - work( 1 ) = cmplx( lwkopt,KIND=qp) + work( 1 ) = cmplx( lwkopt,KIND=${ck}$) end if if( info/=0 ) then call stdlib_xerbla( 'ZUNM22', -info ) @@ -79248,14 +79250,14 @@ module stdlib_linalg_lapack_w work( 1 ) = 1 return end if - ! degenerate cases (n1 = 0 or n2 = 0) are handled using stdlib_wtrmm. + ! degenerate cases (n1 = 0 or n2 = 0) are handled using stdlib_${ci}$trmm. if( n1==0 ) then - call stdlib_wtrmm( side, 'UPPER', trans, 'NON-UNIT', m, n, cone,q, ldq, c, ldc ) + call stdlib_${ci}$trmm( side, 'UPPER', trans, 'NON-UNIT', m, n, cone,q, ldq, c, ldc ) work( 1 ) = cone return else if( n2==0 ) then - call stdlib_wtrmm( side, 'LOWER', trans, 'NON-UNIT', m, n, cone,q, ldq, c, ldc ) + call stdlib_${ci}$trmm( side, 'LOWER', trans, 'NON-UNIT', m, n, cone,q, ldq, c, ldc ) work( 1 ) = cone return @@ -79268,44 +79270,44 @@ module stdlib_linalg_lapack_w len = min( nb, n-i+1 ) ldwork = m ! multiply bottom part of c by q12. - call stdlib_wlacpy( 'ALL', n1, len, c( n2+1, i ), ldc, work,ldwork ) - call stdlib_wtrmm( 'LEFT', 'LOWER', 'NO TRANSPOSE', 'NON-UNIT',n1, len, cone, & + call stdlib_${ci}$lacpy( 'ALL', n1, len, c( n2+1, i ), ldc, work,ldwork ) + call stdlib_${ci}$trmm( 'LEFT', 'LOWER', 'NO TRANSPOSE', 'NON-UNIT',n1, len, cone, & q( 1, n2+1 ), ldq, work,ldwork ) ! multiply top part of c by q11. - call stdlib_wgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', n1, len, n2,cone, q, ldq, & + call stdlib_${ci}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', n1, len, n2,cone, q, ldq, & c( 1, i ), ldc, cone, work,ldwork ) ! multiply top part of c by q21. - call stdlib_wlacpy( 'ALL', n2, len, c( 1, i ), ldc,work( n1+1 ), ldwork ) + call stdlib_${ci}$lacpy( 'ALL', n2, len, c( 1, i ), ldc,work( n1+1 ), ldwork ) - call stdlib_wtrmm( 'LEFT', 'UPPER', 'NO TRANSPOSE', 'NON-UNIT',n2, len, cone, & + call stdlib_${ci}$trmm( 'LEFT', 'UPPER', 'NO TRANSPOSE', 'NON-UNIT',n2, len, cone, & q( n1+1, 1 ), ldq,work( n1+1 ), ldwork ) ! multiply bottom part of c by q22. - call stdlib_wgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', n2, len, n1,cone, q( n1+1, & + call stdlib_${ci}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', n2, len, n1,cone, q( n1+1, & n2+1 ), ldq, c( n2+1, i ), ldc,cone, work( n1+1 ), ldwork ) ! copy everything back. - call stdlib_wlacpy( 'ALL', m, len, work, ldwork, c( 1, i ),ldc ) + call stdlib_${ci}$lacpy( 'ALL', m, len, work, ldwork, c( 1, i ),ldc ) end do else do i = 1, n, nb len = min( nb, n-i+1 ) ldwork = m ! multiply bottom part of c by q21**h. - call stdlib_wlacpy( 'ALL', n2, len, c( n1+1, i ), ldc, work,ldwork ) - call stdlib_wtrmm( 'LEFT', 'UPPER', 'CONJUGATE', 'NON-UNIT',n2, len, cone, q( & + call stdlib_${ci}$lacpy( 'ALL', n2, len, c( n1+1, i ), ldc, work,ldwork ) + call stdlib_${ci}$trmm( 'LEFT', 'UPPER', 'CONJUGATE', 'NON-UNIT',n2, len, cone, q( & n1+1, 1 ), ldq, work,ldwork ) ! multiply top part of c by q11**h. - call stdlib_wgemm( 'CONJUGATE', 'NO TRANSPOSE', n2, len, n1,cone, q, ldq, c( & + call stdlib_${ci}$gemm( 'CONJUGATE', 'NO TRANSPOSE', n2, len, n1,cone, q, ldq, c( & 1, i ), ldc, cone, work,ldwork ) ! multiply top part of c by q12**h. - call stdlib_wlacpy( 'ALL', n1, len, c( 1, i ), ldc,work( n2+1 ), ldwork ) + call stdlib_${ci}$lacpy( 'ALL', n1, len, c( 1, i ), ldc,work( n2+1 ), ldwork ) - call stdlib_wtrmm( 'LEFT', 'LOWER', 'CONJUGATE', 'NON-UNIT',n1, len, cone, q( & + call stdlib_${ci}$trmm( 'LEFT', 'LOWER', 'CONJUGATE', 'NON-UNIT',n1, len, cone, q( & 1, n2+1 ), ldq,work( n2+1 ), ldwork ) ! multiply bottom part of c by q22**h. - call stdlib_wgemm( 'CONJUGATE', 'NO TRANSPOSE', n1, len, n2,cone, q( n1+1, n2+& + call stdlib_${ci}$gemm( 'CONJUGATE', 'NO TRANSPOSE', n1, len, n2,cone, q( n1+1, n2+& 1 ), ldq, c( n1+1, i ), ldc,cone, work( n2+1 ), ldwork ) ! copy everything back. - call stdlib_wlacpy( 'ALL', m, len, work, ldwork, c( 1, i ),ldc ) + call stdlib_${ci}$lacpy( 'ALL', m, len, work, ldwork, c( 1, i ),ldc ) end do end if else @@ -79314,53 +79316,53 @@ module stdlib_linalg_lapack_w len = min( nb, m-i+1 ) ldwork = len ! multiply right part of c by q21. - call stdlib_wlacpy( 'ALL', len, n2, c( i, n1+1 ), ldc, work,ldwork ) - call stdlib_wtrmm( 'RIGHT', 'UPPER', 'NO TRANSPOSE', 'NON-UNIT',len, n2, cone,& + call stdlib_${ci}$lacpy( 'ALL', len, n2, c( i, n1+1 ), ldc, work,ldwork ) + call stdlib_${ci}$trmm( 'RIGHT', 'UPPER', 'NO TRANSPOSE', 'NON-UNIT',len, n2, cone,& q( n1+1, 1 ), ldq, work,ldwork ) ! multiply left part of c by q11. - call stdlib_wgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', len, n2, n1,cone, c( i, 1 )& + call stdlib_${ci}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', len, n2, n1,cone, c( i, 1 )& , ldc, q, ldq, cone, work,ldwork ) ! multiply left part of c by q12. - call stdlib_wlacpy( 'ALL', len, n1, c( i, 1 ), ldc,work( 1 + n2*ldwork ), & + call stdlib_${ci}$lacpy( 'ALL', len, n1, c( i, 1 ), ldc,work( 1 + n2*ldwork ), & ldwork ) - call stdlib_wtrmm( 'RIGHT', 'LOWER', 'NO TRANSPOSE', 'NON-UNIT',len, n1, cone,& + call stdlib_${ci}$trmm( 'RIGHT', 'LOWER', 'NO TRANSPOSE', 'NON-UNIT',len, n1, cone,& q( 1, n2+1 ), ldq,work( 1 + n2*ldwork ), ldwork ) ! multiply right part of c by q22. - call stdlib_wgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', len, n1, n2,cone, c( i, n1+& + call stdlib_${ci}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', len, n1, n2,cone, c( i, n1+& 1 ), ldc, q( n1+1, n2+1 ), ldq,cone, work( 1 + n2*ldwork ), ldwork ) ! copy everything back. - call stdlib_wlacpy( 'ALL', len, n, work, ldwork, c( i, 1 ),ldc ) + call stdlib_${ci}$lacpy( 'ALL', len, n, work, ldwork, c( i, 1 ),ldc ) end do else do i = 1, m, nb len = min( nb, m-i+1 ) ldwork = len ! multiply right part of c by q12**h. - call stdlib_wlacpy( 'ALL', len, n1, c( i, n2+1 ), ldc, work,ldwork ) - call stdlib_wtrmm( 'RIGHT', 'LOWER', 'CONJUGATE', 'NON-UNIT',len, n1, cone, q(& + call stdlib_${ci}$lacpy( 'ALL', len, n1, c( i, n2+1 ), ldc, work,ldwork ) + call stdlib_${ci}$trmm( 'RIGHT', 'LOWER', 'CONJUGATE', 'NON-UNIT',len, n1, cone, q(& 1, n2+1 ), ldq, work,ldwork ) ! multiply left part of c by q11**h. - call stdlib_wgemm( 'NO TRANSPOSE', 'CONJUGATE', len, n1, n2,cone, c( i, 1 ), & + call stdlib_${ci}$gemm( 'NO TRANSPOSE', 'CONJUGATE', len, n1, n2,cone, c( i, 1 ), & ldc, q, ldq, cone, work,ldwork ) ! multiply left part of c by q21**h. - call stdlib_wlacpy( 'ALL', len, n2, c( i, 1 ), ldc,work( 1 + n1*ldwork ), & + call stdlib_${ci}$lacpy( 'ALL', len, n2, c( i, 1 ), ldc,work( 1 + n1*ldwork ), & ldwork ) - call stdlib_wtrmm( 'RIGHT', 'UPPER', 'CONJUGATE', 'NON-UNIT',len, n2, cone, q(& + call stdlib_${ci}$trmm( 'RIGHT', 'UPPER', 'CONJUGATE', 'NON-UNIT',len, n2, cone, q(& n1+1, 1 ), ldq,work( 1 + n1*ldwork ), ldwork ) ! multiply right part of c by q22**h. - call stdlib_wgemm( 'NO TRANSPOSE', 'CONJUGATE', len, n2, n1,cone, c( i, n2+1 )& + call stdlib_${ci}$gemm( 'NO TRANSPOSE', 'CONJUGATE', len, n2, n1,cone, c( i, n2+1 )& , ldc, q( n1+1, n2+1 ), ldq,cone, work( 1 + n1*ldwork ), ldwork ) ! copy everything back. - call stdlib_wlacpy( 'ALL', len, n, work, ldwork, c( i, 1 ),ldc ) + call stdlib_${ci}$lacpy( 'ALL', len, n, work, ldwork, c( i, 1 ),ldc ) end do end if end if - work( 1 ) = cmplx( lwkopt,KIND=qp) + work( 1 ) = cmplx( lwkopt,KIND=${ck}$) return - end subroutine stdlib_wunm22 + end subroutine stdlib_${ci}$unm22 - pure subroutine stdlib_wunm2l( side, trans, m, n, k, a, lda, tau, c, ldc,work, info ) + pure subroutine stdlib_${ci}$unm2l( side, trans, m, n, k, a, lda, tau, c, ldc,work, info ) !! ZUNM2L: overwrites the general complex m-by-n matrix C with !! Q * C if SIDE = 'L' and TRANS = 'N', or !! Q**H* C if SIDE = 'L' and TRANS = 'C', or @@ -79379,15 +79381,15 @@ module stdlib_linalg_lapack_w integer(ilp), intent(out) :: info integer(ilp), intent(in) :: k, lda, ldc, m, n ! Array Arguments - complex(qp), intent(inout) :: a(lda,*), c(ldc,*) - complex(qp), intent(in) :: tau(*) - complex(qp), intent(out) :: work(*) + complex(${ck}$), intent(inout) :: a(lda,*), c(ldc,*) + complex(${ck}$), intent(in) :: tau(*) + complex(${ck}$), intent(out) :: work(*) ! ===================================================================== ! Local Scalars logical(lk) :: left, notran integer(ilp) :: i, i1, i2, i3, mi, ni, nq - complex(qp) :: aii, taui + complex(${ck}$) :: aii, taui ! Intrinsic Functions intrinsic :: conjg,max ! Executable Statements @@ -79452,14 +79454,14 @@ module stdlib_linalg_lapack_w end if aii = a( nq-k+i, i ) a( nq-k+i, i ) = cone - call stdlib_wlarf( side, mi, ni, a( 1, i ), 1, taui, c, ldc, work ) + call stdlib_${ci}$larf( side, mi, ni, a( 1, i ), 1, taui, c, ldc, work ) a( nq-k+i, i ) = aii end do return - end subroutine stdlib_wunm2l + end subroutine stdlib_${ci}$unm2l - pure subroutine stdlib_wunm2r( side, trans, m, n, k, a, lda, tau, c, ldc,work, info ) + pure subroutine stdlib_${ci}$unm2r( side, trans, m, n, k, a, lda, tau, c, ldc,work, info ) !! ZUNM2R: overwrites the general complex m-by-n matrix C with !! Q * C if SIDE = 'L' and TRANS = 'N', or !! Q**H* C if SIDE = 'L' and TRANS = 'C', or @@ -79478,15 +79480,15 @@ module stdlib_linalg_lapack_w integer(ilp), intent(out) :: info integer(ilp), intent(in) :: k, lda, ldc, m, n ! Array Arguments - complex(qp), intent(inout) :: a(lda,*), c(ldc,*) - complex(qp), intent(in) :: tau(*) - complex(qp), intent(out) :: work(*) + complex(${ck}$), intent(inout) :: a(lda,*), c(ldc,*) + complex(${ck}$), intent(in) :: tau(*) + complex(${ck}$), intent(out) :: work(*) ! ===================================================================== ! Local Scalars logical(lk) :: left, notran integer(ilp) :: i, i1, i2, i3, ic, jc, mi, ni, nq - complex(qp) :: aii, taui + complex(${ck}$) :: aii, taui ! Intrinsic Functions intrinsic :: conjg,max ! Executable Statements @@ -79555,14 +79557,14 @@ module stdlib_linalg_lapack_w end if aii = a( i, i ) a( i, i ) = cone - call stdlib_wlarf( side, mi, ni, a( i, i ), 1, taui, c( ic, jc ), ldc,work ) + call stdlib_${ci}$larf( side, mi, ni, a( i, i ), 1, taui, c( ic, jc ), ldc,work ) a( i, i ) = aii end do return - end subroutine stdlib_wunm2r + end subroutine stdlib_${ci}$unm2r - pure subroutine stdlib_wunmbr( vect, side, trans, m, n, k, a, lda, tau, c,ldc, work, lwork, & + pure subroutine stdlib_${ci}$unmbr( vect, side, trans, m, n, k, a, lda, tau, c,ldc, work, lwork, & !! If VECT = 'Q', ZUNMBR: overwrites the general complex M-by-N matrix C !! with !! SIDE = 'L' SIDE = 'R' @@ -79594,9 +79596,9 @@ module stdlib_linalg_lapack_w integer(ilp), intent(out) :: info integer(ilp), intent(in) :: k, lda, ldc, lwork, m, n ! Array Arguments - complex(qp), intent(inout) :: a(lda,*), c(ldc,*) - complex(qp), intent(in) :: tau(*) - complex(qp), intent(out) :: work(*) + complex(${ck}$), intent(inout) :: a(lda,*), c(ldc,*) + complex(${ck}$), intent(in) :: tau(*) + complex(${ck}$), intent(out) :: work(*) ! ===================================================================== ! Local Scalars logical(lk) :: applyq, left, lquery, notran @@ -79671,11 +79673,11 @@ module stdlib_linalg_lapack_w if( applyq ) then ! apply q if( nq>=k ) then - ! q was determined by a call to stdlib_wgebrd with nq >= k - call stdlib_wunmqr( side, trans, m, n, k, a, lda, tau, c, ldc,work, lwork, iinfo & + ! q was determined by a call to stdlib_${ci}$gebrd with nq >= k + call stdlib_${ci}$unmqr( side, trans, m, n, k, a, lda, tau, c, ldc,work, lwork, iinfo & ) else if( nq>1 ) then - ! q was determined by a call to stdlib_wgebrd with nq < k + ! q was determined by a call to stdlib_${ci}$gebrd with nq < k if( left ) then mi = m - 1 ni = n @@ -79687,7 +79689,7 @@ module stdlib_linalg_lapack_w i1 = 1 i2 = 2 end if - call stdlib_wunmqr( side, trans, mi, ni, nq-1, a( 2, 1 ), lda, tau,c( i1, i2 ), & + call stdlib_${ci}$unmqr( side, trans, mi, ni, nq-1, a( 2, 1 ), lda, tau,c( i1, i2 ), & ldc, work, lwork, iinfo ) end if else @@ -79698,11 +79700,11 @@ module stdlib_linalg_lapack_w transt = 'N' end if if( nq>k ) then - ! p was determined by a call to stdlib_wgebrd with nq > k - call stdlib_wunmlq( side, transt, m, n, k, a, lda, tau, c, ldc,work, lwork, & + ! p was determined by a call to stdlib_${ci}$gebrd with nq > k + call stdlib_${ci}$unmlq( side, transt, m, n, k, a, lda, tau, c, ldc,work, lwork, & iinfo ) else if( nq>1 ) then - ! p was determined by a call to stdlib_wgebrd with nq <= k + ! p was determined by a call to stdlib_${ci}$gebrd with nq <= k if( left ) then mi = m - 1 ni = n @@ -79714,16 +79716,16 @@ module stdlib_linalg_lapack_w i1 = 1 i2 = 2 end if - call stdlib_wunmlq( side, transt, mi, ni, nq-1, a( 1, 2 ), lda,tau, c( i1, i2 ), & + call stdlib_${ci}$unmlq( side, transt, mi, ni, nq-1, a( 1, 2 ), lda,tau, c( i1, i2 ), & ldc, work, lwork, iinfo ) end if end if work( 1 ) = lwkopt return - end subroutine stdlib_wunmbr + end subroutine stdlib_${ci}$unmbr - pure subroutine stdlib_wunmhr( side, trans, m, n, ilo, ihi, a, lda, tau, c,ldc, work, lwork, & + pure subroutine stdlib_${ci}$unmhr( side, trans, m, n, ilo, ihi, a, lda, tau, c,ldc, work, lwork, & !! ZUNMHR: overwrites the general complex M-by-N matrix C with !! SIDE = 'L' SIDE = 'R' !! TRANS = 'N': Q * C C * Q @@ -79741,9 +79743,9 @@ module stdlib_linalg_lapack_w integer(ilp), intent(in) :: ihi, ilo, lda, ldc, lwork, m, n integer(ilp), intent(out) :: info ! Array Arguments - complex(qp), intent(inout) :: a(lda,*), c(ldc,*) - complex(qp), intent(in) :: tau(*) - complex(qp), intent(out) :: work(*) + complex(${ck}$), intent(inout) :: a(lda,*), c(ldc,*) + complex(${ck}$), intent(in) :: tau(*) + complex(${ck}$), intent(out) :: work(*) ! ===================================================================== ! Local Scalars logical(lk) :: left, lquery @@ -79815,14 +79817,14 @@ module stdlib_linalg_lapack_w i1 = 1 i2 = ilo + 1 end if - call stdlib_wunmqr( side, trans, mi, ni, nh, a( ilo+1, ilo ), lda,tau( ilo ), c( i1, & + call stdlib_${ci}$unmqr( side, trans, mi, ni, nh, a( ilo+1, ilo ), lda,tau( ilo ), c( i1, & i2 ), ldc, work, lwork, iinfo ) work( 1 ) = lwkopt return - end subroutine stdlib_wunmhr + end subroutine stdlib_${ci}$unmhr - pure subroutine stdlib_wunml2( side, trans, m, n, k, a, lda, tau, c, ldc,work, info ) + pure subroutine stdlib_${ci}$unml2( side, trans, m, n, k, a, lda, tau, c, ldc,work, info ) !! ZUNML2: overwrites the general complex m-by-n matrix C with !! Q * C if SIDE = 'L' and TRANS = 'N', or !! Q**H* C if SIDE = 'L' and TRANS = 'C', or @@ -79841,15 +79843,15 @@ module stdlib_linalg_lapack_w integer(ilp), intent(out) :: info integer(ilp), intent(in) :: k, lda, ldc, m, n ! Array Arguments - complex(qp), intent(inout) :: a(lda,*), c(ldc,*) - complex(qp), intent(in) :: tau(*) - complex(qp), intent(out) :: work(*) + complex(${ck}$), intent(inout) :: a(lda,*), c(ldc,*) + complex(${ck}$), intent(in) :: tau(*) + complex(${ck}$), intent(out) :: work(*) ! ===================================================================== ! Local Scalars logical(lk) :: left, notran integer(ilp) :: i, i1, i2, i3, ic, jc, mi, ni, nq - complex(qp) :: aii, taui + complex(${ck}$) :: aii, taui ! Intrinsic Functions intrinsic :: conjg,max ! Executable Statements @@ -79916,19 +79918,19 @@ module stdlib_linalg_lapack_w else taui = tau( i ) end if - if( i=k ) then ! use unblocked code - call stdlib_wunml2( side, trans, m, n, k, a, lda, tau, c, ldc, work,iinfo ) + call stdlib_${ci}$unml2( side, trans, m, n, k, a, lda, tau, c, ldc, work,iinfo ) else ! use blocked code iwt = 1 + nw*nb @@ -80050,7 +80052,7 @@ module stdlib_linalg_lapack_w ib = min( nb, k-i+1 ) ! form the triangular factor of the block reflector ! h = h(i) h(i+1) . . . h(i+ib-1) - call stdlib_wlarft( 'FORWARD', 'ROWWISE', nq-i+1, ib, a( i, i ),lda, tau( i ), & + call stdlib_${ci}$larft( 'FORWARD', 'ROWWISE', nq-i+1, ib, a( i, i ),lda, tau( i ), & work( iwt ), ldt ) if( left ) then ! h or h**h is applied to c(i:m,1:n) @@ -80062,16 +80064,16 @@ module stdlib_linalg_lapack_w jc = i end if ! apply h or h**h - call stdlib_wlarfb( side, transt, 'FORWARD', 'ROWWISE', mi, ni, ib,a( i, i ), & + call stdlib_${ci}$larfb( side, transt, 'FORWARD', 'ROWWISE', mi, ni, ib,a( i, i ), & lda, work( iwt ), ldt,c( ic, jc ), ldc, work, ldwork ) end do end if work( 1 ) = lwkopt return - end subroutine stdlib_wunmlq + end subroutine stdlib_${ci}$unmlq - pure subroutine stdlib_wunmql( side, trans, m, n, k, a, lda, tau, c, ldc,work, lwork, info ) + pure subroutine stdlib_${ci}$unmql( side, trans, m, n, k, a, lda, tau, c, ldc,work, lwork, info ) !! ZUNMQL: overwrites the general complex M-by-N matrix C with !! SIDE = 'L' SIDE = 'R' !! TRANS = 'N': Q * C C * Q @@ -80090,9 +80092,9 @@ module stdlib_linalg_lapack_w integer(ilp), intent(out) :: info integer(ilp), intent(in) :: k, lda, ldc, lwork, m, n ! Array Arguments - complex(qp), intent(inout) :: a(lda,*), c(ldc,*) - complex(qp), intent(in) :: tau(*) - complex(qp), intent(out) :: work(*) + complex(${ck}$), intent(inout) :: a(lda,*), c(ldc,*) + complex(${ck}$), intent(in) :: tau(*) + complex(${ck}$), intent(out) :: work(*) ! ===================================================================== ! Parameters integer(ilp), parameter :: nbmax = 64 @@ -80167,7 +80169,7 @@ module stdlib_linalg_lapack_w end if if( nb=k ) then ! use unblocked code - call stdlib_wunm2l( side, trans, m, n, k, a, lda, tau, c, ldc, work,iinfo ) + call stdlib_${ci}$unm2l( side, trans, m, n, k, a, lda, tau, c, ldc, work,iinfo ) else ! use blocked code iwt = 1 + nw*nb @@ -80189,7 +80191,7 @@ module stdlib_linalg_lapack_w ib = min( nb, k-i+1 ) ! form the triangular factor of the block reflector ! h = h(i+ib-1) . . . h(i+1) h(i) - call stdlib_wlarft( 'BACKWARD', 'COLUMNWISE', nq-k+i+ib-1, ib,a( 1, i ), lda, & + call stdlib_${ci}$larft( 'BACKWARD', 'COLUMNWISE', nq-k+i+ib-1, ib,a( 1, i ), lda, & tau( i ), work( iwt ), ldt ) if( left ) then ! h or h**h is applied to c(1:m-k+i+ib-1,1:n) @@ -80199,16 +80201,16 @@ module stdlib_linalg_lapack_w ni = n - k + i + ib - 1 end if ! apply h or h**h - call stdlib_wlarfb( side, trans, 'BACKWARD', 'COLUMNWISE', mi, ni,ib, a( 1, i ), & + call stdlib_${ci}$larfb( side, trans, 'BACKWARD', 'COLUMNWISE', mi, ni,ib, a( 1, i ), & lda, work( iwt ), ldt, c, ldc,work, ldwork ) end do end if work( 1 ) = lwkopt return - end subroutine stdlib_wunmql + end subroutine stdlib_${ci}$unmql - pure subroutine stdlib_wunmqr( side, trans, m, n, k, a, lda, tau, c, ldc,work, lwork, info ) + pure subroutine stdlib_${ci}$unmqr( side, trans, m, n, k, a, lda, tau, c, ldc,work, lwork, info ) !! ZUNMQR: overwrites the general complex M-by-N matrix C with !! SIDE = 'L' SIDE = 'R' !! TRANS = 'N': Q * C C * Q @@ -80227,9 +80229,9 @@ module stdlib_linalg_lapack_w integer(ilp), intent(out) :: info integer(ilp), intent(in) :: k, lda, ldc, lwork, m, n ! Array Arguments - complex(qp), intent(inout) :: a(lda,*), c(ldc,*) - complex(qp), intent(in) :: tau(*) - complex(qp), intent(out) :: work(*) + complex(${ck}$), intent(inout) :: a(lda,*), c(ldc,*) + complex(${ck}$), intent(in) :: tau(*) + complex(${ck}$), intent(out) :: work(*) ! ===================================================================== ! Parameters integer(ilp), parameter :: nbmax = 64 @@ -80300,7 +80302,7 @@ module stdlib_linalg_lapack_w end if if( nb=k ) then ! use unblocked code - call stdlib_wunm2r( side, trans, m, n, k, a, lda, tau, c, ldc, work,iinfo ) + call stdlib_${ci}$unm2r( side, trans, m, n, k, a, lda, tau, c, ldc, work,iinfo ) else ! use blocked code iwt = 1 + nw*nb @@ -80324,7 +80326,7 @@ module stdlib_linalg_lapack_w ib = min( nb, k-i+1 ) ! form the triangular factor of the block reflector ! h = h(i) h(i+1) . . . h(i+ib-1) - call stdlib_wlarft( 'FORWARD', 'COLUMNWISE', nq-i+1, ib, a( i, i ),lda, tau( i ),& + call stdlib_${ci}$larft( 'FORWARD', 'COLUMNWISE', nq-i+1, ib, a( i, i ),lda, tau( i ),& work( iwt ), ldt ) if( left ) then ! h or h**h is applied to c(i:m,1:n) @@ -80336,16 +80338,16 @@ module stdlib_linalg_lapack_w jc = i end if ! apply h or h**h - call stdlib_wlarfb( side, trans, 'FORWARD', 'COLUMNWISE', mi, ni,ib, a( i, i ), & + call stdlib_${ci}$larfb( side, trans, 'FORWARD', 'COLUMNWISE', mi, ni,ib, a( i, i ), & lda, work( iwt ), ldt,c( ic, jc ), ldc, work, ldwork ) end do end if work( 1 ) = lwkopt return - end subroutine stdlib_wunmqr + end subroutine stdlib_${ci}$unmqr - pure subroutine stdlib_wunmr2( side, trans, m, n, k, a, lda, tau, c, ldc,work, info ) + pure subroutine stdlib_${ci}$unmr2( side, trans, m, n, k, a, lda, tau, c, ldc,work, info ) !! ZUNMR2: overwrites the general complex m-by-n matrix C with !! Q * C if SIDE = 'L' and TRANS = 'N', or !! Q**H* C if SIDE = 'L' and TRANS = 'C', or @@ -80364,15 +80366,15 @@ module stdlib_linalg_lapack_w integer(ilp), intent(out) :: info integer(ilp), intent(in) :: k, lda, ldc, m, n ! Array Arguments - complex(qp), intent(inout) :: a(lda,*), c(ldc,*) - complex(qp), intent(in) :: tau(*) - complex(qp), intent(out) :: work(*) + complex(${ck}$), intent(inout) :: a(lda,*), c(ldc,*) + complex(${ck}$), intent(in) :: tau(*) + complex(${ck}$), intent(out) :: work(*) ! ===================================================================== ! Local Scalars logical(lk) :: left, notran integer(ilp) :: i, i1, i2, i3, mi, ni, nq - complex(qp) :: aii, taui + complex(${ck}$) :: aii, taui ! Intrinsic Functions intrinsic :: conjg,max ! Executable Statements @@ -80435,18 +80437,18 @@ module stdlib_linalg_lapack_w else taui = tau( i ) end if - call stdlib_wlacgv( nq-k+i-1, a( i, 1 ), lda ) + call stdlib_${ci}$lacgv( nq-k+i-1, a( i, 1 ), lda ) aii = a( i, nq-k+i ) a( i, nq-k+i ) = cone - call stdlib_wlarf( side, mi, ni, a( i, 1 ), lda, taui, c, ldc, work ) + call stdlib_${ci}$larf( side, mi, ni, a( i, 1 ), lda, taui, c, ldc, work ) a( i, nq-k+i ) = aii - call stdlib_wlacgv( nq-k+i-1, a( i, 1 ), lda ) + call stdlib_${ci}$lacgv( nq-k+i-1, a( i, 1 ), lda ) end do return - end subroutine stdlib_wunmr2 + end subroutine stdlib_${ci}$unmr2 - pure subroutine stdlib_wunmr3( side, trans, m, n, k, l, a, lda, tau, c, ldc,work, info ) + pure subroutine stdlib_${ci}$unmr3( side, trans, m, n, k, l, a, lda, tau, c, ldc,work, info ) !! ZUNMR3: overwrites the general complex m by n matrix C with !! Q * C if SIDE = 'L' and TRANS = 'N', or !! Q**H* C if SIDE = 'L' and TRANS = 'C', or @@ -80466,14 +80468,14 @@ module stdlib_linalg_lapack_w integer(ilp), intent(out) :: info integer(ilp), intent(in) :: k, l, lda, ldc, m, n ! Array Arguments - complex(qp), intent(in) :: a(lda,*), tau(*) - complex(qp), intent(inout) :: c(ldc,*) - complex(qp), intent(out) :: work(*) + complex(${ck}$), intent(in) :: a(lda,*), tau(*) + complex(${ck}$), intent(inout) :: c(ldc,*) + complex(${ck}$), intent(out) :: work(*) ! ===================================================================== ! Local Scalars logical(lk) :: left, notran integer(ilp) :: i, i1, i2, i3, ic, ja, jc, mi, ni, nq - complex(qp) :: taui + complex(${ck}$) :: taui ! Intrinsic Functions intrinsic :: conjg,max ! Executable Statements @@ -80544,14 +80546,14 @@ module stdlib_linalg_lapack_w else taui = conjg( tau( i ) ) end if - call stdlib_wlarz( side, mi, ni, l, a( i, ja ), lda, taui,c( ic, jc ), ldc, work ) + call stdlib_${ci}$larz( side, mi, ni, l, a( i, ja ), lda, taui,c( ic, jc ), ldc, work ) end do return - end subroutine stdlib_wunmr3 + end subroutine stdlib_${ci}$unmr3 - pure subroutine stdlib_wunmrq( side, trans, m, n, k, a, lda, tau, c, ldc,work, lwork, info ) + pure subroutine stdlib_${ci}$unmrq( side, trans, m, n, k, a, lda, tau, c, ldc,work, lwork, info ) !! ZUNMRQ: overwrites the general complex M-by-N matrix C with !! SIDE = 'L' SIDE = 'R' !! TRANS = 'N': Q * C C * Q @@ -80570,9 +80572,9 @@ module stdlib_linalg_lapack_w integer(ilp), intent(out) :: info integer(ilp), intent(in) :: k, lda, ldc, lwork, m, n ! Array Arguments - complex(qp), intent(inout) :: a(lda,*), c(ldc,*) - complex(qp), intent(in) :: tau(*) - complex(qp), intent(out) :: work(*) + complex(${ck}$), intent(inout) :: a(lda,*), c(ldc,*) + complex(${ck}$), intent(in) :: tau(*) + complex(${ck}$), intent(out) :: work(*) ! ===================================================================== ! Parameters integer(ilp), parameter :: nbmax = 64 @@ -80648,7 +80650,7 @@ module stdlib_linalg_lapack_w end if if( nb=k ) then ! use unblocked code - call stdlib_wunmr2( side, trans, m, n, k, a, lda, tau, c, ldc, work,iinfo ) + call stdlib_${ci}$unmr2( side, trans, m, n, k, a, lda, tau, c, ldc, work,iinfo ) else ! use blocked code iwt = 1 + nw*nb @@ -80675,7 +80677,7 @@ module stdlib_linalg_lapack_w ib = min( nb, k-i+1 ) ! form the triangular factor of the block reflector ! h = h(i+ib-1) . . . h(i+1) h(i) - call stdlib_wlarft( 'BACKWARD', 'ROWWISE', nq-k+i+ib-1, ib,a( i, 1 ), lda, tau( & + call stdlib_${ci}$larft( 'BACKWARD', 'ROWWISE', nq-k+i+ib-1, ib,a( i, 1 ), lda, tau( & i ), work( iwt ), ldt ) if( left ) then ! h or h**h is applied to c(1:m-k+i+ib-1,1:n) @@ -80685,16 +80687,16 @@ module stdlib_linalg_lapack_w ni = n - k + i + ib - 1 end if ! apply h or h**h - call stdlib_wlarfb( side, transt, 'BACKWARD', 'ROWWISE', mi, ni,ib, a( i, 1 ), & + call stdlib_${ci}$larfb( side, transt, 'BACKWARD', 'ROWWISE', mi, ni,ib, a( i, 1 ), & lda, work( iwt ), ldt, c, ldc,work, ldwork ) end do end if work( 1 ) = lwkopt return - end subroutine stdlib_wunmrq + end subroutine stdlib_${ci}$unmrq - pure subroutine stdlib_wunmrz( side, trans, m, n, k, l, a, lda, tau, c, ldc,work, lwork, & + pure subroutine stdlib_${ci}$unmrz( side, trans, m, n, k, l, a, lda, tau, c, ldc,work, lwork, & !! ZUNMRZ: overwrites the general complex M-by-N matrix C with !! SIDE = 'L' SIDE = 'R' !! TRANS = 'N': Q * C C * Q @@ -80713,9 +80715,9 @@ module stdlib_linalg_lapack_w integer(ilp), intent(out) :: info integer(ilp), intent(in) :: k, l, lda, ldc, lwork, m, n ! Array Arguments - complex(qp), intent(inout) :: a(lda,*), c(ldc,*) - complex(qp), intent(in) :: tau(*) - complex(qp), intent(out) :: work(*) + complex(${ck}$), intent(inout) :: a(lda,*), c(ldc,*) + complex(${ck}$), intent(in) :: tau(*) + complex(${ck}$), intent(out) :: work(*) ! ===================================================================== ! Parameters integer(ilp), parameter :: nbmax = 64 @@ -80796,7 +80798,7 @@ module stdlib_linalg_lapack_w end if if( nb=k ) then ! use unblocked code - call stdlib_wunmr3( side, trans, m, n, k, l, a, lda, tau, c, ldc,work, iinfo ) + call stdlib_${ci}$unmr3( side, trans, m, n, k, l, a, lda, tau, c, ldc,work, iinfo ) else ! use blocked code @@ -80828,7 +80830,7 @@ module stdlib_linalg_lapack_w ib = min( nb, k-i+1 ) ! form the triangular factor of the block reflector ! h = h(i+ib-1) . . . h(i+1) h(i) - call stdlib_wlarzt( 'BACKWARD', 'ROWWISE', l, ib, a( i, ja ), lda,tau( i ), work(& + call stdlib_${ci}$larzt( 'BACKWARD', 'ROWWISE', l, ib, a( i, ja ), lda,tau( i ), work(& iwt ), ldt ) if( left ) then ! h or h**h is applied to c(i:m,1:n) @@ -80840,16 +80842,16 @@ module stdlib_linalg_lapack_w jc = i end if ! apply h or h**h - call stdlib_wlarzb( side, transt, 'BACKWARD', 'ROWWISE', mi, ni,ib, l, a( i, ja )& + call stdlib_${ci}$larzb( side, transt, 'BACKWARD', 'ROWWISE', mi, ni,ib, l, a( i, ja )& , lda, work( iwt ), ldt,c( ic, jc ), ldc, work, ldwork ) end do end if work( 1 ) = lwkopt return - end subroutine stdlib_wunmrz + end subroutine stdlib_${ci}$unmrz - pure subroutine stdlib_wunmtr( side, uplo, trans, m, n, a, lda, tau, c, ldc,work, lwork, & + pure subroutine stdlib_${ci}$unmtr( side, uplo, trans, m, n, a, lda, tau, c, ldc,work, lwork, & !! ZUNMTR: overwrites the general complex M-by-N matrix C with !! SIDE = 'L' SIDE = 'R' !! TRANS = 'N': Q * C C * Q @@ -80868,9 +80870,9 @@ module stdlib_linalg_lapack_w integer(ilp), intent(out) :: info integer(ilp), intent(in) :: lda, ldc, lwork, m, n ! Array Arguments - complex(qp), intent(inout) :: a(lda,*), c(ldc,*) - complex(qp), intent(in) :: tau(*) - complex(qp), intent(out) :: work(*) + complex(${ck}$), intent(inout) :: a(lda,*), c(ldc,*) + complex(${ck}$), intent(in) :: tau(*) + complex(${ck}$), intent(out) :: work(*) ! ===================================================================== ! Local Scalars logical(lk) :: left, lquery, upper @@ -80945,11 +80947,11 @@ module stdlib_linalg_lapack_w ni = n - 1 end if if( upper ) then - ! q was determined by a call to stdlib_whetrd with uplo = 'u' - call stdlib_wunmql( side, trans, mi, ni, nq-1, a( 1, 2 ), lda, tau, c,ldc, work, & + ! q was determined by a call to stdlib_${ci}$hetrd with uplo = 'u' + call stdlib_${ci}$unmql( side, trans, mi, ni, nq-1, a( 1, 2 ), lda, tau, c,ldc, work, & lwork, iinfo ) else - ! q was determined by a call to stdlib_whetrd with uplo = 'l' + ! q was determined by a call to stdlib_${ci}$hetrd with uplo = 'l' if( left ) then i1 = 2 i2 = 1 @@ -80957,15 +80959,15 @@ module stdlib_linalg_lapack_w i1 = 1 i2 = 2 end if - call stdlib_wunmqr( side, trans, mi, ni, nq-1, a( 2, 1 ), lda, tau,c( i1, i2 ), ldc,& + call stdlib_${ci}$unmqr( side, trans, mi, ni, nq-1, a( 2, 1 ), lda, tau,c( i1, i2 ), ldc,& work, lwork, iinfo ) end if work( 1 ) = lwkopt return - end subroutine stdlib_wunmtr + end subroutine stdlib_${ci}$unmtr - pure subroutine stdlib_wupgtr( uplo, n, ap, tau, q, ldq, work, info ) + pure subroutine stdlib_${ci}$upgtr( uplo, n, ap, tau, q, ldq, work, info ) !! ZUPGTR: generates a complex unitary matrix Q which is defined as the !! product of n-1 elementary reflectors H(i) of order n, as returned by !! ZHPTRD using packed storage: @@ -80979,8 +80981,8 @@ module stdlib_linalg_lapack_w integer(ilp), intent(out) :: info integer(ilp), intent(in) :: ldq, n ! Array Arguments - complex(qp), intent(in) :: ap(*), tau(*) - complex(qp), intent(out) :: q(ldq,*), work(*) + complex(${ck}$), intent(in) :: ap(*), tau(*) + complex(${ck}$), intent(out) :: q(ldq,*), work(*) ! ===================================================================== ! Local Scalars @@ -81006,7 +81008,7 @@ module stdlib_linalg_lapack_w ! quick return if possible if( n==0 )return if( upper ) then - ! q was determined by a call to stdlib_whptrd with uplo = 'u' + ! q was determined by a call to stdlib_${ci}$hptrd with uplo = 'u' ! unpack the vectors which define the elementary reflectors and ! set the last row and column of q equal to those of the unit ! matrix @@ -81024,9 +81026,9 @@ module stdlib_linalg_lapack_w end do q( n, n ) = cone ! generate q(1:n-1,1:n-1) - call stdlib_wung2l( n-1, n-1, n-1, q, ldq, tau, work, iinfo ) + call stdlib_${ci}$ung2l( n-1, n-1, n-1, q, ldq, tau, work, iinfo ) else - ! q was determined by a call to stdlib_whptrd with uplo = 'l'. + ! q was determined by a call to stdlib_${ci}$hptrd with uplo = 'l'. ! unpack the vectors which define the elementary reflectors and ! set the first row and column of q equal to those of the unit ! matrix @@ -81045,14 +81047,14 @@ module stdlib_linalg_lapack_w end do if( n>1 ) then ! generate q(2:n,2:n) - call stdlib_wung2r( n-1, n-1, n-1, q( 2, 2 ), ldq, tau, work,iinfo ) + call stdlib_${ci}$ung2r( n-1, n-1, n-1, q( 2, 2 ), ldq, tau, work,iinfo ) end if end if return - end subroutine stdlib_wupgtr + end subroutine stdlib_${ci}$upgtr - pure subroutine stdlib_wupmtr( side, uplo, trans, m, n, ap, tau, c, ldc, work,info ) + pure subroutine stdlib_${ci}$upmtr( side, uplo, trans, m, n, ap, tau, c, ldc, work,info ) !! ZUPMTR: overwrites the general complex M-by-N matrix C with !! SIDE = 'L' SIDE = 'R' !! TRANS = 'N': Q * C C * Q @@ -81071,15 +81073,15 @@ module stdlib_linalg_lapack_w integer(ilp), intent(out) :: info integer(ilp), intent(in) :: ldc, m, n ! Array Arguments - complex(qp), intent(inout) :: ap(*), c(ldc,*) - complex(qp), intent(in) :: tau(*) - complex(qp), intent(out) :: work(*) + complex(${ck}$), intent(inout) :: ap(*), c(ldc,*) + complex(${ck}$), intent(in) :: tau(*) + complex(${ck}$), intent(out) :: work(*) ! ===================================================================== ! Local Scalars logical(lk) :: forwrd, left, notran, upper integer(ilp) :: i, i1, i2, i3, ic, ii, jc, mi, ni, nq - complex(qp) :: aii, taui + complex(${ck}$) :: aii, taui ! Intrinsic Functions intrinsic :: conjg,max ! Executable Statements @@ -81114,7 +81116,7 @@ module stdlib_linalg_lapack_w ! quick return if possible if( m==0 .or. n==0 )return if( upper ) then - ! q was determined by a call to stdlib_whptrd with uplo = 'u' + ! q was determined by a call to stdlib_${ci}$hptrd with uplo = 'u' forwrd = ( left .and. notran ) .or.( .not.left .and. .not.notran ) if( forwrd ) then i1 = 1 @@ -81148,7 +81150,7 @@ module stdlib_linalg_lapack_w end if aii = ap( ii ) ap( ii ) = cone - call stdlib_wlarf( side, mi, ni, ap( ii-i+1 ), 1, taui, c, ldc,work ) + call stdlib_${ci}$larf( side, mi, ni, ap( ii-i+1 ), 1, taui, c, ldc,work ) ap( ii ) = aii if( forwrd ) then ii = ii + i + 2 @@ -81157,7 +81159,7 @@ module stdlib_linalg_lapack_w end if end do else - ! q was determined by a call to stdlib_whptrd with uplo = 'l'. + ! q was determined by a call to stdlib_${ci}$hptrd with uplo = 'l'. forwrd = ( left .and. .not.notran ) .or.( .not.left .and. notran ) if( forwrd ) then i1 = 1 @@ -81195,7 +81197,7 @@ module stdlib_linalg_lapack_w else taui = conjg( tau( i ) ) end if - call stdlib_wlarf( side, mi, ni, ap( ii ), 1, taui, c( ic, jc ),ldc, work ) + call stdlib_${ci}$larf( side, mi, ni, ap( ii ), 1, taui, c( ic, jc ),ldc, work ) ap( ii ) = aii if( forwrd ) then @@ -81206,9 +81208,11 @@ module stdlib_linalg_lapack_w end do loop_20 end if return - end subroutine stdlib_wupmtr + end subroutine stdlib_${ci}$upmtr -end module stdlib_linalg_lapack_w +end module stdlib_linalg_lapack_${ci}$ + #:endif +#:endfor diff --git a/src/stdlib_linalg_least_squares.fypp b/src/stdlib_linalg_least_squares.fypp index ccb885319..eaf5cfd1b 100644 --- a/src/stdlib_linalg_least_squares.fypp +++ b/src/stdlib_linalg_least_squares.fypp @@ -36,7 +36,6 @@ submodule (stdlib_linalg) stdlib_linalg_least_squares end subroutine handle_gelsd_info #:for rk,rt,ri in RC_KINDS_TYPES - #:if rk!="xdp" ! Workspace needed by gelsd elemental subroutine ${ri}$gelsd_space(m,n,nrhs,lrwork,liwork,lcwork) integer(ilp), intent(in) :: m,n,nrhs @@ -74,12 +73,10 @@ submodule (stdlib_linalg) stdlib_linalg_least_squares end subroutine ${ri}$gelsd_space - #:endif #:endfor #:for nd,ndsuf,nde in ALL_RHS #:for rk,rt,ri in RC_KINDS_TYPES - #:if rk!="xdp" ! Compute the integer, real, [complex] working space requested byu the least squares procedure pure module subroutine stdlib_linalg_${ri}$_lstsq_space_${ndsuf}$(a,b,lrwork,liwork#{if rt.startswith('c')}#,lcwork#{endif}#) @@ -357,7 +354,6 @@ submodule (stdlib_linalg) stdlib_linalg_least_squares end subroutine stdlib_linalg_${ri}$_solve_lstsq_${ndsuf}$ - #:endif #:endfor #:endfor diff --git a/src/stdlib_linalg_solve.fypp b/src/stdlib_linalg_solve.fypp index 8612d5052..7c266b9b8 100644 --- a/src/stdlib_linalg_solve.fypp +++ b/src/stdlib_linalg_solve.fypp @@ -42,7 +42,6 @@ submodule (stdlib_linalg) stdlib_linalg_solve #:for nd,ndsuf,nde in ALL_RHS #:for rk,rt,ri in RC_KINDS_TYPES - #:if rk!="xdp" ! Compute the solution to a real system of linear equations A * X = B module function stdlib_linalg_${ri}$_solve_${ndsuf}$(a,b,overwrite_a,err) result(x) !> Input matrix a[n,n] @@ -163,7 +162,6 @@ submodule (stdlib_linalg) stdlib_linalg_solve end subroutine stdlib_linalg_${ri}$_solve_lu_${ndsuf}$ - #:endif #:endfor #:endfor diff --git a/src/stdlib_linalg_svd.fypp b/src/stdlib_linalg_svd.fypp index b93343c15..8910bd3ce 100644 --- a/src/stdlib_linalg_svd.fypp +++ b/src/stdlib_linalg_svd.fypp @@ -59,7 +59,6 @@ submodule(stdlib_linalg) stdlib_linalg_svd #:for rk,rt,ri in RC_KINDS_TYPES - #:if rk!="xdp" !> Singular values of matrix A module function stdlib_linalg_svdvals_${ri}$(a,err) result(s) @@ -287,7 +286,6 @@ submodule(stdlib_linalg) stdlib_linalg_svd call linalg_error_handling(err0,err) end subroutine stdlib_linalg_svd_${ri}$ - #:endif #:endfor end submodule stdlib_linalg_svd diff --git a/test/linalg/test_blas_lapack.fypp b/test/linalg/test_blas_lapack.fypp index e36ac2717..4df7f4736 100644 --- a/test/linalg/test_blas_lapack.fypp +++ b/test/linalg/test_blas_lapack.fypp @@ -10,13 +10,6 @@ module test_blas_lapack implicit none - real(sp), parameter :: sptol = 1000 * epsilon(1._sp) - real(dp), parameter :: dptol = 1000 * epsilon(1._dp) -#:if WITH_QP - real(qp), parameter :: qptol = 1000 * epsilon(1._qp) -#:endif - - contains @@ -41,10 +34,8 @@ contains !> Error handling type(error_type), allocatable, intent(out) :: error -#:if k1=="xdp" - call skip_test(error, "Extended precision is not enabled") -#:else ${t1}$ :: A(3,3),x(3),y(3),ylap(3),yintr(3),alpha,beta + real(${k1}$), parameter :: tol = 1000 * epsilon(1.0_${k1}$) call random_number(alpha) call random_number(beta) call random_number(A) @@ -54,10 +45,10 @@ contains call gemv('No transpose',size(A,1),size(A,2),alpha,A,size(A,1),x,1,beta,ylap,1) yintr = alpha*matmul(A,x)+beta*y - call check(error, sum(abs(ylap - yintr)) < sptol, & - "blas vs. intrinsics axpy: sum() < sptol failed") + call check(error, sum(abs(ylap - yintr)) < tol, & + "blas vs. intrinsics axpy: sum() < tol failed") if (allocated(error)) return -#:endif + end subroutine test_gemv${t1[0]}$${k1}$ ! Find matrix inverse from LU decomposition @@ -65,15 +56,11 @@ contains !> Error handling type(error_type), allocatable, intent(out) :: error -#:if k1=="xdp" - call skip_test(error, "Extended precision is not enabled") -#:else - integer(ilp), parameter :: n = 3 ${t1}$ :: A(n,n) ${t1}$,allocatable :: work(:) integer(ilp) :: ipiv(n),info,lwork,nb - + real(${k1}$), parameter :: tol = 1000 * epsilon(1.0_${k1}$) A = eye(n) @@ -93,10 +80,10 @@ contains call check(error, info==0, "lapack getri returned info/=0") if (allocated(error)) return - call check(error, sum(abs(A - eye(3))) < sptol, & + call check(error, sum(abs(A - eye(3))) < tol, & "lapack eye inversion: tolerance check failed") if (allocated(error)) return -#:endif + end subroutine test_getri${t1[0]}$${k1}$ #:endfor diff --git a/test/linalg/test_linalg_lstsq.fypp b/test/linalg/test_linalg_lstsq.fypp index 045ac843d..c8766da04 100644 --- a/test/linalg/test_linalg_lstsq.fypp +++ b/test/linalg/test_linalg_lstsq.fypp @@ -24,16 +24,13 @@ module test_linalg_least_squares tests = [tests,new_unittest("issue_823",test_issue_823)] #:for rk,rt,ri in REAL_KINDS_TYPES - #:if rk!="xdp" tests = [tests,new_unittest("least_squares_${ri}$",test_lstsq_one_${ri}$), & new_unittest("least_squares_randm_${ri}$",test_lstsq_random_${ri}$)] - #:endif #:endfor end subroutine test_least_squares #:for rk,rt,ri in REAL_KINDS_TYPES - #:if rk!="xdp" !> Simple polynomial fit subroutine test_lstsq_one_${ri}$(error) type(error_type), allocatable, intent(out) :: error @@ -100,7 +97,6 @@ module test_linalg_least_squares end subroutine test_lstsq_random_${ri}$ - #:endif #:endfor ! Test issue #823 diff --git a/test/linalg/test_linalg_solve.fypp b/test/linalg/test_linalg_solve.fypp index 25234a40b..957c8b0d6 100644 --- a/test/linalg/test_linalg_solve.fypp +++ b/test/linalg/test_linalg_solve.fypp @@ -22,23 +22,18 @@ module test_linalg_solve allocate(tests(0)) #:for rk,rt,ri in REAL_KINDS_TYPES - #:if rk!="xdp" tests = [tests,new_unittest("solve_${ri}$",test_${ri}$_solve), & new_unittest("solve_${ri}$_multiple",test_${ri}$_solve_multiple)] - #:endif #:endfor #:for ck,ct,ci in CMPLX_KINDS_TYPES - #:if ck!="xdp" tests = [tests,new_unittest("solve_complex_${ci}$",test_${ci}$_solve), & new_unittest("solve_2x2_complex_${ci}$",test_2x2_${ci}$_solve)] - #:endif #:endfor end subroutine test_linear_systems #:for rk,rt,ri in REAL_KINDS_TYPES - #:if rk!="xdp" !> Simple linear system subroutine test_${ri}$_solve(error) type(error_type), allocatable, intent(out) :: error @@ -88,11 +83,9 @@ module test_linalg_solve if (allocated(error)) return end subroutine test_${ri}$_solve_multiple - #:endif #:endfor #:for rk,rt,ri in CMPLX_KINDS_TYPES - #:if rk!="xdp" !> Complex linear system !> Militaru, Popa, "On the numerical solving of complex linear systems", !> Int J Pure Appl Math 76(1), 113-122, 2012. @@ -157,7 +150,6 @@ module test_linalg_solve end subroutine test_2x2_${ri}$_solve - #:endif #:endfor end module test_linalg_solve diff --git a/test/linalg/test_linalg_svd.fypp b/test/linalg/test_linalg_svd.fypp index d5a01d123..03886ab69 100644 --- a/test/linalg/test_linalg_svd.fypp +++ b/test/linalg/test_linalg_svd.fypp @@ -20,28 +20,21 @@ module test_linalg_svd allocate(tests(0)) #:for rk,rt,ri in REAL_KINDS_TYPES - #:if rk!="xdp" tests = [tests,new_unittest("test_svd_${ri}$",test_svd_${ri}$)] - #:endif #:endfor #:for ck,ct,ci in CMPLX_KINDS_TYPES - #:if ck!="xdp" tests = [tests,new_unittest("test_complex_svd_${ci}$",test_complex_svd_${ci}$)] - #:endif #:endfor #:for rk,rt,ri in RC_KINDS_TYPES - #:if rk!="xdp" tests = [tests,new_unittest("test_svd_row_${ri}$",test_svd_row_${ri}$)] - #:endif #:endfor end subroutine test_svd !> Real matrix svd #:for rk,rt,ri in REAL_KINDS_TYPES - #:if rk!="xdp" subroutine test_svd_${ri}$(error) type(error_type), allocatable, intent(out) :: error @@ -176,12 +169,10 @@ module test_linalg_svd end subroutine test_svd_${ri}$ - #:endif #:endfor !> Test complex svd #:for ck,ct,ci in CMPLX_KINDS_TYPES - #:if ck!="xdp" subroutine test_complex_svd_${ci}$(error) type(error_type), allocatable, intent(out) :: error @@ -243,12 +234,10 @@ module test_linalg_svd end subroutine test_complex_svd_${ci}$ - #:endif #:endfor #:for rk,rt,ri in RC_KINDS_TYPES - #:if rk!="xdp" ! Issue #835: bounds checking triggers an error with 1-sized A matrix subroutine test_svd_row_${ri}$(error) type(error_type), allocatable, intent(out) :: error @@ -273,7 +262,6 @@ module test_linalg_svd end subroutine test_svd_row_${ri}$ - #:endif #:endfor