From c3a8177ecfbd9de3716bff766649f49e49122edc Mon Sep 17 00:00:00 2001 From: Federico Perini Date: Wed, 13 Nov 2024 17:16:35 +0100 Subject: [PATCH 01/31] add `ilp64` parameter --- src/stdlib_linalg_constants.fypp | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/src/stdlib_linalg_constants.fypp b/src/stdlib_linalg_constants.fypp index 4f9d565b6..ff8dad44c 100644 --- a/src/stdlib_linalg_constants.fypp +++ b/src/stdlib_linalg_constants.fypp @@ -7,8 +7,9 @@ module stdlib_linalg_constants public - ! Integer size support for ILP64 builds should be done here - integer, parameter :: ilp = int32 + ! Support both 32-bit (ilp) and 64-bit (ilp64) integer kinds + integer, parameter :: ilp = int32 + integer, parameter :: ilp64 = int64 private :: int32, int64 end module stdlib_linalg_constants From 65b1ec621fc86b670b3ad0a30379b7a20afbf5e9 Mon Sep 17 00:00:00 2001 From: Federico Perini Date: Wed, 13 Nov 2024 18:02:39 +0100 Subject: [PATCH 02/31] fypp: template `linalg` integer sizes --- include/common.fypp | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/include/common.fypp b/include/common.fypp index 451eebc8a..8d0837e28 100644 --- a/include/common.fypp +++ b/include/common.fypp @@ -74,6 +74,11 @@ $:"s" if cmplx=="c" else "d" if cmplx=="z" else "x" if cmplx=="y" else "q" if cmplx=="w" else "ERROR" #:enddef +#! BLAS/LAPACK/Linear Algebra Integer Kinds +#:set LINALG_INT_KINDS = ["ilp","ilp64"] +#:set LINALG_INT_TYPES = ["integer({})".format(k) for k in LINALG_INT_KINDS] +#:set LINALG_INT_KINDS_TYPES = list(zip(LINALG_INT_KINDS, LINALG_INT_TYPES)) + #! Complex types to be considered during templating #:set CMPLX_TYPES = ["complex({})".format(k) for k in CMPLX_KINDS] #:set CMPLX_SUFFIX = ["c{}".format(k) for k in CMPLX_KINDS] From 1af9ea91139a79cd4ab5d53c8db2ac48eb20ed03 Mon Sep 17 00:00:00 2001 From: Federico Perini Date: Wed, 13 Nov 2024 18:20:52 +0100 Subject: [PATCH 03/31] `blas_aux` template --- include/common.fypp | 3 +- src/stdlib_linalg_blas_aux.fypp | 76 +++++++++++++++++++++------------ 2 files changed, 51 insertions(+), 28 deletions(-) diff --git a/include/common.fypp b/include/common.fypp index 8d0837e28..004967c46 100644 --- a/include/common.fypp +++ b/include/common.fypp @@ -77,7 +77,8 @@ $:"s" if cmplx=="c" else "d" if cmplx=="z" else "x" if cmplx=="y" else "q" if cm #! BLAS/LAPACK/Linear Algebra Integer Kinds #:set LINALG_INT_KINDS = ["ilp","ilp64"] #:set LINALG_INT_TYPES = ["integer({})".format(k) for k in LINALG_INT_KINDS] -#:set LINALG_INT_KINDS_TYPES = list(zip(LINALG_INT_KINDS, LINALG_INT_TYPES)) +#:set LINALG_INT_SUFFIX = ["_{}".format(k) for k in LINALG_INT_KINDS] +#:set LINALG_INT_KINDS_TYPES = list(zip(LINALG_INT_KINDS, LINALG_INT_TYPES, LINALG_INT_SUFFIX)) #! Complex types to be considered during templating #:set CMPLX_TYPES = ["complex({})".format(k) for k in CMPLX_KINDS] diff --git a/src/stdlib_linalg_blas_aux.fypp b/src/stdlib_linalg_blas_aux.fypp index 84b2ebdec..49487b961 100644 --- a/src/stdlib_linalg_blas_aux.fypp +++ b/src/stdlib_linalg_blas_aux.fypp @@ -21,6 +21,27 @@ module stdlib_linalg_blas_aux #:endfor end interface stdlib_cabs1 + #:for rk,rt,ri in RC_KINDS_TYPES + interface stdlib_i${ri}$amax + #:for ik,it,ii in LINALG_INT_KINDS_TYPES + module procedure stdlib${ii}$_i${ri}$amax + #:endfor + end interface stdlib_i${ri}$amax + #:endfor + + interface stdlib_xerbla + #:for ik,it,ii in LINALG_INT_KINDS_TYPES + module procedure stdlib${ii}$_xerbla + #:endfor + end interface stdlib_xerbla + + interface stdlib_xerbla_array + #:for ik,it,ii in LINALG_INT_KINDS_TYPES + module procedure stdlib${ii}$_xerbla_array + #:endfor + end interface stdlib_xerbla_array + + contains @@ -57,13 +78,13 @@ module stdlib_linalg_blas_aux stdlib_lsame = ca == cb if (stdlib_lsame) return ! now test for equivalence if both characters are alphabetic. - zcode = ichar('Z') + zcode = ichar('Z',kind=ilp) ! use 'z' rather than 'a' so that ascii can be detected on prime ! machines, on which ichar returns a value with bit 8 set. ! ichar('a') on prime machines returns 193 which is the same as ! ichar('a') on an ebcdic machine. - inta = ichar(ca) - intb = ichar(cb) + inta = ichar(ca,kind=ilp) + intb = ichar(cb,kind=ilp) if (zcode==90 .or. zcode==122) then ! ascii is assumed - zcode is the ascii code of either lower or ! upper case 'z'. @@ -86,7 +107,8 @@ module stdlib_linalg_blas_aux ! return end function stdlib_lsame - pure subroutine stdlib_xerbla( srname, info ) + #:for ik,it,ii in LINALG_INT_KINDS_TYPES + pure subroutine stdlib${ii}$_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 !! invalid value. A message is printed and execution stops. @@ -97,17 +119,17 @@ module stdlib_linalg_blas_aux ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character(len=*), intent(in) :: srname - integer(ilp), intent(in) :: info + integer(${ik}$), intent(in) :: info ! ===================================================================== ! Intrinsic Functions intrinsic :: len_trim ! Executable Statements 9999 format( ' ** ON ENTRY TO ', a, ' PARAMETER NUMBER ', i2, ' HAD ','AN ILLEGAL VALUE' ) - end subroutine stdlib_xerbla + end subroutine stdlib${ii}$_xerbla - pure subroutine stdlib_xerbla_array(srname_array, srname_len, info) + pure subroutine stdlib${ii}$_xerbla_array(srname_array, srname_len, info) !! XERBLA_ARRAY assists other languages in calling XERBLA, the LAPACK !! and BLAS error handler. Rather than taking a Fortran string argument !! as the function's name, XERBLA_ARRAY takes an array of single @@ -128,12 +150,12 @@ module stdlib_linalg_blas_aux ! -- 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) :: srname_len, info + integer(${ik}$), intent(in) :: srname_len, info ! Array Arguments character(1), intent(in) :: srname_array(srname_len) ! ===================================================================== ! Local Scalars - integer(ilp) :: i + integer(${ik}$) :: i ! Local Arrays character*32 srname ! Intrinsic Functions @@ -145,34 +167,34 @@ module stdlib_linalg_blas_aux end do call stdlib_xerbla( srname, info ) return - end subroutine stdlib_xerbla_array + end subroutine stdlib${ii}$_xerbla_array #:for rk,rt,ri in REAL_KINDS_TYPES - pure integer(ilp) function stdlib_i${ri}$amax(n,dx,incx) + pure integer(${ik}$) function stdlib${ii}$_i${ri}$amax(n,dx,incx) result(iamax) !! 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 + integer(${ik}$), intent(in) :: incx, n ! Array Arguments real(${rk}$), intent(in) :: dx(*) ! ===================================================================== ! Local Scalars real(${rk}$) :: dmax - integer(ilp) :: i, ix + integer(${ik}$) :: i, ix ! Intrinsic Functions intrinsic :: abs - stdlib_i${ri}$amax = 0 + iamax = 0 if (n<1 .or. incx<=0) return - stdlib_i${ri}$amax = 1 + iamax = 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_i${ri}$amax = i + iamax = i dmax = abs(dx(i)) end if end do @@ -183,41 +205,40 @@ module stdlib_linalg_blas_aux ix = ix + incx do i = 2,n if (abs(dx(ix))>dmax) then - stdlib_i${ri}$amax = i + iamax = i dmax = abs(dx(ix)) end if ix = ix + incx end do end if return - end function stdlib_i${ri}$amax + end function stdlib${ii}$_i${ri}$amax #:endfor - #:for ck,ct,ci in CMPLX_KINDS_TYPES - pure integer(ilp) function stdlib_i${ci}$amax(n,zx,incx) + pure integer(${ik}$) function stdlib${ii}$_i${ci}$amax(n,zx,incx) result(iamax) !! 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 + integer(${ik}$), intent(in) :: incx, n ! Array Arguments complex(${ck}$), intent(in) :: zx(*) ! ===================================================================== ! Local Scalars real(${ck}$) :: dmax - integer(ilp) :: i, ix - stdlib_i${ci}$amax = 0 + integer(${ik}$) :: i, ix + iamax = 0 if (n<1 .or. incx<=0) return - stdlib_i${ci}$amax = 1 + iamax = 1 if (n==1) return if (incx==1) then ! code for increment equal to 1 dmax = stdlib_cabs1(zx(1)) do i = 2,n if (stdlib_cabs1(zx(i))>dmax) then - stdlib_i${ci}$amax = i + iamax = i dmax = stdlib_cabs1(zx(i)) end if end do @@ -228,15 +249,16 @@ module stdlib_linalg_blas_aux ix = ix + incx do i = 2,n if (stdlib_cabs1(zx(ix))>dmax) then - stdlib_i${ci}$amax = i + iamax = i dmax = stdlib_cabs1(zx(ix)) end if ix = ix + incx end do end if return - end function stdlib_i${ci}$amax + end function stdlib${ii}$_i${ci}$amax #:endfor +#:endfor end module stdlib_linalg_blas_aux From d5365baa6435a1764ec5dca84207d89fa1b4b0fa Mon Sep 17 00:00:00 2001 From: Federico Perini Date: Wed, 13 Nov 2024 18:29:52 +0100 Subject: [PATCH 04/31] rollback to duplicate interface method (cannot use interfaces for `(*)` arguments) --- include/common.fypp | 2 +- src/stdlib_linalg_blas_aux.fypp | 35 ++++++++------------------------- 2 files changed, 9 insertions(+), 28 deletions(-) diff --git a/include/common.fypp b/include/common.fypp index 004967c46..714605a9e 100644 --- a/include/common.fypp +++ b/include/common.fypp @@ -77,7 +77,7 @@ $:"s" if cmplx=="c" else "d" if cmplx=="z" else "x" if cmplx=="y" else "q" if cm #! BLAS/LAPACK/Linear Algebra Integer Kinds #:set LINALG_INT_KINDS = ["ilp","ilp64"] #:set LINALG_INT_TYPES = ["integer({})".format(k) for k in LINALG_INT_KINDS] -#:set LINALG_INT_SUFFIX = ["_{}".format(k) for k in LINALG_INT_KINDS] +#:set LINALG_INT_SUFFIX = ["","_i64"] #:set LINALG_INT_KINDS_TYPES = list(zip(LINALG_INT_KINDS, LINALG_INT_TYPES, LINALG_INT_SUFFIX)) #! Complex types to be considered during templating diff --git a/src/stdlib_linalg_blas_aux.fypp b/src/stdlib_linalg_blas_aux.fypp index 49487b961..692d7b8fa 100644 --- a/src/stdlib_linalg_blas_aux.fypp +++ b/src/stdlib_linalg_blas_aux.fypp @@ -8,39 +8,20 @@ module stdlib_linalg_blas_aux public :: sp,dp,qp,lk,ilp public :: stdlib_cabs1 - #:for rk,rt,ri in RC_KINDS_TYPES - public :: stdlib_i${ri}$amax - #:endfor public :: stdlib_lsame - public :: stdlib_xerbla - public :: stdlib_xerbla_array + #:for ik,it,ii in LINALG_INT_KINDS_TYPES + #:for rk,rt,ri in RC_KINDS_TYPES + public :: stdlib${ii}$_i${ri}$amax + #:endfor + public :: stdlib${ii}$_xerbla + public :: stdlib${ii}$_xerbla_array + #:endfor interface stdlib_cabs1 #:for rk,rt,ri in REAL_KINDS_TYPES module procedure stdlib_${ri}$cabs1 #:endfor end interface stdlib_cabs1 - - #:for rk,rt,ri in RC_KINDS_TYPES - interface stdlib_i${ri}$amax - #:for ik,it,ii in LINALG_INT_KINDS_TYPES - module procedure stdlib${ii}$_i${ri}$amax - #:endfor - end interface stdlib_i${ri}$amax - #:endfor - - interface stdlib_xerbla - #:for ik,it,ii in LINALG_INT_KINDS_TYPES - module procedure stdlib${ii}$_xerbla - #:endfor - end interface stdlib_xerbla - - interface stdlib_xerbla_array - #:for ik,it,ii in LINALG_INT_KINDS_TYPES - module procedure stdlib${ii}$_xerbla_array - #:endfor - end interface stdlib_xerbla_array - contains @@ -165,7 +146,7 @@ module stdlib_linalg_blas_aux do i = 1, min( srname_len, len( srname ) ) srname( i:i ) = srname_array( i ) end do - call stdlib_xerbla( srname, info ) + call stdlib${ii}$_xerbla( srname, info ) return end subroutine stdlib${ii}$_xerbla_array From 8046997a272b26462937c2f0ab2550a80e90243a Mon Sep 17 00:00:00 2001 From: Federico Perini Date: Wed, 13 Nov 2024 18:33:00 +0100 Subject: [PATCH 05/31] `blas_s`: template integer type --- src/stdlib_linalg_blas_s.fypp | 436 +++++++++++++++++----------------- 1 file changed, 219 insertions(+), 217 deletions(-) diff --git a/src/stdlib_linalg_blas_s.fypp b/src/stdlib_linalg_blas_s.fypp index 0f8c5075e..60c41dfe6 100644 --- a/src/stdlib_linalg_blas_s.fypp +++ b/src/stdlib_linalg_blas_s.fypp @@ -6,43 +6,45 @@ module stdlib_linalg_blas_s private - public :: sp,dp,qp,lk,ilp - public :: stdlib_sasum - public :: stdlib_saxpy - public :: stdlib_scasum - public :: stdlib_scnrm2 - public :: stdlib_scopy - public :: stdlib_sdot - public :: stdlib_sdsdot - public :: stdlib_sgbmv - public :: stdlib_sgemm - public :: stdlib_sgemv - public :: stdlib_sger - public :: stdlib_snrm2 - public :: stdlib_srot - public :: stdlib_srotg - public :: stdlib_srotm - public :: stdlib_srotmg - public :: stdlib_ssbmv - public :: stdlib_sscal - public :: stdlib_sspmv - public :: stdlib_sspr - public :: stdlib_sspr2 - public :: stdlib_sswap - public :: stdlib_ssymm - public :: stdlib_ssymv - public :: stdlib_ssyr - public :: stdlib_ssyr2 - public :: stdlib_ssyr2k - public :: stdlib_ssyrk - public :: stdlib_stbmv - public :: stdlib_stbsv - public :: stdlib_stpmv - public :: stdlib_stpsv - public :: stdlib_strmm - public :: stdlib_strmv - public :: stdlib_strsm - public :: stdlib_strsv + public :: sp,dp,qp,lk,ilp,ilp64 + #:for ik,it,ii in LINALG_INT_KINDS_TYPES + public :: stdlib${ii}$_sasum + public :: stdlib${ii}$_saxpy + public :: stdlib${ii}$_scasum + public :: stdlib${ii}$_scnrm2 + public :: stdlib${ii}$_scopy + public :: stdlib${ii}$_sdot + public :: stdlib${ii}$_sdsdot + public :: stdlib${ii}$_sgbmv + public :: stdlib${ii}$_sgemm + public :: stdlib${ii}$_sgemv + public :: stdlib${ii}$_sger + public :: stdlib${ii}$_snrm2 + public :: stdlib${ii}$_srot + public :: stdlib${ii}$_srotg + public :: stdlib${ii}$_srotm + public :: stdlib${ii}$_srotmg + public :: stdlib${ii}$_ssbmv + public :: stdlib${ii}$_sscal + public :: stdlib${ii}$_sspmv + public :: stdlib${ii}$_sspr + public :: stdlib${ii}$_sspr2 + public :: stdlib${ii}$_sswap + public :: stdlib${ii}$_ssymm + public :: stdlib${ii}$_ssymv + public :: stdlib${ii}$_ssyr + public :: stdlib${ii}$_ssyr2 + public :: stdlib${ii}$_ssyr2k + public :: stdlib${ii}$_ssyrk + public :: stdlib${ii}$_stbmv + public :: stdlib${ii}$_stbsv + public :: stdlib${ii}$_stpmv + public :: stdlib${ii}$_stpsv + public :: stdlib${ii}$_strmm + public :: stdlib${ii}$_strmv + public :: stdlib${ii}$_strsm + public :: stdlib${ii}$_strsv + #:endfor ! 32-bit real constants real(sp), parameter, private :: negone = -1.00_sp @@ -84,24 +86,24 @@ module stdlib_linalg_blas_s contains - - pure real(sp) function stdlib_sasum(n,sx,incx) + #:for ik,it,ii in LINALG_INT_KINDS_TYPES + pure real(sp) function stdlib${ii}$_sasum(n,sx,incx) !! SASUM takes the sum of the absolute values. !! uses unrolled loops for increment 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 - integer(ilp), intent(in) :: incx, n + integer(${ik}$), intent(in) :: incx, n ! Array Arguments real(sp), intent(in) :: sx(*) ! ===================================================================== ! Local Scalars real(sp) :: stemp - integer(ilp) :: i, m, mp1, nincx + integer(${ik}$) :: i, m, mp1, nincx ! Intrinsic Functions intrinsic :: abs,mod - stdlib_sasum = zero + stdlib${ii}$_sasum = zero stemp = zero if (n<=0 .or. incx<=0) return if (incx==1) then @@ -113,7 +115,7 @@ module stdlib_linalg_blas_s stemp = stemp + abs(sx(i)) end do if (n<6) then - stdlib_sasum = stemp + stdlib${ii}$_sasum = stemp return end if end if @@ -129,12 +131,12 @@ module stdlib_linalg_blas_s stemp = stemp + abs(sx(i)) end do end if - stdlib_sasum = stemp + stdlib${ii}$_sasum = stemp return - end function stdlib_sasum + end function stdlib${ii}$_sasum - pure subroutine stdlib_saxpy(n,sa,sx,incx,sy,incy) + pure subroutine stdlib${ii}$_saxpy(n,sa,sx,incx,sy,incy) !! SAXPY constant times a vector plus a vector. !! uses unrolled loops for increments equal to one. ! -- reference blas level1 routine -- @@ -142,13 +144,13 @@ module stdlib_linalg_blas_s ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments real(sp), intent(in) :: sa - integer(ilp), intent(in) :: incx, incy, n + integer(${ik}$), intent(in) :: incx, incy, n ! Array Arguments real(sp), intent(in) :: sx(*) real(sp), intent(inout) :: sy(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, ix, iy, m, mp1 + integer(${ik}$) :: i, ix, iy, m, mp1 ! Intrinsic Functions intrinsic :: mod if (n<=0) return @@ -184,26 +186,26 @@ module stdlib_linalg_blas_s end do end if return - end subroutine stdlib_saxpy + end subroutine stdlib${ii}$_saxpy - pure real(sp) function stdlib_scasum(n,cx,incx) + pure real(sp) function stdlib${ii}$_scasum(n,cx,incx) !! SCASUM takes the sum of the (|Re(.)| + |Im(.)|)'s of a complex vector and !! returns a single precision result. ! -- 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 + integer(${ik}$), intent(in) :: incx, n ! Array Arguments complex(sp), intent(in) :: cx(*) ! ===================================================================== ! Local Scalars real(sp) :: stemp - integer(ilp) :: i, nincx + integer(${ik}$) :: i, nincx ! Intrinsic Functions intrinsic :: abs,aimag,real - stdlib_scasum = zero + stdlib${ii}$_scasum = zero stemp = zero if (n<=0 .or. incx<=0) return if (incx==1) then @@ -218,16 +220,16 @@ module stdlib_linalg_blas_s stemp = stemp + abs(real(cx(i),KIND=sp)) + abs(aimag(cx(i))) end do end if - stdlib_scasum = stemp + stdlib${ii}$_scasum = stemp return - end function stdlib_scasum + end function stdlib${ii}$_scasum - pure function stdlib_scnrm2( n, x, incx ) + pure function stdlib${ii}$_scnrm2( n, x, incx ) !! SCNRM2 returns the euclidean norm of a vector via the function !! name, so that !! SCNRM2 := sqrt( x**H*x ) - real(sp) :: stdlib_scnrm2 + real(sp) :: stdlib${ii}$_scnrm2 ! -- reference blas level1 routine (version 3.9.1_sp) -- ! -- reference blas is a software package provided by univ. of tennessee, -- ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- @@ -236,15 +238,15 @@ module stdlib_linalg_blas_s real(sp), parameter :: maxn = huge(0.0_sp) ! .. blue's scaling constants .. ! Scalar Arguments - integer(ilp), intent(in) :: incx, n + integer(${ik}$), intent(in) :: incx, n ! Array Arguments complex(sp), intent(in) :: x(*) ! Local Scalars - integer(ilp) :: i, ix + integer(${ik}$) :: i, ix logical(lk) :: notbig real(sp) :: abig, amed, asml, ax, scl, sumsq, ymax, ymin ! quick return if possible - stdlib_scnrm2 = zero + stdlib${ii}$_scnrm2 = zero if( n <= 0 ) return scl = one sumsq = zero @@ -314,25 +316,25 @@ module stdlib_linalg_blas_s scl = one sumsq = amed end if - stdlib_scnrm2 = scl*sqrt( sumsq ) + stdlib${ii}$_scnrm2 = scl*sqrt( sumsq ) return - end function stdlib_scnrm2 + end function stdlib${ii}$_scnrm2 - pure subroutine stdlib_scopy(n,sx,incx,sy,incy) + pure subroutine stdlib${ii}$_scopy(n,sx,incx,sy,incy) !! SCOPY copies a vector, x, to a vector, y. !! uses unrolled loops for increments equal to 1. ! -- 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, incy, n + integer(${ik}$), intent(in) :: incx, incy, n ! Array Arguments real(sp), intent(in) :: sx(*) real(sp), intent(out) :: sy(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, ix, iy, m, mp1 + integer(${ik}$) :: i, ix, iy, m, mp1 ! Intrinsic Functions intrinsic :: mod if (n<=0) return @@ -370,27 +372,27 @@ module stdlib_linalg_blas_s end do end if return - end subroutine stdlib_scopy + end subroutine stdlib${ii}$_scopy - pure real(sp) function stdlib_sdot(n,sx,incx,sy,incy) + pure real(sp) function stdlib${ii}$_sdot(n,sx,incx,sy,incy) !! SDOT forms the dot product of two vectors. !! 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 - integer(ilp), intent(in) :: incx, incy, n + integer(${ik}$), intent(in) :: incx, incy, n ! Array Arguments real(sp), intent(in) :: sx(*), sy(*) ! ===================================================================== ! Local Scalars real(sp) :: stemp - integer(ilp) :: i, ix, iy, m, mp1 + integer(${ik}$) :: i, ix, iy, m, mp1 ! Intrinsic Functions intrinsic :: mod stemp = zero - stdlib_sdot = zero + stdlib${ii}$_sdot = zero if (n<=0) return if (incx==1 .and. incy==1) then ! code for both increments equal to 1 @@ -401,7 +403,7 @@ module stdlib_linalg_blas_s stemp = stemp + sx(i)*sy(i) end do if (n<5) then - stdlib_sdot=stemp + stdlib${ii}$_sdot=stemp return end if end if @@ -423,12 +425,12 @@ module stdlib_linalg_blas_s iy = iy + incy end do end if - stdlib_sdot = stemp + stdlib${ii}$_sdot = stemp return - end function stdlib_sdot + end function stdlib${ii}$_sdot - pure real(sp) function stdlib_sdsdot(n,sb,sx,incx,sy,incy) + pure real(sp) function stdlib${ii}$_sdsdot(n,sb,sx,incx,sy,incy) !! Compute the inner product of two vectors with extended !! precision accumulation. !! Returns S.P. result with dot product accumulated in D.P. @@ -440,17 +442,17 @@ module stdlib_linalg_blas_s ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments real(sp), intent(in) :: sb - integer(ilp), intent(in) :: incx, incy, n + integer(${ik}$), intent(in) :: incx, incy, n ! Array Arguments real(sp), intent(in) :: sx(*), sy(*) ! Local Scalars real(dp) :: dsdot - integer(ilp) :: i, kx, ky, ns + integer(${ik}$) :: i, kx, ky, ns ! Intrinsic Functions intrinsic :: real dsdot = sb if (n<=0) then - stdlib_sdsdot = dsdot + stdlib${ii}$_sdsdot = dsdot return end if if (incx==incy .and. incx>0) then @@ -471,12 +473,12 @@ module stdlib_linalg_blas_s ky = ky + incy end do end if - stdlib_sdsdot = dsdot + stdlib${ii}$_sdsdot = dsdot return - end function stdlib_sdsdot + end function stdlib${ii}$_sdsdot - pure subroutine stdlib_sgbmv(trans,m,n,kl,ku,alpha,a,lda,x,incx,beta,y,incy) + pure subroutine stdlib${ii}$_sgbmv(trans,m,n,kl,ku,alpha,a,lda,x,incx,beta,y,incy) !! SGBMV 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 @@ -486,7 +488,7 @@ module stdlib_linalg_blas_s ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments real(sp), intent(in) :: alpha, beta - integer(ilp), intent(in) :: incx, incy, kl, ku, lda, m, n + integer(${ik}$), intent(in) :: incx, incy, kl, ku, lda, m, n character, intent(in) :: trans ! Array Arguments real(sp), intent(in) :: a(lda,*), x(*) @@ -495,7 +497,7 @@ module stdlib_linalg_blas_s ! Local Scalars real(sp) :: temp - integer(ilp) :: i, info, ix, iy, j, jx, jy, k, kup1, kx, ky, lenx, leny + integer(${ik}$) :: i, info, ix, iy, j, jx, jy, k, kup1, kx, ky, lenx, leny ! Intrinsic Functions intrinsic :: max,min ! test the input parameters. @@ -519,7 +521,7 @@ module stdlib_linalg_blas_s info = 13 end if if (info/=0) then - call stdlib_xerbla('SGBMV ',info) + call stdlib${ii}$_xerbla('SGBMV ',info) return end if ! quick return if possible. @@ -628,10 +630,10 @@ module stdlib_linalg_blas_s end if end if return - end subroutine stdlib_sgbmv + end subroutine stdlib${ii}$_sgbmv - pure subroutine stdlib_sgemm(transa,transb,m,n,k,alpha,a,lda,b,ldb,beta,c,ldc) + pure subroutine stdlib${ii}$_sgemm(transa,transb,m,n,k,alpha,a,lda,b,ldb,beta,c,ldc) !! SGEMM performs one of the matrix-matrix operations !! C := alpha*op( A )*op( B ) + beta*C, !! where op( X ) is one of @@ -643,7 +645,7 @@ module stdlib_linalg_blas_s ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments real(sp), intent(in) :: alpha, beta - integer(ilp), intent(in) :: k, lda, ldb, ldc, m, n + integer(${ik}$), intent(in) :: k, lda, ldb, ldc, m, n character, intent(in) :: transa, transb ! Array Arguments real(sp), intent(in) :: a(lda,*), b(ldb,*) @@ -653,7 +655,7 @@ module stdlib_linalg_blas_s intrinsic :: max ! Local Scalars real(sp) :: temp - integer(ilp) :: i, info, j, l, nrowa, nrowb + integer(${ik}$) :: i, info, j, l, nrowa, nrowb logical(lk) :: nota, notb ! set nota and notb as true if a and b respectively are not @@ -693,7 +695,7 @@ module stdlib_linalg_blas_s info = 13 end if if (info/=0) then - call stdlib_xerbla('SGEMM ',info) + call stdlib${ii}$_xerbla('SGEMM ',info) return end if ! quick return if possible. @@ -791,10 +793,10 @@ module stdlib_linalg_blas_s end if end if return - end subroutine stdlib_sgemm + end subroutine stdlib${ii}$_sgemm - pure subroutine stdlib_sgemv(trans,m,n,alpha,a,lda,x,incx,beta,y,incy) + pure subroutine stdlib${ii}$_sgemv(trans,m,n,alpha,a,lda,x,incx,beta,y,incy) !! SGEMV 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 @@ -804,7 +806,7 @@ module stdlib_linalg_blas_s ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments real(sp), intent(in) :: alpha, beta - integer(ilp), intent(in) :: incx, incy, lda, m, n + integer(${ik}$), intent(in) :: incx, incy, lda, m, n character, intent(in) :: trans ! Array Arguments real(sp), intent(in) :: a(lda,*), x(*) @@ -813,7 +815,7 @@ module stdlib_linalg_blas_s ! Local Scalars real(sp) :: temp - integer(ilp) :: i, info, ix, iy, j, jx, jy, kx, ky, lenx, leny + integer(${ik}$) :: i, info, ix, iy, j, jx, jy, kx, ky, lenx, leny ! Intrinsic Functions intrinsic :: max ! test the input parameters. @@ -833,7 +835,7 @@ module stdlib_linalg_blas_s info = 11 end if if (info/=0) then - call stdlib_xerbla('SGEMV ',info) + call stdlib${ii}$_xerbla('SGEMV ',info) return end if ! quick return if possible. @@ -935,10 +937,10 @@ module stdlib_linalg_blas_s end if end if return - end subroutine stdlib_sgemv + end subroutine stdlib${ii}$_sgemv - pure subroutine stdlib_sger(m,n,alpha,x,incx,y,incy,a,lda) + pure subroutine stdlib${ii}$_sger(m,n,alpha,x,incx,y,incy,a,lda) !! SGER 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 @@ -948,7 +950,7 @@ module stdlib_linalg_blas_s ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments real(sp), intent(in) :: alpha - integer(ilp), intent(in) :: incx, incy, lda, m, n + integer(${ik}$), intent(in) :: incx, incy, lda, m, n ! Array Arguments real(sp), intent(inout) :: a(lda,*) real(sp), intent(in) :: x(*), y(*) @@ -956,7 +958,7 @@ module stdlib_linalg_blas_s ! Local Scalars real(sp) :: temp - integer(ilp) :: i, info, ix, j, jy, kx + integer(${ik}$) :: i, info, ix, j, jy, kx ! Intrinsic Functions intrinsic :: max ! test the input parameters. @@ -973,7 +975,7 @@ module stdlib_linalg_blas_s info = 9 end if if (info/=0) then - call stdlib_xerbla('SGER ',info) + call stdlib${ii}$_xerbla('SGER ',info) return end if ! quick return if possible. @@ -1014,14 +1016,14 @@ module stdlib_linalg_blas_s end do end if return - end subroutine stdlib_sger + end subroutine stdlib${ii}$_sger - pure function stdlib_snrm2( n, x, incx ) + pure function stdlib${ii}$_snrm2( n, x, incx ) !! SNRM2 returns the euclidean norm of a vector via the function !! name, so that !! SNRM2 := sqrt( x'*x ). - real(sp) :: stdlib_snrm2 + real(sp) :: stdlib${ii}$_snrm2 ! -- reference blas level1 routine (version 3.9.1_sp) -- ! -- reference blas is a software package provided by univ. of tennessee, -- ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- @@ -1030,15 +1032,15 @@ module stdlib_linalg_blas_s real(sp), parameter :: maxn = huge(0.0_sp) ! .. blue's scaling constants .. ! Scalar Arguments - integer(ilp), intent(in) :: incx, n + integer(${ik}$), intent(in) :: incx, n ! Array Arguments real(sp), intent(in) :: x(*) ! Local Scalars - integer(ilp) :: i, ix + integer(${ik}$) :: i, ix logical(lk) :: notbig real(sp) :: abig, amed, asml, ax, scl, sumsq, ymax, ymin ! quick return if possible - stdlib_snrm2 = zero + stdlib${ii}$_snrm2 = zero if( n <= 0 ) return scl = one sumsq = zero @@ -1099,25 +1101,25 @@ module stdlib_linalg_blas_s scl = one sumsq = amed end if - stdlib_snrm2 = scl*sqrt( sumsq ) + stdlib${ii}$_snrm2 = scl*sqrt( sumsq ) return - end function stdlib_snrm2 + end function stdlib${ii}$_snrm2 - pure subroutine stdlib_srot(n,sx,incx,sy,incy,c,s) + pure subroutine stdlib${ii}$_srot(n,sx,incx,sy,incy,c,s) !! 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(sp), intent(in) :: c, s - integer(ilp), intent(in) :: incx, incy, n + integer(${ik}$), intent(in) :: incx, incy, n ! Array Arguments real(sp), intent(inout) :: sx(*), sy(*) ! ===================================================================== ! Local Scalars real(sp) :: stemp - integer(ilp) :: i, ix, iy + integer(${ik}$) :: i, ix, iy if (n<=0) return if (incx==1 .and. incy==1) then ! code for both increments equal to 1 @@ -1142,10 +1144,10 @@ module stdlib_linalg_blas_s end do end if return - end subroutine stdlib_srot + end subroutine stdlib${ii}$_srot - pure subroutine stdlib_srotg( a, b, c, s ) + pure subroutine stdlib${ii}$_srotg( a, b, c, s ) !! The computation uses the formulas !! sigma = sgn(a) if |a| > |b| !! = sgn(b) if |b| >= |a| @@ -1202,10 +1204,10 @@ module stdlib_linalg_blas_s b = z end if return - end subroutine stdlib_srotg + end subroutine stdlib${ii}$_srotg - pure subroutine stdlib_srotm(n,sx,incx,sy,incy,sparam) + pure subroutine stdlib${ii}$_srotm(n,sx,incx,sy,incy,sparam) !! SROTM applies the modified Givens transformation, \(H\), to the 2-by-N matrix !! $$ \left[ \begin{array}{c}SX^T\\SY^T\\ \end{array} \right], $$ !! where \(^T\) indicates transpose. The elements of \(SX\) are in @@ -1221,14 +1223,14 @@ module stdlib_linalg_blas_s ! -- 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, incy, n + integer(${ik}$), intent(in) :: incx, incy, n ! Array Arguments real(sp), intent(in) :: sparam(5) real(sp), intent(inout) :: sx(*), sy(*) ! ===================================================================== ! Local Scalars real(sp) :: sflag, sh11, sh12, sh21, sh22, two, w, z, zero - integer(ilp) :: i, kx, ky, nsteps + integer(${ik}$) :: i, kx, ky, nsteps ! Data Statements zero = 0.0_sp two = 2.0_sp @@ -1309,10 +1311,10 @@ module stdlib_linalg_blas_s end if end if return - end subroutine stdlib_srotm + end subroutine stdlib${ii}$_srotm - pure subroutine stdlib_srotmg(sd1,sd2,sx1,sy1,sparam) + pure subroutine stdlib${ii}$_srotmg(sd1,sd2,sx1,sy1,sparam) !! SROTMG Constructs the modified Givens transformation matrix \(H\) which zeros the !! second component of the 2-vector !! $$ \left[ {\sqrt{SD_1}\cdot SX_1,\sqrt{SD_2}\cdot SY_2} \right]^T. $$ @@ -1474,10 +1476,10 @@ module stdlib_linalg_blas_s end if sparam(1) = sflag return - end subroutine stdlib_srotmg + end subroutine stdlib${ii}$_srotmg - pure subroutine stdlib_ssbmv(uplo,n,k,alpha,a,lda,x,incx,beta,y,incy) + pure subroutine stdlib${ii}$_ssbmv(uplo,n,k,alpha,a,lda,x,incx,beta,y,incy) !! SSBMV 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 @@ -1487,7 +1489,7 @@ module stdlib_linalg_blas_s ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments real(sp), intent(in) :: alpha, beta - integer(ilp), intent(in) :: incx, incy, k, lda, n + integer(${ik}$), intent(in) :: incx, incy, k, lda, n character, intent(in) :: uplo ! Array Arguments real(sp), intent(in) :: a(lda,*), x(*) @@ -1496,7 +1498,7 @@ module stdlib_linalg_blas_s ! Local Scalars real(sp) :: temp1, temp2 - integer(ilp) :: i, info, ix, iy, j, jx, jy, kplus1, kx, ky, l + integer(${ik}$) :: i, info, ix, iy, j, jx, jy, kplus1, kx, ky, l ! Intrinsic Functions intrinsic :: max,min ! test the input parameters. @@ -1515,7 +1517,7 @@ module stdlib_linalg_blas_s info = 11 end if if (info/=0) then - call stdlib_xerbla('SSBMV ',info) + call stdlib${ii}$_xerbla('SSBMV ',info) return end if ! quick return if possible. @@ -1636,10 +1638,10 @@ module stdlib_linalg_blas_s end if end if return - end subroutine stdlib_ssbmv + end subroutine stdlib${ii}$_ssbmv - pure subroutine stdlib_sscal(n,sa,sx,incx) + pure subroutine stdlib${ii}$_sscal(n,sa,sx,incx) !! SSCAL scales a vector by a constant. !! uses unrolled loops for increment equal to 1. ! -- reference blas level1 routine -- @@ -1647,12 +1649,12 @@ module stdlib_linalg_blas_s ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments real(sp), intent(in) :: sa - integer(ilp), intent(in) :: incx, n + integer(${ik}$), intent(in) :: incx, n ! Array Arguments real(sp), intent(inout) :: sx(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, m, mp1, nincx + integer(${ik}$) :: i, m, mp1, nincx ! Intrinsic Functions intrinsic :: mod if (n<=0 .or. incx<=0) return @@ -1682,10 +1684,10 @@ module stdlib_linalg_blas_s end do end if return - end subroutine stdlib_sscal + end subroutine stdlib${ii}$_sscal - pure subroutine stdlib_sspmv(uplo,n,alpha,ap,x,incx,beta,y,incy) + pure subroutine stdlib${ii}$_sspmv(uplo,n,alpha,ap,x,incx,beta,y,incy) !! SSPMV 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 @@ -1695,7 +1697,7 @@ module stdlib_linalg_blas_s ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments real(sp), intent(in) :: alpha, beta - integer(ilp), intent(in) :: incx, incy, n + integer(${ik}$), intent(in) :: incx, incy, n character, intent(in) :: uplo ! Array Arguments real(sp), intent(in) :: ap(*), x(*) @@ -1704,7 +1706,7 @@ module stdlib_linalg_blas_s ! Local Scalars real(sp) :: temp1, temp2 - integer(ilp) :: i, info, ix, iy, j, jx, jy, k, kk, kx, ky + integer(${ik}$) :: i, info, ix, iy, j, jx, jy, k, kk, kx, ky ! test the input parameters. info = 0 if (.not.stdlib_lsame(uplo,'U') .and. .not.stdlib_lsame(uplo,'L')) then @@ -1717,7 +1719,7 @@ module stdlib_linalg_blas_s info = 9 end if if (info/=0) then - call stdlib_xerbla('SSPMV ',info) + call stdlib${ii}$_xerbla('SSPMV ',info) return end if ! quick return if possible. @@ -1838,10 +1840,10 @@ module stdlib_linalg_blas_s end if end if return - end subroutine stdlib_sspmv + end subroutine stdlib${ii}$_sspmv - pure subroutine stdlib_sspr(uplo,n,alpha,x,incx,ap) + pure subroutine stdlib${ii}$_sspr(uplo,n,alpha,x,incx,ap) !! SSPR 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 @@ -1851,7 +1853,7 @@ module stdlib_linalg_blas_s ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments real(sp), intent(in) :: alpha - integer(ilp), intent(in) :: incx, n + integer(${ik}$), intent(in) :: incx, n character, intent(in) :: uplo ! Array Arguments real(sp), intent(inout) :: ap(*) @@ -1860,7 +1862,7 @@ module stdlib_linalg_blas_s ! Local Scalars real(sp) :: temp - integer(ilp) :: i, info, ix, j, jx, k, kk, kx + integer(${ik}$) :: i, info, ix, j, jx, k, kk, kx ! test the input parameters. info = 0 if (.not.stdlib_lsame(uplo,'U') .and. .not.stdlib_lsame(uplo,'L')) then @@ -1871,7 +1873,7 @@ module stdlib_linalg_blas_s info = 5 end if if (info/=0) then - call stdlib_xerbla('SSPR ',info) + call stdlib${ii}$_xerbla('SSPR ',info) return end if ! quick return if possible. @@ -1945,10 +1947,10 @@ module stdlib_linalg_blas_s end if end if return - end subroutine stdlib_sspr + end subroutine stdlib${ii}$_sspr - pure subroutine stdlib_sspr2(uplo,n,alpha,x,incx,y,incy,ap) + pure subroutine stdlib${ii}$_sspr2(uplo,n,alpha,x,incx,y,incy,ap) !! SSPR2 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 @@ -1958,7 +1960,7 @@ module stdlib_linalg_blas_s ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments real(sp), intent(in) :: alpha - integer(ilp), intent(in) :: incx, incy, n + integer(${ik}$), intent(in) :: incx, incy, n character, intent(in) :: uplo ! Array Arguments real(sp), intent(inout) :: ap(*) @@ -1967,7 +1969,7 @@ module stdlib_linalg_blas_s ! Local Scalars real(sp) :: temp1, temp2 - integer(ilp) :: i, info, ix, iy, j, jx, jy, k, kk, kx, ky + integer(${ik}$) :: i, info, ix, iy, j, jx, jy, k, kk, kx, ky ! test the input parameters. info = 0 if (.not.stdlib_lsame(uplo,'U') .and. .not.stdlib_lsame(uplo,'L')) then @@ -1980,7 +1982,7 @@ module stdlib_linalg_blas_s info = 7 end if if (info/=0) then - call stdlib_xerbla('SSPR2 ',info) + call stdlib${ii}$_xerbla('SSPR2 ',info) return end if ! quick return if possible. @@ -2072,23 +2074,23 @@ module stdlib_linalg_blas_s end if end if return - end subroutine stdlib_sspr2 + end subroutine stdlib${ii}$_sspr2 - pure subroutine stdlib_sswap(n,sx,incx,sy,incy) + pure subroutine stdlib${ii}$_sswap(n,sx,incx,sy,incy) !! SSWAP interchanges two vectors. !! uses unrolled loops for increments equal to 1. ! -- 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, incy, n + integer(${ik}$), intent(in) :: incx, incy, n ! Array Arguments real(sp), intent(inout) :: sx(*), sy(*) ! ===================================================================== ! Local Scalars real(sp) :: stemp - integer(ilp) :: i, ix, iy, m, mp1 + integer(${ik}$) :: i, ix, iy, m, mp1 ! Intrinsic Functions intrinsic :: mod if (n<=0) return @@ -2132,10 +2134,10 @@ module stdlib_linalg_blas_s end do end if return - end subroutine stdlib_sswap + end subroutine stdlib${ii}$_sswap - pure subroutine stdlib_ssymm(side,uplo,m,n,alpha,a,lda,b,ldb,beta,c,ldc) + pure subroutine stdlib${ii}$_ssymm(side,uplo,m,n,alpha,a,lda,b,ldb,beta,c,ldc) !! SSYMM performs one of the matrix-matrix operations !! C := alpha*A*B + beta*C, !! or @@ -2147,7 +2149,7 @@ module stdlib_linalg_blas_s ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments real(sp), intent(in) :: alpha, beta - integer(ilp), intent(in) :: lda, ldb, ldc, m, n + integer(${ik}$), intent(in) :: lda, ldb, ldc, m, n character, intent(in) :: side, uplo ! Array Arguments real(sp), intent(in) :: a(lda,*), b(ldb,*) @@ -2157,7 +2159,7 @@ module stdlib_linalg_blas_s intrinsic :: max ! Local Scalars real(sp) :: temp1, temp2 - integer(ilp) :: i, info, j, k, nrowa + integer(${ik}$) :: i, info, j, k, nrowa logical(lk) :: upper ! set nrowa as the number of rows of a. @@ -2185,7 +2187,7 @@ module stdlib_linalg_blas_s info = 12 end if if (info/=0) then - call stdlib_xerbla('SSYMM ',info) + call stdlib${ii}$_xerbla('SSYMM ',info) return end if ! quick return if possible. @@ -2279,10 +2281,10 @@ module stdlib_linalg_blas_s end do loop_170 end if return - end subroutine stdlib_ssymm + end subroutine stdlib${ii}$_ssymm - pure subroutine stdlib_ssymv(uplo,n,alpha,a,lda,x,incx,beta,y,incy) + pure subroutine stdlib${ii}$_ssymv(uplo,n,alpha,a,lda,x,incx,beta,y,incy) !! SSYMV 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 @@ -2292,7 +2294,7 @@ module stdlib_linalg_blas_s ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments real(sp), intent(in) :: alpha, beta - integer(ilp), intent(in) :: incx, incy, lda, n + integer(${ik}$), intent(in) :: incx, incy, lda, n character, intent(in) :: uplo ! Array Arguments real(sp), intent(in) :: a(lda,*), x(*) @@ -2301,7 +2303,7 @@ module stdlib_linalg_blas_s ! Local Scalars real(sp) :: temp1, temp2 - integer(ilp) :: i, info, ix, iy, j, jx, jy, kx, ky + integer(${ik}$) :: i, info, ix, iy, j, jx, jy, kx, ky ! Intrinsic Functions intrinsic :: max ! test the input parameters. @@ -2318,7 +2320,7 @@ module stdlib_linalg_blas_s info = 10 end if if (info/=0) then - call stdlib_xerbla('SSYMV ',info) + call stdlib${ii}$_xerbla('SSYMV ',info) return end if ! quick return if possible. @@ -2431,10 +2433,10 @@ module stdlib_linalg_blas_s end if end if return - end subroutine stdlib_ssymv + end subroutine stdlib${ii}$_ssymv - pure subroutine stdlib_ssyr(uplo,n,alpha,x,incx,a,lda) + pure subroutine stdlib${ii}$_ssyr(uplo,n,alpha,x,incx,a,lda) !! SSYR 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 @@ -2444,7 +2446,7 @@ module stdlib_linalg_blas_s ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments real(sp), intent(in) :: alpha - integer(ilp), intent(in) :: incx, lda, n + integer(${ik}$), intent(in) :: incx, lda, n character, intent(in) :: uplo ! Array Arguments real(sp), intent(inout) :: a(lda,*) @@ -2453,7 +2455,7 @@ module stdlib_linalg_blas_s ! Local Scalars real(sp) :: temp - integer(ilp) :: i, info, ix, j, jx, kx + integer(${ik}$) :: i, info, ix, j, jx, kx ! Intrinsic Functions intrinsic :: max ! test the input parameters. @@ -2468,7 +2470,7 @@ module stdlib_linalg_blas_s info = 7 end if if (info/=0) then - call stdlib_xerbla('SSYR ',info) + call stdlib${ii}$_xerbla('SSYR ',info) return end if ! quick return if possible. @@ -2534,10 +2536,10 @@ module stdlib_linalg_blas_s end if end if return - end subroutine stdlib_ssyr + end subroutine stdlib${ii}$_ssyr - pure subroutine stdlib_ssyr2(uplo,n,alpha,x,incx,y,incy,a,lda) + pure subroutine stdlib${ii}$_ssyr2(uplo,n,alpha,x,incx,y,incy,a,lda) !! SSYR2 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 @@ -2547,7 +2549,7 @@ module stdlib_linalg_blas_s ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments real(sp), intent(in) :: alpha - integer(ilp), intent(in) :: incx, incy, lda, n + integer(${ik}$), intent(in) :: incx, incy, lda, n character, intent(in) :: uplo ! Array Arguments real(sp), intent(inout) :: a(lda,*) @@ -2556,7 +2558,7 @@ module stdlib_linalg_blas_s ! Local Scalars real(sp) :: temp1, temp2 - integer(ilp) :: i, info, ix, iy, j, jx, jy, kx, ky + integer(${ik}$) :: i, info, ix, iy, j, jx, jy, kx, ky ! Intrinsic Functions intrinsic :: max ! test the input parameters. @@ -2573,7 +2575,7 @@ module stdlib_linalg_blas_s info = 9 end if if (info/=0) then - call stdlib_xerbla('SSYR2 ',info) + call stdlib${ii}$_xerbla('SSYR2 ',info) return end if ! quick return if possible. @@ -2657,10 +2659,10 @@ module stdlib_linalg_blas_s end if end if return - end subroutine stdlib_ssyr2 + end subroutine stdlib${ii}$_ssyr2 - pure subroutine stdlib_ssyr2k(uplo,trans,n,k,alpha,a,lda,b,ldb,beta,c,ldc) + pure subroutine stdlib${ii}$_ssyr2k(uplo,trans,n,k,alpha,a,lda,b,ldb,beta,c,ldc) !! SSYR2K performs one of the symmetric rank 2k operations !! C := alpha*A*B**T + alpha*B*A**T + beta*C, !! or @@ -2673,7 +2675,7 @@ module stdlib_linalg_blas_s ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments real(sp), intent(in) :: alpha, beta - integer(ilp), intent(in) :: k, lda, ldb, ldc, n + integer(${ik}$), intent(in) :: k, lda, ldb, ldc, n character, intent(in) :: trans, uplo ! Array Arguments real(sp), intent(in) :: a(lda,*), b(ldb,*) @@ -2683,7 +2685,7 @@ module stdlib_linalg_blas_s intrinsic :: max ! Local Scalars real(sp) :: temp1, temp2 - integer(ilp) :: i, info, j, l, nrowa + integer(${ik}$) :: i, info, j, l, nrowa logical(lk) :: upper ! test the input parameters. @@ -2711,7 +2713,7 @@ module stdlib_linalg_blas_s info = 12 end if if (info/=0) then - call stdlib_xerbla('SSYR2K',info) + call stdlib${ii}$_xerbla('SSYR2K',info) return end if ! quick return if possible. @@ -2832,10 +2834,10 @@ module stdlib_linalg_blas_s end if end if return - end subroutine stdlib_ssyr2k + end subroutine stdlib${ii}$_ssyr2k - pure subroutine stdlib_ssyrk(uplo,trans,n,k,alpha,a,lda,beta,c,ldc) + pure subroutine stdlib${ii}$_ssyrk(uplo,trans,n,k,alpha,a,lda,beta,c,ldc) !! SSYRK performs one of the symmetric rank k operations !! C := alpha*A*A**T + beta*C, !! or @@ -2848,7 +2850,7 @@ module stdlib_linalg_blas_s ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments real(sp), intent(in) :: alpha, beta - integer(ilp), intent(in) :: k, lda, ldc, n + integer(${ik}$), intent(in) :: k, lda, ldc, n character, intent(in) :: trans, uplo ! Array Arguments real(sp), intent(in) :: a(lda,*) @@ -2858,7 +2860,7 @@ module stdlib_linalg_blas_s intrinsic :: max ! Local Scalars real(sp) :: temp - integer(ilp) :: i, info, j, l, nrowa + integer(${ik}$) :: i, info, j, l, nrowa logical(lk) :: upper ! test the input parameters. @@ -2884,7 +2886,7 @@ module stdlib_linalg_blas_s info = 10 end if if (info/=0) then - call stdlib_xerbla('SSYRK ',info) + call stdlib${ii}$_xerbla('SSYRK ',info) return end if ! quick return if possible. @@ -2999,10 +3001,10 @@ module stdlib_linalg_blas_s end if end if return - end subroutine stdlib_ssyrk + end subroutine stdlib${ii}$_ssyrk - pure subroutine stdlib_stbmv(uplo,trans,diag,n,k,a,lda,x,incx) + pure subroutine stdlib${ii}$_stbmv(uplo,trans,diag,n,k,a,lda,x,incx) !! STBMV 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, @@ -3011,7 +3013,7 @@ module stdlib_linalg_blas_s ! -- 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, k, lda, n + integer(${ik}$), intent(in) :: incx, k, lda, n character, intent(in) :: diag, trans, uplo ! Array Arguments real(sp), intent(in) :: a(lda,*) @@ -3020,7 +3022,7 @@ module stdlib_linalg_blas_s ! Local Scalars real(sp) :: temp - integer(ilp) :: i, info, ix, j, jx, kplus1, kx, l + integer(${ik}$) :: i, info, ix, j, jx, kplus1, kx, l logical(lk) :: nounit ! Intrinsic Functions intrinsic :: max,min @@ -3043,7 +3045,7 @@ module stdlib_linalg_blas_s info = 9 end if if (info/=0) then - call stdlib_xerbla('STBMV ',info) + call stdlib${ii}$_xerbla('STBMV ',info) return end if ! quick return if possible. @@ -3182,10 +3184,10 @@ module stdlib_linalg_blas_s end if end if return - end subroutine stdlib_stbmv + end subroutine stdlib${ii}$_stbmv - pure subroutine stdlib_stbsv(uplo,trans,diag,n,k,a,lda,x,incx) + pure subroutine stdlib${ii}$_stbsv(uplo,trans,diag,n,k,a,lda,x,incx) !! STBSV 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 @@ -3197,7 +3199,7 @@ module stdlib_linalg_blas_s ! -- 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, k, lda, n + integer(${ik}$), intent(in) :: incx, k, lda, n character, intent(in) :: diag, trans, uplo ! Array Arguments real(sp), intent(in) :: a(lda,*) @@ -3206,7 +3208,7 @@ module stdlib_linalg_blas_s ! Local Scalars real(sp) :: temp - integer(ilp) :: i, info, ix, j, jx, kplus1, kx, l + integer(${ik}$) :: i, info, ix, j, jx, kplus1, kx, l logical(lk) :: nounit ! Intrinsic Functions intrinsic :: max,min @@ -3229,7 +3231,7 @@ module stdlib_linalg_blas_s info = 9 end if if (info/=0) then - call stdlib_xerbla('STBSV ',info) + call stdlib${ii}$_xerbla('STBSV ',info) return end if ! quick return if possible. @@ -3368,10 +3370,10 @@ module stdlib_linalg_blas_s end if end if return - end subroutine stdlib_stbsv + end subroutine stdlib${ii}$_stbsv - pure subroutine stdlib_stpmv(uplo,trans,diag,n,ap,x,incx) + pure subroutine stdlib${ii}$_stpmv(uplo,trans,diag,n,ap,x,incx) !! STPMV 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, @@ -3380,7 +3382,7 @@ module stdlib_linalg_blas_s ! -- 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 + integer(${ik}$), intent(in) :: incx, n character, intent(in) :: diag, trans, uplo ! Array Arguments real(sp), intent(in) :: ap(*) @@ -3389,7 +3391,7 @@ module stdlib_linalg_blas_s ! Local Scalars real(sp) :: temp - integer(ilp) :: i, info, ix, j, jx, k, kk, kx + integer(${ik}$) :: i, info, ix, j, jx, k, kk, kx logical(lk) :: nounit ! test the input parameters. info = 0 @@ -3406,7 +3408,7 @@ module stdlib_linalg_blas_s info = 7 end if if (info/=0) then - call stdlib_xerbla('STPMV ',info) + call stdlib${ii}$_xerbla('STPMV ',info) return end if ! quick return if possible. @@ -3550,10 +3552,10 @@ module stdlib_linalg_blas_s end if end if return - end subroutine stdlib_stpmv + end subroutine stdlib${ii}$_stpmv - pure subroutine stdlib_stpsv(uplo,trans,diag,n,ap,x,incx) + pure subroutine stdlib${ii}$_stpsv(uplo,trans,diag,n,ap,x,incx) !! STPSV 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 @@ -3564,7 +3566,7 @@ module stdlib_linalg_blas_s ! -- 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 + integer(${ik}$), intent(in) :: incx, n character, intent(in) :: diag, trans, uplo ! Array Arguments real(sp), intent(in) :: ap(*) @@ -3573,7 +3575,7 @@ module stdlib_linalg_blas_s ! Local Scalars real(sp) :: temp - integer(ilp) :: i, info, ix, j, jx, k, kk, kx + integer(${ik}$) :: i, info, ix, j, jx, k, kk, kx logical(lk) :: nounit ! test the input parameters. info = 0 @@ -3590,7 +3592,7 @@ module stdlib_linalg_blas_s info = 7 end if if (info/=0) then - call stdlib_xerbla('STPSV ',info) + call stdlib${ii}$_xerbla('STPSV ',info) return end if ! quick return if possible. @@ -3734,10 +3736,10 @@ module stdlib_linalg_blas_s end if end if return - end subroutine stdlib_stpsv + end subroutine stdlib${ii}$_stpsv - pure subroutine stdlib_strmm(side,uplo,transa,diag,m,n,alpha,a,lda,b,ldb) + pure subroutine stdlib${ii}$_strmm(side,uplo,transa,diag,m,n,alpha,a,lda,b,ldb) !! STRMM 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 @@ -3748,7 +3750,7 @@ module stdlib_linalg_blas_s ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments real(sp), intent(in) :: alpha - integer(ilp), intent(in) :: lda, ldb, m, n + integer(${ik}$), intent(in) :: lda, ldb, m, n character, intent(in) :: diag, side, transa, uplo ! Array Arguments real(sp), intent(in) :: a(lda,*) @@ -3758,7 +3760,7 @@ module stdlib_linalg_blas_s intrinsic :: max ! Local Scalars real(sp) :: temp - integer(ilp) :: i, info, j, k, nrowa + integer(${ik}$) :: i, info, j, k, nrowa logical(lk) :: lside, nounit, upper ! test the input parameters. @@ -3791,7 +3793,7 @@ module stdlib_linalg_blas_s info = 11 end if if (info/=0) then - call stdlib_xerbla('STRMM ',info) + call stdlib${ii}$_xerbla('STRMM ',info) return end if ! quick return if possible. @@ -3940,10 +3942,10 @@ module stdlib_linalg_blas_s end if end if return - end subroutine stdlib_strmm + end subroutine stdlib${ii}$_strmm - pure subroutine stdlib_strmv(uplo,trans,diag,n,a,lda,x,incx) + pure subroutine stdlib${ii}$_strmv(uplo,trans,diag,n,a,lda,x,incx) !! STRMV 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, @@ -3952,7 +3954,7 @@ module stdlib_linalg_blas_s ! -- 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, lda, n + integer(${ik}$), intent(in) :: incx, lda, n character, intent(in) :: diag, trans, uplo ! Array Arguments real(sp), intent(in) :: a(lda,*) @@ -3961,7 +3963,7 @@ module stdlib_linalg_blas_s ! Local Scalars real(sp) :: temp - integer(ilp) :: i, info, ix, j, jx, kx + integer(${ik}$) :: i, info, ix, j, jx, kx logical(lk) :: nounit ! Intrinsic Functions intrinsic :: max @@ -3982,7 +3984,7 @@ module stdlib_linalg_blas_s info = 8 end if if (info/=0) then - call stdlib_xerbla('STRMV ',info) + call stdlib${ii}$_xerbla('STRMV ',info) return end if ! quick return if possible. @@ -4106,10 +4108,10 @@ module stdlib_linalg_blas_s end if end if return - end subroutine stdlib_strmv + end subroutine stdlib${ii}$_strmv - pure subroutine stdlib_strsm(side,uplo,transa,diag,m,n,alpha,a,lda,b,ldb) + pure subroutine stdlib${ii}$_strsm(side,uplo,transa,diag,m,n,alpha,a,lda,b,ldb) !! STRSM 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 @@ -4121,7 +4123,7 @@ module stdlib_linalg_blas_s ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments real(sp), intent(in) :: alpha - integer(ilp), intent(in) :: lda, ldb, m, n + integer(${ik}$), intent(in) :: lda, ldb, m, n character, intent(in) :: diag, side, transa, uplo ! Array Arguments real(sp), intent(in) :: a(lda,*) @@ -4131,7 +4133,7 @@ module stdlib_linalg_blas_s intrinsic :: max ! Local Scalars real(sp) :: temp - integer(ilp) :: i, info, j, k, nrowa + integer(${ik}$) :: i, info, j, k, nrowa logical(lk) :: lside, nounit, upper ! test the input parameters. @@ -4164,7 +4166,7 @@ module stdlib_linalg_blas_s info = 11 end if if (info/=0) then - call stdlib_xerbla('STRSM ',info) + call stdlib${ii}$_xerbla('STRSM ',info) return end if ! quick return if possible. @@ -4337,10 +4339,10 @@ module stdlib_linalg_blas_s end if end if return - end subroutine stdlib_strsm + end subroutine stdlib${ii}$_strsm - pure subroutine stdlib_strsv(uplo,trans,diag,n,a,lda,x,incx) + pure subroutine stdlib${ii}$_strsv(uplo,trans,diag,n,a,lda,x,incx) !! STRSV 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 @@ -4351,7 +4353,7 @@ module stdlib_linalg_blas_s ! -- 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, lda, n + integer(${ik}$), intent(in) :: incx, lda, n character, intent(in) :: diag, trans, uplo ! Array Arguments real(sp), intent(in) :: a(lda,*) @@ -4360,7 +4362,7 @@ module stdlib_linalg_blas_s ! Local Scalars real(sp) :: temp - integer(ilp) :: i, info, ix, j, jx, kx + integer(${ik}$) :: i, info, ix, j, jx, kx logical(lk) :: nounit ! Intrinsic Functions intrinsic :: max @@ -4381,7 +4383,7 @@ module stdlib_linalg_blas_s info = 8 end if if (info/=0) then - call stdlib_xerbla('STRSV ',info) + call stdlib${ii}$_xerbla('STRSV ',info) return end if ! quick return if possible. @@ -4505,8 +4507,8 @@ module stdlib_linalg_blas_s end if end if return - end subroutine stdlib_strsv - + end subroutine stdlib${ii}$_strsv + #:endfor end module stdlib_linalg_blas_s From b9ff65bc2f186711fa741658c95547e8072dbd18 Mon Sep 17 00:00:00 2001 From: Federico Perini Date: Wed, 13 Nov 2024 18:35:23 +0100 Subject: [PATCH 06/31] `blas_d`: template integer type --- src/stdlib_linalg_blas_d.fypp | 440 +++++++++++++++++----------------- 1 file changed, 221 insertions(+), 219 deletions(-) diff --git a/src/stdlib_linalg_blas_d.fypp b/src/stdlib_linalg_blas_d.fypp index 5602f0d9a..e03e9f7af 100644 --- a/src/stdlib_linalg_blas_d.fypp +++ b/src/stdlib_linalg_blas_d.fypp @@ -8,43 +8,45 @@ module stdlib_linalg_blas_d private - public :: sp,dp,qp,lk,ilp - public :: stdlib_dasum - public :: stdlib_daxpy - public :: stdlib_dcopy - public :: stdlib_ddot - public :: stdlib_dgbmv - public :: stdlib_dgemm - public :: stdlib_dgemv - public :: stdlib_dger - public :: stdlib_dnrm2 - public :: stdlib_drot - public :: stdlib_drotg - public :: stdlib_drotm - public :: stdlib_drotmg - public :: stdlib_dsbmv - public :: stdlib_dscal - public :: stdlib_dsdot - public :: stdlib_dspmv - public :: stdlib_dspr - public :: stdlib_dspr2 - public :: stdlib_dswap - public :: stdlib_dsymm - public :: stdlib_dsymv - public :: stdlib_dsyr - public :: stdlib_dsyr2 - public :: stdlib_dsyr2k - public :: stdlib_dsyrk - public :: stdlib_dtbmv - public :: stdlib_dtbsv - public :: stdlib_dtpmv - public :: stdlib_dtpsv - public :: stdlib_dtrmm - public :: stdlib_dtrmv - public :: stdlib_dtrsm - public :: stdlib_dtrsv - public :: stdlib_dzasum - public :: stdlib_dznrm2 + public :: sp,dp,qp,lk,ilp,ilp64 + #:for ik,it,ii in LINALG_INT_KINDS_TYPES + public :: stdlib${ii}$_dasum + public :: stdlib${ii}$_daxpy + public :: stdlib${ii}$_dcopy + public :: stdlib${ii}$_ddot + public :: stdlib${ii}$_dgbmv + public :: stdlib${ii}$_dgemm + public :: stdlib${ii}$_dgemv + public :: stdlib${ii}$_dger + public :: stdlib${ii}$_dnrm2 + public :: stdlib${ii}$_drot + public :: stdlib${ii}$_drotg + public :: stdlib${ii}$_drotm + public :: stdlib${ii}$_drotmg + public :: stdlib${ii}$_dsbmv + public :: stdlib${ii}$_dscal + public :: stdlib${ii}$_dsdot + public :: stdlib${ii}$_dspmv + public :: stdlib${ii}$_dspr + public :: stdlib${ii}$_dspr2 + public :: stdlib${ii}$_dswap + public :: stdlib${ii}$_dsymm + public :: stdlib${ii}$_dsymv + public :: stdlib${ii}$_dsyr + public :: stdlib${ii}$_dsyr2 + public :: stdlib${ii}$_dsyr2k + public :: stdlib${ii}$_dsyrk + public :: stdlib${ii}$_dtbmv + public :: stdlib${ii}$_dtbsv + public :: stdlib${ii}$_dtpmv + public :: stdlib${ii}$_dtpsv + public :: stdlib${ii}$_dtrmm + public :: stdlib${ii}$_dtrmv + public :: stdlib${ii}$_dtrsm + public :: stdlib${ii}$_dtrsv + public :: stdlib${ii}$_dzasum + public :: stdlib${ii}$_dznrm2 + #:endfor ! 64-bit real constants real(dp), parameter, private :: negone = -1.00_dp @@ -86,23 +88,23 @@ module stdlib_linalg_blas_d contains - - pure real(dp) function stdlib_dasum(n,dx,incx) + #:for ik,it,ii in LINALG_INT_KINDS_TYPES + pure real(dp) function stdlib${ii}$_dasum(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, -- ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments - integer(ilp), intent(in) :: incx, n + integer(${ik}$), intent(in) :: incx, n ! Array Arguments real(dp), intent(in) :: dx(*) ! ===================================================================== ! Local Scalars real(dp) :: dtemp - integer(ilp) :: i, m, mp1, nincx + integer(${ik}$) :: i, m, mp1, nincx ! Intrinsic Functions intrinsic :: abs,mod - stdlib_dasum = zero + stdlib${ii}$_dasum = zero dtemp = zero if (n<=0 .or. incx<=0) return if (incx==1) then @@ -114,7 +116,7 @@ module stdlib_linalg_blas_d dtemp = dtemp + abs(dx(i)) end do if (n<6) then - stdlib_dasum = dtemp + stdlib${ii}$_dasum = dtemp return end if end if @@ -130,12 +132,12 @@ module stdlib_linalg_blas_d dtemp = dtemp + abs(dx(i)) end do end if - stdlib_dasum = dtemp + stdlib${ii}$_dasum = dtemp return - end function stdlib_dasum + end function stdlib${ii}$_dasum - pure subroutine stdlib_daxpy(n,da,dx,incx,dy,incy) + pure subroutine stdlib${ii}$_daxpy(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 -- @@ -143,13 +145,13 @@ module stdlib_linalg_blas_d ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments real(dp), intent(in) :: da - integer(ilp), intent(in) :: incx, incy, n + integer(${ik}$), intent(in) :: incx, incy, n ! Array Arguments real(dp), intent(in) :: dx(*) real(dp), intent(inout) :: dy(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, ix, iy, m, mp1 + integer(${ik}$) :: i, ix, iy, m, mp1 ! Intrinsic Functions intrinsic :: mod if (n<=0) return @@ -185,23 +187,23 @@ module stdlib_linalg_blas_d end do end if return - end subroutine stdlib_daxpy + end subroutine stdlib${ii}$_daxpy - pure subroutine stdlib_dcopy(n,dx,incx,dy,incy) + pure subroutine stdlib${ii}$_dcopy(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 -- ! -- 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, incy, n + integer(${ik}$), intent(in) :: incx, incy, n ! Array Arguments real(dp), intent(in) :: dx(*) real(dp), intent(out) :: dy(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, ix, iy, m, mp1 + integer(${ik}$) :: i, ix, iy, m, mp1 ! Intrinsic Functions intrinsic :: mod if (n<=0) return @@ -239,26 +241,26 @@ module stdlib_linalg_blas_d end do end if return - end subroutine stdlib_dcopy + end subroutine stdlib${ii}$_dcopy - pure real(dp) function stdlib_ddot(n,dx,incx,dy,incy) + pure real(dp) function stdlib${ii}$_ddot(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 -- ! -- 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, incy, n + integer(${ik}$), intent(in) :: incx, incy, n ! Array Arguments real(dp), intent(in) :: dx(*), dy(*) ! ===================================================================== ! Local Scalars real(dp) :: dtemp - integer(ilp) :: i, ix, iy, m, mp1 + integer(${ik}$) :: i, ix, iy, m, mp1 ! Intrinsic Functions intrinsic :: mod - stdlib_ddot = zero + stdlib${ii}$_ddot = zero dtemp = zero if (n<=0) return if (incx==1 .and. incy==1) then @@ -270,7 +272,7 @@ module stdlib_linalg_blas_d dtemp = dtemp + dx(i)*dy(i) end do if (n<5) then - stdlib_ddot=dtemp + stdlib${ii}$_ddot=dtemp return end if end if @@ -292,12 +294,12 @@ module stdlib_linalg_blas_d iy = iy + incy end do end if - stdlib_ddot = dtemp + stdlib${ii}$_ddot = dtemp return - end function stdlib_ddot + end function stdlib${ii}$_ddot - pure subroutine stdlib_dgbmv(trans,m,n,kl,ku,alpha,a,lda,x,incx,beta,y,incy) + pure subroutine stdlib${ii}$_dgbmv(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 @@ -307,7 +309,7 @@ module stdlib_linalg_blas_d ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments real(dp), intent(in) :: alpha, beta - integer(ilp), intent(in) :: incx, incy, kl, ku, lda, m, n + integer(${ik}$), intent(in) :: incx, incy, kl, ku, lda, m, n character, intent(in) :: trans ! Array Arguments real(dp), intent(in) :: a(lda,*), x(*) @@ -316,7 +318,7 @@ module stdlib_linalg_blas_d ! Local Scalars real(dp) :: temp - integer(ilp) :: i, info, ix, iy, j, jx, jy, k, kup1, kx, ky, lenx, leny + integer(${ik}$) :: i, info, ix, iy, j, jx, jy, k, kup1, kx, ky, lenx, leny ! Intrinsic Functions intrinsic :: max,min ! test the input parameters. @@ -340,7 +342,7 @@ module stdlib_linalg_blas_d info = 13 end if if (info/=0) then - call stdlib_xerbla('DGBMV ',info) + call stdlib${ii}$_xerbla('DGBMV ',info) return end if ! quick return if possible. @@ -449,10 +451,10 @@ module stdlib_linalg_blas_d end if end if return - end subroutine stdlib_dgbmv + end subroutine stdlib${ii}$_dgbmv - pure subroutine stdlib_dgemm(transa,transb,m,n,k,alpha,a,lda,b,ldb,beta,c,ldc) + pure subroutine stdlib${ii}$_dgemm(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 @@ -464,7 +466,7 @@ module stdlib_linalg_blas_d ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments real(dp), intent(in) :: alpha, beta - integer(ilp), intent(in) :: k, lda, ldb, ldc, m, n + integer(${ik}$), intent(in) :: k, lda, ldb, ldc, m, n character, intent(in) :: transa, transb ! Array Arguments real(dp), intent(in) :: a(lda,*), b(ldb,*) @@ -474,7 +476,7 @@ module stdlib_linalg_blas_d intrinsic :: max ! Local Scalars real(dp) :: temp - integer(ilp) :: i, info, j, l, nrowa, nrowb + integer(${ik}$) :: i, info, j, l, nrowa, nrowb logical(lk) :: nota, notb ! set nota and notb as true if a and b respectively are not @@ -514,7 +516,7 @@ module stdlib_linalg_blas_d info = 13 end if if (info/=0) then - call stdlib_xerbla('DGEMM ',info) + call stdlib${ii}$_xerbla('DGEMM ',info) return end if ! quick return if possible. @@ -612,10 +614,10 @@ module stdlib_linalg_blas_d end if end if return - end subroutine stdlib_dgemm + end subroutine stdlib${ii}$_dgemm - pure subroutine stdlib_dgemv(trans,m,n,alpha,a,lda,x,incx,beta,y,incy) + pure subroutine stdlib${ii}$_dgemv(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 @@ -625,7 +627,7 @@ module stdlib_linalg_blas_d ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments real(dp), intent(in) :: alpha, beta - integer(ilp), intent(in) :: incx, incy, lda, m, n + integer(${ik}$), intent(in) :: incx, incy, lda, m, n character, intent(in) :: trans ! Array Arguments real(dp), intent(in) :: a(lda,*), x(*) @@ -634,7 +636,7 @@ module stdlib_linalg_blas_d ! Local Scalars real(dp) :: temp - integer(ilp) :: i, info, ix, iy, j, jx, jy, kx, ky, lenx, leny + integer(${ik}$) :: i, info, ix, iy, j, jx, jy, kx, ky, lenx, leny ! Intrinsic Functions intrinsic :: max ! test the input parameters. @@ -654,7 +656,7 @@ module stdlib_linalg_blas_d info = 11 end if if (info/=0) then - call stdlib_xerbla('DGEMV ',info) + call stdlib${ii}$_xerbla('DGEMV ',info) return end if ! quick return if possible. @@ -756,10 +758,10 @@ module stdlib_linalg_blas_d end if end if return - end subroutine stdlib_dgemv + end subroutine stdlib${ii}$_dgemv - pure subroutine stdlib_dger(m,n,alpha,x,incx,y,incy,a,lda) + pure subroutine stdlib${ii}$_dger(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 @@ -769,7 +771,7 @@ module stdlib_linalg_blas_d ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments real(dp), intent(in) :: alpha - integer(ilp), intent(in) :: incx, incy, lda, m, n + integer(${ik}$), intent(in) :: incx, incy, lda, m, n ! Array Arguments real(dp), intent(inout) :: a(lda,*) real(dp), intent(in) :: x(*), y(*) @@ -777,7 +779,7 @@ module stdlib_linalg_blas_d ! Local Scalars real(dp) :: temp - integer(ilp) :: i, info, ix, j, jy, kx + integer(${ik}$) :: i, info, ix, j, jy, kx ! Intrinsic Functions intrinsic :: max ! test the input parameters. @@ -794,7 +796,7 @@ module stdlib_linalg_blas_d info = 9 end if if (info/=0) then - call stdlib_xerbla('DGER ',info) + call stdlib${ii}$_xerbla('DGER ',info) return end if ! quick return if possible. @@ -835,14 +837,14 @@ module stdlib_linalg_blas_d end do end if return - end subroutine stdlib_dger + end subroutine stdlib${ii}$_dger - pure function stdlib_dnrm2( n, x, incx ) + pure function stdlib${ii}$_dnrm2( n, x, incx ) !! DNRM2 returns the euclidean norm of a vector via the function !! name, so that !! DNRM2 := sqrt( x'*x ) - real(dp) :: stdlib_dnrm2 + real(dp) :: stdlib${ii}$_dnrm2 ! -- reference blas level1 routine (version 3.9.1_dp) -- ! -- reference blas is a software package provided by univ. of tennessee, -- ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- @@ -851,15 +853,15 @@ module stdlib_linalg_blas_d real(dp), parameter :: maxn = huge(0.0_dp) ! .. blue's scaling constants .. ! Scalar Arguments - integer(ilp), intent(in) :: incx, n + integer(${ik}$), intent(in) :: incx, n ! Array Arguments real(dp), intent(in) :: x(*) ! Local Scalars - integer(ilp) :: i, ix + integer(${ik}$) :: i, ix logical(lk) :: notbig real(dp) :: abig, amed, asml, ax, scl, sumsq, ymax, ymin ! quick return if possible - stdlib_dnrm2 = zero + stdlib${ii}$_dnrm2 = zero if( n <= 0 ) return scl = one sumsq = zero @@ -920,25 +922,25 @@ module stdlib_linalg_blas_d scl = one sumsq = amed end if - stdlib_dnrm2 = scl*sqrt( sumsq ) + stdlib${ii}$_dnrm2 = scl*sqrt( sumsq ) return - end function stdlib_dnrm2 + end function stdlib${ii}$_dnrm2 - pure subroutine stdlib_drot(n,dx,incx,dy,incy,c,s) + pure subroutine stdlib${ii}$_drot(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(dp), intent(in) :: c, s - integer(ilp), intent(in) :: incx, incy, n + integer(${ik}$), intent(in) :: incx, incy, n ! Array Arguments real(dp), intent(inout) :: dx(*), dy(*) ! ===================================================================== ! Local Scalars real(dp) :: dtemp - integer(ilp) :: i, ix, iy + integer(${ik}$) :: i, ix, iy if (n<=0) return if (incx==1 .and. incy==1) then ! code for both increments equal to 1 @@ -963,10 +965,10 @@ module stdlib_linalg_blas_d end do end if return - end subroutine stdlib_drot + end subroutine stdlib${ii}$_drot - pure subroutine stdlib_drotg( a, b, c, s ) + pure subroutine stdlib${ii}$_drotg( a, b, c, s ) !! The computation uses the formulas !! sigma = sgn(a) if |a| > |b| !! = sgn(b) if |b| >= |a| @@ -1022,10 +1024,10 @@ module stdlib_linalg_blas_d b = z end if return - end subroutine stdlib_drotg + end subroutine stdlib${ii}$_drotg - pure subroutine stdlib_drotm(n,dx,incx,dy,incy,dparam) + pure subroutine stdlib${ii}$_drotm(n,dx,incx,dy,incy,dparam) !! DROTM 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 @@ -1041,14 +1043,14 @@ module stdlib_linalg_blas_d ! -- 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, incy, n + integer(${ik}$), intent(in) :: incx, incy, n ! Array Arguments real(dp), intent(in) :: dparam(5) real(dp), intent(inout) :: dx(*), dy(*) ! ===================================================================== ! Local Scalars real(dp) :: dflag, dh11, dh12, dh21, dh22, two, w, z, zero - integer(ilp) :: i, kx, ky, nsteps + integer(${ik}$) :: i, kx, ky, nsteps ! Data Statements zero = 0.0_dp two = 2.0_dp @@ -1129,10 +1131,10 @@ module stdlib_linalg_blas_d end if end if return - end subroutine stdlib_drotm + end subroutine stdlib${ii}$_drotm - pure subroutine stdlib_drotmg(dd1,dd2,dx1,dy1,dparam) + pure subroutine stdlib${ii}$_drotmg(dd1,dd2,dx1,dy1,dparam) !! DROTMG 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. $$ @@ -1294,10 +1296,10 @@ module stdlib_linalg_blas_d end if dparam(1) = dflag return - end subroutine stdlib_drotmg + end subroutine stdlib${ii}$_drotmg - pure subroutine stdlib_dsbmv(uplo,n,k,alpha,a,lda,x,incx,beta,y,incy) + pure subroutine stdlib${ii}$_dsbmv(uplo,n,k,alpha,a,lda,x,incx,beta,y,incy) !! DSBMV 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 @@ -1307,7 +1309,7 @@ module stdlib_linalg_blas_d ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments real(dp), intent(in) :: alpha, beta - integer(ilp), intent(in) :: incx, incy, k, lda, n + integer(${ik}$), intent(in) :: incx, incy, k, lda, n character, intent(in) :: uplo ! Array Arguments real(dp), intent(in) :: a(lda,*), x(*) @@ -1316,7 +1318,7 @@ module stdlib_linalg_blas_d ! Local Scalars real(dp) :: temp1, temp2 - integer(ilp) :: i, info, ix, iy, j, jx, jy, kplus1, kx, ky, l + integer(${ik}$) :: i, info, ix, iy, j, jx, jy, kplus1, kx, ky, l ! Intrinsic Functions intrinsic :: max,min ! test the input parameters. @@ -1335,7 +1337,7 @@ module stdlib_linalg_blas_d info = 11 end if if (info/=0) then - call stdlib_xerbla('DSBMV ',info) + call stdlib${ii}$_xerbla('DSBMV ',info) return end if ! quick return if possible. @@ -1456,10 +1458,10 @@ module stdlib_linalg_blas_d end if end if return - end subroutine stdlib_dsbmv + end subroutine stdlib${ii}$_dsbmv - pure subroutine stdlib_dscal(n,da,dx,incx) + pure subroutine stdlib${ii}$_dscal(n,da,dx,incx) !! DSCAL scales a vector by a constant. !! uses unrolled loops for increment equal to 1. ! -- reference blas level1 routine -- @@ -1467,12 +1469,12 @@ module stdlib_linalg_blas_d ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments real(dp), intent(in) :: da - integer(ilp), intent(in) :: incx, n + integer(${ik}$), intent(in) :: incx, n ! Array Arguments real(dp), intent(inout) :: dx(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, m, mp1, nincx + integer(${ik}$) :: i, m, mp1, nincx ! Intrinsic Functions intrinsic :: mod if (n<=0 .or. incx<=0) return @@ -1502,10 +1504,10 @@ module stdlib_linalg_blas_d end do end if return - end subroutine stdlib_dscal + end subroutine stdlib${ii}$_dscal - pure real(dp) function stdlib_dsdot(n,sx,incx,sy,incy) + pure real(dp) function stdlib${ii}$_dsdot(n,sx,incx,sy,incy) !! Compute the inner product of two vectors with extended !! precision accumulation and result. !! Returns D.P. dot product accumulated in D.P., for S.P. SX and SY @@ -1516,7 +1518,7 @@ module stdlib_linalg_blas_d ! -- 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, incy, n + integer(${ik}$), intent(in) :: incx, incy, n ! Array Arguments real(sp), intent(in) :: sx(*), sy(*) ! authors: @@ -1525,16 +1527,16 @@ module stdlib_linalg_blas_d ! kincaid, d. r., (u. of texas), krogh, f. t., (jpl) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, kx, ky, ns + integer(${ik}$) :: i, kx, ky, ns ! Intrinsic Functions intrinsic :: real - stdlib_dsdot = zero + stdlib${ii}$_dsdot = zero if (n<=0) return if (incx==incy .and. incx>0) then ! code for equal, positive, non-unit increments. ns = n*incx do i = 1,ns,incx - stdlib_dsdot = stdlib_dsdot + real(sx(i),KIND=dp)*real(sy(i),KIND=dp) + stdlib${ii}$_dsdot = stdlib${ii}$_dsdot + real(sx(i),KIND=dp)*real(sy(i),KIND=dp) end do else ! code for unequal or nonpositive increments. @@ -1543,16 +1545,16 @@ module stdlib_linalg_blas_d if (incx<0) kx = 1 + (1-n)*incx if (incy<0) ky = 1 + (1-n)*incy do i = 1,n - stdlib_dsdot = stdlib_dsdot + real(sx(kx),KIND=dp)*real(sy(ky),KIND=dp) + stdlib${ii}$_dsdot = stdlib${ii}$_dsdot + real(sx(kx),KIND=dp)*real(sy(ky),KIND=dp) kx = kx + incx ky = ky + incy end do end if return - end function stdlib_dsdot + end function stdlib${ii}$_dsdot - pure subroutine stdlib_dspmv(uplo,n,alpha,ap,x,incx,beta,y,incy) + pure subroutine stdlib${ii}$_dspmv(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 @@ -1562,7 +1564,7 @@ module stdlib_linalg_blas_d ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments real(dp), intent(in) :: alpha, beta - integer(ilp), intent(in) :: incx, incy, n + integer(${ik}$), intent(in) :: incx, incy, n character, intent(in) :: uplo ! Array Arguments real(dp), intent(in) :: ap(*), x(*) @@ -1571,7 +1573,7 @@ module stdlib_linalg_blas_d ! Local Scalars real(dp) :: temp1, temp2 - integer(ilp) :: i, info, ix, iy, j, jx, jy, k, kk, kx, ky + integer(${ik}$) :: i, info, ix, iy, j, jx, jy, k, kk, kx, ky ! test the input parameters. info = 0 if (.not.stdlib_lsame(uplo,'U') .and. .not.stdlib_lsame(uplo,'L')) then @@ -1584,7 +1586,7 @@ module stdlib_linalg_blas_d info = 9 end if if (info/=0) then - call stdlib_xerbla('DSPMV ',info) + call stdlib${ii}$_xerbla('DSPMV ',info) return end if ! quick return if possible. @@ -1705,10 +1707,10 @@ module stdlib_linalg_blas_d end if end if return - end subroutine stdlib_dspmv + end subroutine stdlib${ii}$_dspmv - pure subroutine stdlib_dspr(uplo,n,alpha,x,incx,ap) + pure subroutine stdlib${ii}$_dspr(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 @@ -1718,7 +1720,7 @@ module stdlib_linalg_blas_d ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments real(dp), intent(in) :: alpha - integer(ilp), intent(in) :: incx, n + integer(${ik}$), intent(in) :: incx, n character, intent(in) :: uplo ! Array Arguments real(dp), intent(inout) :: ap(*) @@ -1727,7 +1729,7 @@ module stdlib_linalg_blas_d ! Local Scalars real(dp) :: temp - integer(ilp) :: i, info, ix, j, jx, k, kk, kx + integer(${ik}$) :: i, info, ix, j, jx, k, kk, kx ! test the input parameters. info = 0 if (.not.stdlib_lsame(uplo,'U') .and. .not.stdlib_lsame(uplo,'L')) then @@ -1738,7 +1740,7 @@ module stdlib_linalg_blas_d info = 5 end if if (info/=0) then - call stdlib_xerbla('DSPR ',info) + call stdlib${ii}$_xerbla('DSPR ',info) return end if ! quick return if possible. @@ -1812,10 +1814,10 @@ module stdlib_linalg_blas_d end if end if return - end subroutine stdlib_dspr + end subroutine stdlib${ii}$_dspr - pure subroutine stdlib_dspr2(uplo,n,alpha,x,incx,y,incy,ap) + pure subroutine stdlib${ii}$_dspr2(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 @@ -1825,7 +1827,7 @@ module stdlib_linalg_blas_d ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments real(dp), intent(in) :: alpha - integer(ilp), intent(in) :: incx, incy, n + integer(${ik}$), intent(in) :: incx, incy, n character, intent(in) :: uplo ! Array Arguments real(dp), intent(inout) :: ap(*) @@ -1834,7 +1836,7 @@ module stdlib_linalg_blas_d ! Local Scalars real(dp) :: temp1, temp2 - integer(ilp) :: i, info, ix, iy, j, jx, jy, k, kk, kx, ky + integer(${ik}$) :: i, info, ix, iy, j, jx, jy, k, kk, kx, ky ! test the input parameters. info = 0 if (.not.stdlib_lsame(uplo,'U') .and. .not.stdlib_lsame(uplo,'L')) then @@ -1847,7 +1849,7 @@ module stdlib_linalg_blas_d info = 7 end if if (info/=0) then - call stdlib_xerbla('DSPR2 ',info) + call stdlib${ii}$_xerbla('DSPR2 ',info) return end if ! quick return if possible. @@ -1939,23 +1941,23 @@ module stdlib_linalg_blas_d end if end if return - end subroutine stdlib_dspr2 + end subroutine stdlib${ii}$_dspr2 - pure subroutine stdlib_dswap(n,dx,incx,dy,incy) + pure subroutine stdlib${ii}$_dswap(n,dx,incx,dy,incy) !! DSWAP interchanges two vectors. !! uses unrolled loops for increments equal to 1. ! -- 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, incy, n + integer(${ik}$), intent(in) :: incx, incy, n ! Array Arguments real(dp), intent(inout) :: dx(*), dy(*) ! ===================================================================== ! Local Scalars real(dp) :: dtemp - integer(ilp) :: i, ix, iy, m, mp1 + integer(${ik}$) :: i, ix, iy, m, mp1 ! Intrinsic Functions intrinsic :: mod if (n<=0) return @@ -1999,10 +2001,10 @@ module stdlib_linalg_blas_d end do end if return - end subroutine stdlib_dswap + end subroutine stdlib${ii}$_dswap - pure subroutine stdlib_dsymm(side,uplo,m,n,alpha,a,lda,b,ldb,beta,c,ldc) + pure subroutine stdlib${ii}$_dsymm(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 @@ -2014,7 +2016,7 @@ module stdlib_linalg_blas_d ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments real(dp), intent(in) :: alpha, beta - integer(ilp), intent(in) :: lda, ldb, ldc, m, n + integer(${ik}$), intent(in) :: lda, ldb, ldc, m, n character, intent(in) :: side, uplo ! Array Arguments real(dp), intent(in) :: a(lda,*), b(ldb,*) @@ -2024,7 +2026,7 @@ module stdlib_linalg_blas_d intrinsic :: max ! Local Scalars real(dp) :: temp1, temp2 - integer(ilp) :: i, info, j, k, nrowa + integer(${ik}$) :: i, info, j, k, nrowa logical(lk) :: upper ! set nrowa as the number of rows of a. @@ -2052,7 +2054,7 @@ module stdlib_linalg_blas_d info = 12 end if if (info/=0) then - call stdlib_xerbla('DSYMM ',info) + call stdlib${ii}$_xerbla('DSYMM ',info) return end if ! quick return if possible. @@ -2146,10 +2148,10 @@ module stdlib_linalg_blas_d end do loop_170 end if return - end subroutine stdlib_dsymm + end subroutine stdlib${ii}$_dsymm - pure subroutine stdlib_dsymv(uplo,n,alpha,a,lda,x,incx,beta,y,incy) + pure subroutine stdlib${ii}$_dsymv(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 @@ -2159,7 +2161,7 @@ module stdlib_linalg_blas_d ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments real(dp), intent(in) :: alpha, beta - integer(ilp), intent(in) :: incx, incy, lda, n + integer(${ik}$), intent(in) :: incx, incy, lda, n character, intent(in) :: uplo ! Array Arguments real(dp), intent(in) :: a(lda,*), x(*) @@ -2168,7 +2170,7 @@ module stdlib_linalg_blas_d ! Local Scalars real(dp) :: temp1, temp2 - integer(ilp) :: i, info, ix, iy, j, jx, jy, kx, ky + integer(${ik}$) :: i, info, ix, iy, j, jx, jy, kx, ky ! Intrinsic Functions intrinsic :: max ! test the input parameters. @@ -2185,7 +2187,7 @@ module stdlib_linalg_blas_d info = 10 end if if (info/=0) then - call stdlib_xerbla('DSYMV ',info) + call stdlib${ii}$_xerbla('DSYMV ',info) return end if ! quick return if possible. @@ -2298,10 +2300,10 @@ module stdlib_linalg_blas_d end if end if return - end subroutine stdlib_dsymv + end subroutine stdlib${ii}$_dsymv - pure subroutine stdlib_dsyr(uplo,n,alpha,x,incx,a,lda) + pure subroutine stdlib${ii}$_dsyr(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 @@ -2311,7 +2313,7 @@ module stdlib_linalg_blas_d ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments real(dp), intent(in) :: alpha - integer(ilp), intent(in) :: incx, lda, n + integer(${ik}$), intent(in) :: incx, lda, n character, intent(in) :: uplo ! Array Arguments real(dp), intent(inout) :: a(lda,*) @@ -2320,7 +2322,7 @@ module stdlib_linalg_blas_d ! Local Scalars real(dp) :: temp - integer(ilp) :: i, info, ix, j, jx, kx + integer(${ik}$) :: i, info, ix, j, jx, kx ! Intrinsic Functions intrinsic :: max ! test the input parameters. @@ -2335,7 +2337,7 @@ module stdlib_linalg_blas_d info = 7 end if if (info/=0) then - call stdlib_xerbla('DSYR ',info) + call stdlib${ii}$_xerbla('DSYR ',info) return end if ! quick return if possible. @@ -2401,10 +2403,10 @@ module stdlib_linalg_blas_d end if end if return - end subroutine stdlib_dsyr + end subroutine stdlib${ii}$_dsyr - pure subroutine stdlib_dsyr2(uplo,n,alpha,x,incx,y,incy,a,lda) + pure subroutine stdlib${ii}$_dsyr2(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 @@ -2414,7 +2416,7 @@ module stdlib_linalg_blas_d ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments real(dp), intent(in) :: alpha - integer(ilp), intent(in) :: incx, incy, lda, n + integer(${ik}$), intent(in) :: incx, incy, lda, n character, intent(in) :: uplo ! Array Arguments real(dp), intent(inout) :: a(lda,*) @@ -2423,7 +2425,7 @@ module stdlib_linalg_blas_d ! Local Scalars real(dp) :: temp1, temp2 - integer(ilp) :: i, info, ix, iy, j, jx, jy, kx, ky + integer(${ik}$) :: i, info, ix, iy, j, jx, jy, kx, ky ! Intrinsic Functions intrinsic :: max ! test the input parameters. @@ -2440,7 +2442,7 @@ module stdlib_linalg_blas_d info = 9 end if if (info/=0) then - call stdlib_xerbla('DSYR2 ',info) + call stdlib${ii}$_xerbla('DSYR2 ',info) return end if ! quick return if possible. @@ -2524,10 +2526,10 @@ module stdlib_linalg_blas_d end if end if return - end subroutine stdlib_dsyr2 + end subroutine stdlib${ii}$_dsyr2 - pure subroutine stdlib_dsyr2k(uplo,trans,n,k,alpha,a,lda,b,ldb,beta,c,ldc) + pure subroutine stdlib${ii}$_dsyr2k(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 @@ -2540,7 +2542,7 @@ module stdlib_linalg_blas_d ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments real(dp), intent(in) :: alpha, beta - integer(ilp), intent(in) :: k, lda, ldb, ldc, n + integer(${ik}$), intent(in) :: k, lda, ldb, ldc, n character, intent(in) :: trans, uplo ! Array Arguments real(dp), intent(in) :: a(lda,*), b(ldb,*) @@ -2550,7 +2552,7 @@ module stdlib_linalg_blas_d intrinsic :: max ! Local Scalars real(dp) :: temp1, temp2 - integer(ilp) :: i, info, j, l, nrowa + integer(${ik}$) :: i, info, j, l, nrowa logical(lk) :: upper ! test the input parameters. @@ -2578,7 +2580,7 @@ module stdlib_linalg_blas_d info = 12 end if if (info/=0) then - call stdlib_xerbla('DSYR2K',info) + call stdlib${ii}$_xerbla('DSYR2K',info) return end if ! quick return if possible. @@ -2699,10 +2701,10 @@ module stdlib_linalg_blas_d end if end if return - end subroutine stdlib_dsyr2k + end subroutine stdlib${ii}$_dsyr2k - pure subroutine stdlib_dsyrk(uplo,trans,n,k,alpha,a,lda,beta,c,ldc) + pure subroutine stdlib${ii}$_dsyrk(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 @@ -2715,7 +2717,7 @@ module stdlib_linalg_blas_d ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments real(dp), intent(in) :: alpha, beta - integer(ilp), intent(in) :: k, lda, ldc, n + integer(${ik}$), intent(in) :: k, lda, ldc, n character, intent(in) :: trans, uplo ! Array Arguments real(dp), intent(in) :: a(lda,*) @@ -2725,7 +2727,7 @@ module stdlib_linalg_blas_d intrinsic :: max ! Local Scalars real(dp) :: temp - integer(ilp) :: i, info, j, l, nrowa + integer(${ik}$) :: i, info, j, l, nrowa logical(lk) :: upper ! test the input parameters. @@ -2751,7 +2753,7 @@ module stdlib_linalg_blas_d info = 10 end if if (info/=0) then - call stdlib_xerbla('DSYRK ',info) + call stdlib${ii}$_xerbla('DSYRK ',info) return end if ! quick return if possible. @@ -2866,10 +2868,10 @@ module stdlib_linalg_blas_d end if end if return - end subroutine stdlib_dsyrk + end subroutine stdlib${ii}$_dsyrk - pure subroutine stdlib_dtbmv(uplo,trans,diag,n,k,a,lda,x,incx) + pure subroutine stdlib${ii}$_dtbmv(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, @@ -2878,7 +2880,7 @@ module stdlib_linalg_blas_d ! -- 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, k, lda, n + integer(${ik}$), intent(in) :: incx, k, lda, n character, intent(in) :: diag, trans, uplo ! Array Arguments real(dp), intent(in) :: a(lda,*) @@ -2887,7 +2889,7 @@ module stdlib_linalg_blas_d ! Local Scalars real(dp) :: temp - integer(ilp) :: i, info, ix, j, jx, kplus1, kx, l + integer(${ik}$) :: i, info, ix, j, jx, kplus1, kx, l logical(lk) :: nounit ! Intrinsic Functions intrinsic :: max,min @@ -2910,7 +2912,7 @@ module stdlib_linalg_blas_d info = 9 end if if (info/=0) then - call stdlib_xerbla('DTBMV ',info) + call stdlib${ii}$_xerbla('DTBMV ',info) return end if ! quick return if possible. @@ -3049,10 +3051,10 @@ module stdlib_linalg_blas_d end if end if return - end subroutine stdlib_dtbmv + end subroutine stdlib${ii}$_dtbmv - pure subroutine stdlib_dtbsv(uplo,trans,diag,n,k,a,lda,x,incx) + pure subroutine stdlib${ii}$_dtbsv(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 @@ -3064,7 +3066,7 @@ module stdlib_linalg_blas_d ! -- 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, k, lda, n + integer(${ik}$), intent(in) :: incx, k, lda, n character, intent(in) :: diag, trans, uplo ! Array Arguments real(dp), intent(in) :: a(lda,*) @@ -3073,7 +3075,7 @@ module stdlib_linalg_blas_d ! Local Scalars real(dp) :: temp - integer(ilp) :: i, info, ix, j, jx, kplus1, kx, l + integer(${ik}$) :: i, info, ix, j, jx, kplus1, kx, l logical(lk) :: nounit ! Intrinsic Functions intrinsic :: max,min @@ -3096,7 +3098,7 @@ module stdlib_linalg_blas_d info = 9 end if if (info/=0) then - call stdlib_xerbla('DTBSV ',info) + call stdlib${ii}$_xerbla('DTBSV ',info) return end if ! quick return if possible. @@ -3235,10 +3237,10 @@ module stdlib_linalg_blas_d end if end if return - end subroutine stdlib_dtbsv + end subroutine stdlib${ii}$_dtbsv - pure subroutine stdlib_dtpmv(uplo,trans,diag,n,ap,x,incx) + pure subroutine stdlib${ii}$_dtpmv(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, @@ -3247,7 +3249,7 @@ module stdlib_linalg_blas_d ! -- 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 + integer(${ik}$), intent(in) :: incx, n character, intent(in) :: diag, trans, uplo ! Array Arguments real(dp), intent(in) :: ap(*) @@ -3256,7 +3258,7 @@ module stdlib_linalg_blas_d ! Local Scalars real(dp) :: temp - integer(ilp) :: i, info, ix, j, jx, k, kk, kx + integer(${ik}$) :: i, info, ix, j, jx, k, kk, kx logical(lk) :: nounit ! test the input parameters. info = 0 @@ -3273,7 +3275,7 @@ module stdlib_linalg_blas_d info = 7 end if if (info/=0) then - call stdlib_xerbla('DTPMV ',info) + call stdlib${ii}$_xerbla('DTPMV ',info) return end if ! quick return if possible. @@ -3417,10 +3419,10 @@ module stdlib_linalg_blas_d end if end if return - end subroutine stdlib_dtpmv + end subroutine stdlib${ii}$_dtpmv - pure subroutine stdlib_dtpsv(uplo,trans,diag,n,ap,x,incx) + pure subroutine stdlib${ii}$_dtpsv(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 @@ -3431,7 +3433,7 @@ module stdlib_linalg_blas_d ! -- 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 + integer(${ik}$), intent(in) :: incx, n character, intent(in) :: diag, trans, uplo ! Array Arguments real(dp), intent(in) :: ap(*) @@ -3440,7 +3442,7 @@ module stdlib_linalg_blas_d ! Local Scalars real(dp) :: temp - integer(ilp) :: i, info, ix, j, jx, k, kk, kx + integer(${ik}$) :: i, info, ix, j, jx, k, kk, kx logical(lk) :: nounit ! test the input parameters. info = 0 @@ -3457,7 +3459,7 @@ module stdlib_linalg_blas_d info = 7 end if if (info/=0) then - call stdlib_xerbla('DTPSV ',info) + call stdlib${ii}$_xerbla('DTPSV ',info) return end if ! quick return if possible. @@ -3601,10 +3603,10 @@ module stdlib_linalg_blas_d end if end if return - end subroutine stdlib_dtpsv + end subroutine stdlib${ii}$_dtpsv - pure subroutine stdlib_dtrmm(side,uplo,transa,diag,m,n,alpha,a,lda,b,ldb) + pure subroutine stdlib${ii}$_dtrmm(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 @@ -3615,7 +3617,7 @@ module stdlib_linalg_blas_d ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments real(dp), intent(in) :: alpha - integer(ilp), intent(in) :: lda, ldb, m, n + integer(${ik}$), intent(in) :: lda, ldb, m, n character, intent(in) :: diag, side, transa, uplo ! Array Arguments real(dp), intent(in) :: a(lda,*) @@ -3625,7 +3627,7 @@ module stdlib_linalg_blas_d intrinsic :: max ! Local Scalars real(dp) :: temp - integer(ilp) :: i, info, j, k, nrowa + integer(${ik}$) :: i, info, j, k, nrowa logical(lk) :: lside, nounit, upper ! test the input parameters. @@ -3658,7 +3660,7 @@ module stdlib_linalg_blas_d info = 11 end if if (info/=0) then - call stdlib_xerbla('DTRMM ',info) + call stdlib${ii}$_xerbla('DTRMM ',info) return end if ! quick return if possible. @@ -3807,10 +3809,10 @@ module stdlib_linalg_blas_d end if end if return - end subroutine stdlib_dtrmm + end subroutine stdlib${ii}$_dtrmm - pure subroutine stdlib_dtrmv(uplo,trans,diag,n,a,lda,x,incx) + pure subroutine stdlib${ii}$_dtrmv(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, @@ -3819,7 +3821,7 @@ module stdlib_linalg_blas_d ! -- 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, lda, n + integer(${ik}$), intent(in) :: incx, lda, n character, intent(in) :: diag, trans, uplo ! Array Arguments real(dp), intent(in) :: a(lda,*) @@ -3828,7 +3830,7 @@ module stdlib_linalg_blas_d ! Local Scalars real(dp) :: temp - integer(ilp) :: i, info, ix, j, jx, kx + integer(${ik}$) :: i, info, ix, j, jx, kx logical(lk) :: nounit ! Intrinsic Functions intrinsic :: max @@ -3849,7 +3851,7 @@ module stdlib_linalg_blas_d info = 8 end if if (info/=0) then - call stdlib_xerbla('DTRMV ',info) + call stdlib${ii}$_xerbla('DTRMV ',info) return end if ! quick return if possible. @@ -3973,10 +3975,10 @@ module stdlib_linalg_blas_d end if end if return - end subroutine stdlib_dtrmv + end subroutine stdlib${ii}$_dtrmv - pure subroutine stdlib_dtrsm(side,uplo,transa,diag,m,n,alpha,a,lda,b,ldb) + pure subroutine stdlib${ii}$_dtrsm(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 @@ -3988,7 +3990,7 @@ module stdlib_linalg_blas_d ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments real(dp), intent(in) :: alpha - integer(ilp), intent(in) :: lda, ldb, m, n + integer(${ik}$), intent(in) :: lda, ldb, m, n character, intent(in) :: diag, side, transa, uplo ! Array Arguments real(dp), intent(in) :: a(lda,*) @@ -3998,7 +4000,7 @@ module stdlib_linalg_blas_d intrinsic :: max ! Local Scalars real(dp) :: temp - integer(ilp) :: i, info, j, k, nrowa + integer(${ik}$) :: i, info, j, k, nrowa logical(lk) :: lside, nounit, upper ! test the input parameters. @@ -4031,7 +4033,7 @@ module stdlib_linalg_blas_d info = 11 end if if (info/=0) then - call stdlib_xerbla('DTRSM ',info) + call stdlib${ii}$_xerbla('DTRSM ',info) return end if ! quick return if possible. @@ -4204,10 +4206,10 @@ module stdlib_linalg_blas_d end if end if return - end subroutine stdlib_dtrsm + end subroutine stdlib${ii}$_dtrsm - pure subroutine stdlib_dtrsv(uplo,trans,diag,n,a,lda,x,incx) + pure subroutine stdlib${ii}$_dtrsv(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 @@ -4218,7 +4220,7 @@ module stdlib_linalg_blas_d ! -- 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, lda, n + integer(${ik}$), intent(in) :: incx, lda, n character, intent(in) :: diag, trans, uplo ! Array Arguments real(dp), intent(in) :: a(lda,*) @@ -4227,7 +4229,7 @@ module stdlib_linalg_blas_d ! Local Scalars real(dp) :: temp - integer(ilp) :: i, info, ix, j, jx, kx + integer(${ik}$) :: i, info, ix, j, jx, kx logical(lk) :: nounit ! Intrinsic Functions intrinsic :: max @@ -4248,7 +4250,7 @@ module stdlib_linalg_blas_d info = 8 end if if (info/=0) then - call stdlib_xerbla('DTRSV ',info) + call stdlib${ii}$_xerbla('DTRSV ',info) return end if ! quick return if possible. @@ -4372,24 +4374,24 @@ module stdlib_linalg_blas_d end if end if return - end subroutine stdlib_dtrsv + end subroutine stdlib${ii}$_dtrsv - pure real(dp) function stdlib_dzasum(n,zx,incx) + pure real(dp) function stdlib${ii}$_dzasum(n,zx,incx) !! DZASUM takes the sum of the (|Re(.)| + |Im(.)|)'s of a complex vector and !! returns a double precision result. ! -- 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 + integer(${ik}$), intent(in) :: incx, n ! Array Arguments complex(dp), intent(in) :: zx(*) ! ===================================================================== ! Local Scalars real(dp) :: stemp - integer(ilp) :: i, nincx - stdlib_dzasum = zero + integer(${ik}$) :: i, nincx + stdlib${ii}$_dzasum = zero stemp = zero if (n<=0 .or. incx<=0) return if (incx==1) then @@ -4404,16 +4406,16 @@ module stdlib_linalg_blas_d stemp = stemp + stdlib_cabs1(zx(i)) end do end if - stdlib_dzasum = stemp + stdlib${ii}$_dzasum = stemp return - end function stdlib_dzasum + end function stdlib${ii}$_dzasum - pure function stdlib_dznrm2( n, x, incx ) + pure function stdlib${ii}$_dznrm2( n, x, incx ) !! DZNRM2 returns the euclidean norm of a vector via the function !! name, so that !! DZNRM2 := sqrt( x**H*x ) - real(dp) :: stdlib_dznrm2 + real(dp) :: stdlib${ii}$_dznrm2 ! -- reference blas level1 routine (version 3.9.1_dp) -- ! -- reference blas is a software package provided by univ. of tennessee, -- ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- @@ -4422,15 +4424,15 @@ module stdlib_linalg_blas_d real(dp), parameter :: maxn = huge(0.0_dp) ! .. blue's scaling constants .. ! Scalar Arguments - integer(ilp), intent(in) :: incx, n + integer(${ik}$), intent(in) :: incx, n ! Array Arguments complex(dp), intent(in) :: x(*) ! Local Scalars - integer(ilp) :: i, ix - logical(lk) :: notbig + integer(${ik}$) :: i, ix + logical(lk) :: notbig real(dp) :: abig, amed, asml, ax, scl, sumsq, ymax, ymin ! quick return if possible - stdlib_dznrm2 = zero + stdlib${ii}$_dznrm2 = zero if( n <= 0 ) return scl = one sumsq = zero @@ -4500,10 +4502,10 @@ module stdlib_linalg_blas_d scl = one sumsq = amed end if - stdlib_dznrm2 = scl*sqrt( sumsq ) + stdlib${ii}$_dznrm2 = scl*sqrt( sumsq ) return - end function stdlib_dznrm2 - + end function stdlib${ii}$_dznrm2 + #:endfor end module stdlib_linalg_blas_d From 2cb842262445b4db1518b90a912c6b0732fb155b Mon Sep 17 00:00:00 2001 From: Federico Perini Date: Wed, 13 Nov 2024 18:38:06 +0100 Subject: [PATCH 07/31] `blas_q`: template integer type --- src/stdlib_linalg_blas_q.fypp | 440 +++++++++++++++++----------------- 1 file changed, 222 insertions(+), 218 deletions(-) diff --git a/src/stdlib_linalg_blas_q.fypp b/src/stdlib_linalg_blas_q.fypp index 7da2e2f5a..7ba930c9d 100644 --- a/src/stdlib_linalg_blas_q.fypp +++ b/src/stdlib_linalg_blas_q.fypp @@ -12,43 +12,45 @@ module stdlib_linalg_blas_${ri}$ private - 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 + public :: sp,dp,${rk}$,lk,ilp,ilp64 + #:for ik,it,ii in LINALG_INT_KINDS_TYPES + public :: stdlib${ii}$_${ri}$asum + public :: stdlib${ii}$_${ri}$axpy + public :: stdlib${ii}$_${ri}$copy + public :: stdlib${ii}$_${ri}$dot + public :: stdlib${ii}$_${ri}$gbmv + public :: stdlib${ii}$_${ri}$gemm + public :: stdlib${ii}$_${ri}$gemv + public :: stdlib${ii}$_${ri}$ger + public :: stdlib${ii}$_${ri}$nrm2 + public :: stdlib${ii}$_${ri}$rot + public :: stdlib${ii}$_${ri}$rotg + public :: stdlib${ii}$_${ri}$rotm + public :: stdlib${ii}$_${ri}$rotmg + public :: stdlib${ii}$_${ri}$sbmv + public :: stdlib${ii}$_${ri}$scal + public :: stdlib${ii}$_${ri}$sdot + public :: stdlib${ii}$_${ri}$spmv + public :: stdlib${ii}$_${ri}$spr + public :: stdlib${ii}$_${ri}$spr2 + public :: stdlib${ii}$_${ri}$swap + public :: stdlib${ii}$_${ri}$symm + public :: stdlib${ii}$_${ri}$symv + public :: stdlib${ii}$_${ri}$syr + public :: stdlib${ii}$_${ri}$syr2 + public :: stdlib${ii}$_${ri}$syr2k + public :: stdlib${ii}$_${ri}$syrk + public :: stdlib${ii}$_${ri}$tbmv + public :: stdlib${ii}$_${ri}$tbsv + public :: stdlib${ii}$_${ri}$tpmv + public :: stdlib${ii}$_${ri}$tpsv + public :: stdlib${ii}$_${ri}$trmm + public :: stdlib${ii}$_${ri}$trmv + public :: stdlib${ii}$_${ri}$trsm + public :: stdlib${ii}$_${ri}$trsv + public :: stdlib${ii}$_${ri}$zasum + public :: stdlib${ii}$_${ri}$znrm2 + #:endfor ! 128-bit real constants real(${rk}$), parameter, private :: negone = -1.00_${rk}$ @@ -90,23 +92,23 @@ module stdlib_linalg_blas_${ri}$ contains - - pure real(${rk}$) function stdlib_${ri}$asum(n,dx,incx) + #:for ik,it,ii in LINALG_INT_KINDS_TYPES + pure real(${rk}$) function stdlib${ii}$_${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, -- ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments - integer(ilp), intent(in) :: incx, n + integer(${ik}$), intent(in) :: incx, n ! Array Arguments real(${rk}$), intent(in) :: dx(*) ! ===================================================================== ! Local Scalars real(${rk}$) :: dtemp - integer(ilp) :: i, m, mp1, nincx + integer(${ik}$) :: i, m, mp1, nincx ! Intrinsic Functions intrinsic :: abs,mod - stdlib_${ri}$asum = zero + stdlib${ii}$_${ri}$asum = zero dtemp = zero if (n<=0 .or. incx<=0) return if (incx==1) then @@ -118,7 +120,7 @@ module stdlib_linalg_blas_${ri}$ dtemp = dtemp + abs(dx(i)) end do if (n<6) then - stdlib_${ri}$asum = dtemp + stdlib${ii}$_${ri}$asum = dtemp return end if end if @@ -134,12 +136,12 @@ module stdlib_linalg_blas_${ri}$ dtemp = dtemp + abs(dx(i)) end do end if - stdlib_${ri}$asum = dtemp + stdlib${ii}$_${ri}$asum = dtemp return - end function stdlib_${ri}$asum + end function stdlib${ii}$_${ri}$asum - pure subroutine stdlib_${ri}$axpy(n,da,dx,incx,dy,incy) + pure subroutine stdlib${ii}$_${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 -- @@ -147,13 +149,13 @@ module stdlib_linalg_blas_${ri}$ ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments real(${rk}$), intent(in) :: da - integer(ilp), intent(in) :: incx, incy, n + integer(${ik}$), intent(in) :: incx, incy, n ! Array Arguments real(${rk}$), intent(in) :: dx(*) real(${rk}$), intent(inout) :: dy(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, ix, iy, m, mp1 + integer(${ik}$) :: i, ix, iy, m, mp1 ! Intrinsic Functions intrinsic :: mod if (n<=0) return @@ -189,23 +191,23 @@ module stdlib_linalg_blas_${ri}$ end do end if return - end subroutine stdlib_${ri}$axpy + end subroutine stdlib${ii}$_${ri}$axpy - pure subroutine stdlib_${ri}$copy(n,dx,incx,dy,incy) + pure subroutine stdlib${ii}$_${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 -- ! -- 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, incy, n + integer(${ik}$), intent(in) :: incx, incy, n ! Array Arguments real(${rk}$), intent(in) :: dx(*) real(${rk}$), intent(out) :: dy(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, ix, iy, m, mp1 + integer(${ik}$) :: i, ix, iy, m, mp1 ! Intrinsic Functions intrinsic :: mod if (n<=0) return @@ -243,26 +245,26 @@ module stdlib_linalg_blas_${ri}$ end do end if return - end subroutine stdlib_${ri}$copy + end subroutine stdlib${ii}$_${ri}$copy - pure real(${rk}$) function stdlib_${ri}$dot(n,dx,incx,dy,incy) + pure real(${rk}$) function stdlib${ii}$_${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 -- ! -- 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, incy, n + integer(${ik}$), intent(in) :: incx, incy, n ! Array Arguments real(${rk}$), intent(in) :: dx(*), dy(*) ! ===================================================================== ! Local Scalars real(${rk}$) :: dtemp - integer(ilp) :: i, ix, iy, m, mp1 + integer(${ik}$) :: i, ix, iy, m, mp1 ! Intrinsic Functions intrinsic :: mod - stdlib_${ri}$dot = zero + stdlib${ii}$_${ri}$dot = zero dtemp = zero if (n<=0) return if (incx==1 .and. incy==1) then @@ -274,7 +276,7 @@ module stdlib_linalg_blas_${ri}$ dtemp = dtemp + dx(i)*dy(i) end do if (n<5) then - stdlib_${ri}$dot=dtemp + stdlib${ii}$_${ri}$dot=dtemp return end if end if @@ -296,12 +298,12 @@ module stdlib_linalg_blas_${ri}$ iy = iy + incy end do end if - stdlib_${ri}$dot = dtemp + stdlib${ii}$_${ri}$dot = dtemp return - end function stdlib_${ri}$dot + end function stdlib${ii}$_${ri}$dot - pure subroutine stdlib_${ri}$gbmv(trans,m,n,kl,ku,alpha,a,lda,x,incx,beta,y,incy) + pure subroutine stdlib${ii}$_${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 @@ -311,7 +313,7 @@ module stdlib_linalg_blas_${ri}$ ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments real(${rk}$), intent(in) :: alpha, beta - integer(ilp), intent(in) :: incx, incy, kl, ku, lda, m, n + integer(${ik}$), intent(in) :: incx, incy, kl, ku, lda, m, n character, intent(in) :: trans ! Array Arguments real(${rk}$), intent(in) :: a(lda,*), x(*) @@ -320,7 +322,7 @@ module stdlib_linalg_blas_${ri}$ ! Local Scalars real(${rk}$) :: temp - integer(ilp) :: i, info, ix, iy, j, jx, jy, k, kup1, kx, ky, lenx, leny + integer(${ik}$) :: i, info, ix, iy, j, jx, jy, k, kup1, kx, ky, lenx, leny ! Intrinsic Functions intrinsic :: max,min ! test the input parameters. @@ -344,7 +346,7 @@ module stdlib_linalg_blas_${ri}$ info = 13 end if if (info/=0) then - call stdlib_xerbla('DGBMV ',info) + call stdlib${ii}$_xerbla('DGBMV ',info) return end if ! quick return if possible. @@ -453,10 +455,10 @@ module stdlib_linalg_blas_${ri}$ end if end if return - end subroutine stdlib_${ri}$gbmv + end subroutine stdlib${ii}$_${ri}$gbmv - pure subroutine stdlib_${ri}$gemm(transa,transb,m,n,k,alpha,a,lda,b,ldb,beta,c,ldc) + pure subroutine stdlib${ii}$_${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 @@ -468,7 +470,7 @@ module stdlib_linalg_blas_${ri}$ ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments real(${rk}$), intent(in) :: alpha, beta - integer(ilp), intent(in) :: k, lda, ldb, ldc, m, n + integer(${ik}$), intent(in) :: k, lda, ldb, ldc, m, n character, intent(in) :: transa, transb ! Array Arguments real(${rk}$), intent(in) :: a(lda,*), b(ldb,*) @@ -478,7 +480,7 @@ module stdlib_linalg_blas_${ri}$ intrinsic :: max ! Local Scalars real(${rk}$) :: temp - integer(ilp) :: i, info, j, l, nrowa, nrowb + integer(${ik}$) :: i, info, j, l, nrowa, nrowb logical(lk) :: nota, notb ! set nota and notb as true if a and b respectively are not @@ -518,7 +520,7 @@ module stdlib_linalg_blas_${ri}$ info = 13 end if if (info/=0) then - call stdlib_xerbla('DGEMM ',info) + call stdlib${ii}$_xerbla('DGEMM ',info) return end if ! quick return if possible. @@ -616,10 +618,10 @@ module stdlib_linalg_blas_${ri}$ end if end if return - end subroutine stdlib_${ri}$gemm + end subroutine stdlib${ii}$_${ri}$gemm - pure subroutine stdlib_${ri}$gemv(trans,m,n,alpha,a,lda,x,incx,beta,y,incy) + pure subroutine stdlib${ii}$_${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 @@ -629,7 +631,7 @@ module stdlib_linalg_blas_${ri}$ ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments real(${rk}$), intent(in) :: alpha, beta - integer(ilp), intent(in) :: incx, incy, lda, m, n + integer(${ik}$), intent(in) :: incx, incy, lda, m, n character, intent(in) :: trans ! Array Arguments real(${rk}$), intent(in) :: a(lda,*), x(*) @@ -638,7 +640,7 @@ module stdlib_linalg_blas_${ri}$ ! Local Scalars real(${rk}$) :: temp - integer(ilp) :: i, info, ix, iy, j, jx, jy, kx, ky, lenx, leny + integer(${ik}$) :: i, info, ix, iy, j, jx, jy, kx, ky, lenx, leny ! Intrinsic Functions intrinsic :: max ! test the input parameters. @@ -658,7 +660,7 @@ module stdlib_linalg_blas_${ri}$ info = 11 end if if (info/=0) then - call stdlib_xerbla('DGEMV ',info) + call stdlib${ii}$_xerbla('DGEMV ',info) return end if ! quick return if possible. @@ -760,10 +762,10 @@ module stdlib_linalg_blas_${ri}$ end if end if return - end subroutine stdlib_${ri}$gemv + end subroutine stdlib${ii}$_${ri}$gemv - pure subroutine stdlib_${ri}$ger(m,n,alpha,x,incx,y,incy,a,lda) + pure subroutine stdlib${ii}$_${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 @@ -773,7 +775,7 @@ module stdlib_linalg_blas_${ri}$ ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments real(${rk}$), intent(in) :: alpha - integer(ilp), intent(in) :: incx, incy, lda, m, n + integer(${ik}$), intent(in) :: incx, incy, lda, m, n ! Array Arguments real(${rk}$), intent(inout) :: a(lda,*) real(${rk}$), intent(in) :: x(*), y(*) @@ -781,7 +783,7 @@ module stdlib_linalg_blas_${ri}$ ! Local Scalars real(${rk}$) :: temp - integer(ilp) :: i, info, ix, j, jy, kx + integer(${ik}$) :: i, info, ix, j, jy, kx ! Intrinsic Functions intrinsic :: max ! test the input parameters. @@ -798,7 +800,7 @@ module stdlib_linalg_blas_${ri}$ info = 9 end if if (info/=0) then - call stdlib_xerbla('DGER ',info) + call stdlib${ii}$_xerbla('DGER ',info) return end if ! quick return if possible. @@ -839,14 +841,14 @@ module stdlib_linalg_blas_${ri}$ end do end if return - end subroutine stdlib_${ri}$ger + end subroutine stdlib${ii}$_${ri}$ger - pure function stdlib_${ri}$nrm2( n, x, incx ) + pure function stdlib${ii}$_${ri}$nrm2( n, x, incx ) !! DNRM2: returns the euclidean norm of a vector via the function !! name, so that !! DNRM2 := sqrt( x'*x ) - real(${rk}$) :: stdlib_${ri}$nrm2 + real(${rk}$) :: stdlib${ii}$_${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..-- @@ -855,15 +857,15 @@ module stdlib_linalg_blas_${ri}$ real(${rk}$), parameter :: maxn = huge(0.0_${rk}$) ! .. blue's scaling constants .. ! Scalar Arguments - integer(ilp), intent(in) :: incx, n + integer(${ik}$), intent(in) :: incx, n ! Array Arguments real(${rk}$), intent(in) :: x(*) ! Local Scalars - integer(ilp) :: i, ix + integer(${ik}$) :: i, ix logical(lk) :: notbig real(${rk}$) :: abig, amed, asml, ax, scl, sumsq, ymax, ymin ! quick return if possible - stdlib_${ri}$nrm2 = zero + stdlib${ii}$_${ri}$nrm2 = zero if( n <= 0 ) return scl = one sumsq = zero @@ -924,25 +926,25 @@ module stdlib_linalg_blas_${ri}$ scl = one sumsq = amed end if - stdlib_${ri}$nrm2 = scl*sqrt( sumsq ) + stdlib${ii}$_${ri}$nrm2 = scl*sqrt( sumsq ) return - end function stdlib_${ri}$nrm2 + end function stdlib${ii}$_${ri}$nrm2 - pure subroutine stdlib_${ri}$rot(n,dx,incx,dy,incy,c,s) + pure subroutine stdlib${ii}$_${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(${rk}$), intent(in) :: c, s - integer(ilp), intent(in) :: incx, incy, n + integer(${ik}$), intent(in) :: incx, incy, n ! Array Arguments real(${rk}$), intent(inout) :: dx(*), dy(*) ! ===================================================================== ! Local Scalars real(${rk}$) :: dtemp - integer(ilp) :: i, ix, iy + integer(${ik}$) :: i, ix, iy if (n<=0) return if (incx==1 .and. incy==1) then ! code for both increments equal to 1 @@ -967,10 +969,10 @@ module stdlib_linalg_blas_${ri}$ end do end if return - end subroutine stdlib_${ri}$rot + end subroutine stdlib${ii}$_${ri}$rot - pure subroutine stdlib_${ri}$rotg( a, b, c, s ) + pure subroutine stdlib${ii}$_${ri}$rotg( a, b, c, s ) !! The computation uses the formulas !! sigma = sgn(a) if |a| > |b| !! = sgn(b) if |b| >= |a| @@ -1026,10 +1028,10 @@ module stdlib_linalg_blas_${ri}$ b = z end if return - end subroutine stdlib_${ri}$rotg + end subroutine stdlib${ii}$_${ri}$rotg - pure subroutine stdlib_${ri}$rotm(n,dx,incx,dy,incy,dparam) + pure subroutine stdlib${ii}$_${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 @@ -1045,14 +1047,14 @@ module stdlib_linalg_blas_${ri}$ ! -- 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, incy, n + integer(${ik}$), intent(in) :: incx, incy, n ! Array Arguments real(${rk}$), intent(in) :: dparam(5) real(${rk}$), intent(inout) :: dx(*), dy(*) ! ===================================================================== ! Local Scalars real(${rk}$) :: dflag, dh11, dh12, dh21, dh22, two, w, z, zero - integer(ilp) :: i, kx, ky, nsteps + integer(${ik}$) :: i, kx, ky, nsteps ! Data Statements zero = 0.0_${rk}$ two = 2.0_${rk}$ @@ -1133,10 +1135,10 @@ module stdlib_linalg_blas_${ri}$ end if end if return - end subroutine stdlib_${ri}$rotm + end subroutine stdlib${ii}$_${ri}$rotm - pure subroutine stdlib_${ri}$rotmg(dd1,dd2,dx1,dy1,dparam) + pure subroutine stdlib${ii}$_${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. $$ @@ -1298,10 +1300,10 @@ module stdlib_linalg_blas_${ri}$ end if dparam(1) = dflag return - end subroutine stdlib_${ri}$rotmg + end subroutine stdlib${ii}$_${ri}$rotmg - pure subroutine stdlib_${ri}$sbmv(uplo,n,k,alpha,a,lda,x,incx,beta,y,incy) + pure subroutine stdlib${ii}$_${ri}$sbmv(uplo,n,k,alpha,a,lda,x,incx,beta,y,incy) !! DSBMV: 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 @@ -1311,7 +1313,7 @@ module stdlib_linalg_blas_${ri}$ ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments real(${rk}$), intent(in) :: alpha, beta - integer(ilp), intent(in) :: incx, incy, k, lda, n + integer(${ik}$), intent(in) :: incx, incy, k, lda, n character, intent(in) :: uplo ! Array Arguments real(${rk}$), intent(in) :: a(lda,*), x(*) @@ -1320,7 +1322,7 @@ module stdlib_linalg_blas_${ri}$ ! Local Scalars real(${rk}$) :: temp1, temp2 - integer(ilp) :: i, info, ix, iy, j, jx, jy, kplus1, kx, ky, l + integer(${ik}$) :: i, info, ix, iy, j, jx, jy, kplus1, kx, ky, l ! Intrinsic Functions intrinsic :: max,min ! test the input parameters. @@ -1339,7 +1341,7 @@ module stdlib_linalg_blas_${ri}$ info = 11 end if if (info/=0) then - call stdlib_xerbla('DSBMV ',info) + call stdlib${ii}$_xerbla('DSBMV ',info) return end if ! quick return if possible. @@ -1460,10 +1462,10 @@ module stdlib_linalg_blas_${ri}$ end if end if return - end subroutine stdlib_${ri}$sbmv + end subroutine stdlib${ii}$_${ri}$sbmv - pure subroutine stdlib_${ri}$scal(n,da,dx,incx) + pure subroutine stdlib${ii}$_${ri}$scal(n,da,dx,incx) !! DSCAL: scales a vector by a constant. !! uses unrolled loops for increment equal to 1. ! -- reference blas level1 routine -- @@ -1471,12 +1473,12 @@ module stdlib_linalg_blas_${ri}$ ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments real(${rk}$), intent(in) :: da - integer(ilp), intent(in) :: incx, n + integer(${ik}$), intent(in) :: incx, n ! Array Arguments real(${rk}$), intent(inout) :: dx(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, m, mp1, nincx + integer(${ik}$) :: i, m, mp1, nincx ! Intrinsic Functions intrinsic :: mod if (n<=0 .or. incx<=0) return @@ -1506,10 +1508,10 @@ module stdlib_linalg_blas_${ri}$ end do end if return - end subroutine stdlib_${ri}$scal + end subroutine stdlib${ii}$_${ri}$scal - pure real(${rk}$) function stdlib_${ri}$sdot(n,sx,incx,sy,incy) + pure real(${rk}$) function stdlib${ii}$_${ri}$sdot(n,sx,incx,sy,incy) !! Compute the inner product of two vectors with extended !! precision accumulation and result. !! Returns D.P. dot product accumulated in D.P., for S.P. SX and SY @@ -1520,7 +1522,7 @@ module stdlib_linalg_blas_${ri}$ ! -- 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, incy, n + integer(${ik}$), intent(in) :: incx, incy, n ! Array Arguments real(dp), intent(in) :: sx(*), sy(*) ! authors: @@ -1529,16 +1531,16 @@ module stdlib_linalg_blas_${ri}$ ! kincaid, d. r., (u. of texas), krogh, f. t., (jpl) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, kx, ky, ns + integer(${ik}$) :: i, kx, ky, ns ! Intrinsic Functions intrinsic :: real - stdlib_${ri}$sdot = zero + stdlib${ii}$_${ri}$sdot = zero if (n<=0) return if (incx==incy .and. incx>0) then ! code for equal, positive, non-unit increments. ns = n*incx do i = 1,ns,incx - stdlib_${ri}$sdot = stdlib_${ri}$sdot + real(sx(i),KIND=${rk}$)*real(sy(i),KIND=${rk}$) + stdlib${ii}$_${ri}$sdot = stdlib${ii}$_${ri}$sdot + real(sx(i),KIND=${rk}$)*real(sy(i),KIND=${rk}$) end do else ! code for unequal or nonpositive increments. @@ -1547,16 +1549,16 @@ module stdlib_linalg_blas_${ri}$ if (incx<0) kx = 1 + (1-n)*incx if (incy<0) ky = 1 + (1-n)*incy do i = 1,n - stdlib_${ri}$sdot = stdlib_${ri}$sdot + real(sx(kx),KIND=${rk}$)*real(sy(ky),KIND=${rk}$) + stdlib${ii}$_${ri}$sdot = stdlib${ii}$_${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_${ri}$sdot + end function stdlib${ii}$_${ri}$sdot - pure subroutine stdlib_${ri}$spmv(uplo,n,alpha,ap,x,incx,beta,y,incy) + pure subroutine stdlib${ii}$_${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 @@ -1566,7 +1568,7 @@ module stdlib_linalg_blas_${ri}$ ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments real(${rk}$), intent(in) :: alpha, beta - integer(ilp), intent(in) :: incx, incy, n + integer(${ik}$), intent(in) :: incx, incy, n character, intent(in) :: uplo ! Array Arguments real(${rk}$), intent(in) :: ap(*), x(*) @@ -1575,7 +1577,7 @@ module stdlib_linalg_blas_${ri}$ ! Local Scalars real(${rk}$) :: temp1, temp2 - integer(ilp) :: i, info, ix, iy, j, jx, jy, k, kk, kx, ky + integer(${ik}$) :: i, info, ix, iy, j, jx, jy, k, kk, kx, ky ! test the input parameters. info = 0 if (.not.stdlib_lsame(uplo,'U') .and. .not.stdlib_lsame(uplo,'L')) then @@ -1588,7 +1590,7 @@ module stdlib_linalg_blas_${ri}$ info = 9 end if if (info/=0) then - call stdlib_xerbla('DSPMV ',info) + call stdlib${ii}$_xerbla('DSPMV ',info) return end if ! quick return if possible. @@ -1709,10 +1711,10 @@ module stdlib_linalg_blas_${ri}$ end if end if return - end subroutine stdlib_${ri}$spmv + end subroutine stdlib${ii}$_${ri}$spmv - pure subroutine stdlib_${ri}$spr(uplo,n,alpha,x,incx,ap) + pure subroutine stdlib${ii}$_${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 @@ -1722,7 +1724,7 @@ module stdlib_linalg_blas_${ri}$ ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments real(${rk}$), intent(in) :: alpha - integer(ilp), intent(in) :: incx, n + integer(${ik}$), intent(in) :: incx, n character, intent(in) :: uplo ! Array Arguments real(${rk}$), intent(inout) :: ap(*) @@ -1731,7 +1733,7 @@ module stdlib_linalg_blas_${ri}$ ! Local Scalars real(${rk}$) :: temp - integer(ilp) :: i, info, ix, j, jx, k, kk, kx + integer(${ik}$) :: i, info, ix, j, jx, k, kk, kx ! test the input parameters. info = 0 if (.not.stdlib_lsame(uplo,'U') .and. .not.stdlib_lsame(uplo,'L')) then @@ -1742,7 +1744,7 @@ module stdlib_linalg_blas_${ri}$ info = 5 end if if (info/=0) then - call stdlib_xerbla('DSPR ',info) + call stdlib${ii}$_xerbla('DSPR ',info) return end if ! quick return if possible. @@ -1816,10 +1818,10 @@ module stdlib_linalg_blas_${ri}$ end if end if return - end subroutine stdlib_${ri}$spr + end subroutine stdlib${ii}$_${ri}$spr - pure subroutine stdlib_${ri}$spr2(uplo,n,alpha,x,incx,y,incy,ap) + pure subroutine stdlib${ii}$_${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 @@ -1829,7 +1831,7 @@ module stdlib_linalg_blas_${ri}$ ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments real(${rk}$), intent(in) :: alpha - integer(ilp), intent(in) :: incx, incy, n + integer(${ik}$), intent(in) :: incx, incy, n character, intent(in) :: uplo ! Array Arguments real(${rk}$), intent(inout) :: ap(*) @@ -1838,7 +1840,7 @@ module stdlib_linalg_blas_${ri}$ ! Local Scalars real(${rk}$) :: temp1, temp2 - integer(ilp) :: i, info, ix, iy, j, jx, jy, k, kk, kx, ky + integer(${ik}$) :: i, info, ix, iy, j, jx, jy, k, kk, kx, ky ! test the input parameters. info = 0 if (.not.stdlib_lsame(uplo,'U') .and. .not.stdlib_lsame(uplo,'L')) then @@ -1851,7 +1853,7 @@ module stdlib_linalg_blas_${ri}$ info = 7 end if if (info/=0) then - call stdlib_xerbla('DSPR2 ',info) + call stdlib${ii}$_xerbla('DSPR2 ',info) return end if ! quick return if possible. @@ -1943,23 +1945,23 @@ module stdlib_linalg_blas_${ri}$ end if end if return - end subroutine stdlib_${ri}$spr2 + end subroutine stdlib${ii}$_${ri}$spr2 - pure subroutine stdlib_${ri}$swap(n,dx,incx,dy,incy) + pure subroutine stdlib${ii}$_${ri}$swap(n,dx,incx,dy,incy) !! DSWAP: interchanges two vectors. !! uses unrolled loops for increments equal to 1. ! -- 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, incy, n + integer(${ik}$), intent(in) :: incx, incy, n ! Array Arguments real(${rk}$), intent(inout) :: dx(*), dy(*) ! ===================================================================== ! Local Scalars real(${rk}$) :: dtemp - integer(ilp) :: i, ix, iy, m, mp1 + integer(${ik}$) :: i, ix, iy, m, mp1 ! Intrinsic Functions intrinsic :: mod if (n<=0) return @@ -2003,10 +2005,10 @@ module stdlib_linalg_blas_${ri}$ end do end if return - end subroutine stdlib_${ri}$swap + end subroutine stdlib${ii}$_${ri}$swap - pure subroutine stdlib_${ri}$symm(side,uplo,m,n,alpha,a,lda,b,ldb,beta,c,ldc) + pure subroutine stdlib${ii}$_${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 @@ -2018,7 +2020,7 @@ module stdlib_linalg_blas_${ri}$ ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments real(${rk}$), intent(in) :: alpha, beta - integer(ilp), intent(in) :: lda, ldb, ldc, m, n + integer(${ik}$), intent(in) :: lda, ldb, ldc, m, n character, intent(in) :: side, uplo ! Array Arguments real(${rk}$), intent(in) :: a(lda,*), b(ldb,*) @@ -2028,7 +2030,7 @@ module stdlib_linalg_blas_${ri}$ intrinsic :: max ! Local Scalars real(${rk}$) :: temp1, temp2 - integer(ilp) :: i, info, j, k, nrowa + integer(${ik}$) :: i, info, j, k, nrowa logical(lk) :: upper ! set nrowa as the number of rows of a. @@ -2056,7 +2058,7 @@ module stdlib_linalg_blas_${ri}$ info = 12 end if if (info/=0) then - call stdlib_xerbla('DSYMM ',info) + call stdlib${ii}$_xerbla('DSYMM ',info) return end if ! quick return if possible. @@ -2150,10 +2152,10 @@ module stdlib_linalg_blas_${ri}$ end do loop_170 end if return - end subroutine stdlib_${ri}$symm + end subroutine stdlib${ii}$_${ri}$symm - pure subroutine stdlib_${ri}$symv(uplo,n,alpha,a,lda,x,incx,beta,y,incy) + pure subroutine stdlib${ii}$_${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 @@ -2163,7 +2165,7 @@ module stdlib_linalg_blas_${ri}$ ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments real(${rk}$), intent(in) :: alpha, beta - integer(ilp), intent(in) :: incx, incy, lda, n + integer(${ik}$), intent(in) :: incx, incy, lda, n character, intent(in) :: uplo ! Array Arguments real(${rk}$), intent(in) :: a(lda,*), x(*) @@ -2172,7 +2174,7 @@ module stdlib_linalg_blas_${ri}$ ! Local Scalars real(${rk}$) :: temp1, temp2 - integer(ilp) :: i, info, ix, iy, j, jx, jy, kx, ky + integer(${ik}$) :: i, info, ix, iy, j, jx, jy, kx, ky ! Intrinsic Functions intrinsic :: max ! test the input parameters. @@ -2189,7 +2191,7 @@ module stdlib_linalg_blas_${ri}$ info = 10 end if if (info/=0) then - call stdlib_xerbla('DSYMV ',info) + call stdlib${ii}$_xerbla('DSYMV ',info) return end if ! quick return if possible. @@ -2302,10 +2304,10 @@ module stdlib_linalg_blas_${ri}$ end if end if return - end subroutine stdlib_${ri}$symv + end subroutine stdlib${ii}$_${ri}$symv - pure subroutine stdlib_${ri}$syr(uplo,n,alpha,x,incx,a,lda) + pure subroutine stdlib${ii}$_${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 @@ -2315,7 +2317,7 @@ module stdlib_linalg_blas_${ri}$ ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments real(${rk}$), intent(in) :: alpha - integer(ilp), intent(in) :: incx, lda, n + integer(${ik}$), intent(in) :: incx, lda, n character, intent(in) :: uplo ! Array Arguments real(${rk}$), intent(inout) :: a(lda,*) @@ -2324,7 +2326,7 @@ module stdlib_linalg_blas_${ri}$ ! Local Scalars real(${rk}$) :: temp - integer(ilp) :: i, info, ix, j, jx, kx + integer(${ik}$) :: i, info, ix, j, jx, kx ! Intrinsic Functions intrinsic :: max ! test the input parameters. @@ -2339,7 +2341,7 @@ module stdlib_linalg_blas_${ri}$ info = 7 end if if (info/=0) then - call stdlib_xerbla('DSYR ',info) + call stdlib${ii}$_xerbla('DSYR ',info) return end if ! quick return if possible. @@ -2405,10 +2407,10 @@ module stdlib_linalg_blas_${ri}$ end if end if return - end subroutine stdlib_${ri}$syr + end subroutine stdlib${ii}$_${ri}$syr - pure subroutine stdlib_${ri}$syr2(uplo,n,alpha,x,incx,y,incy,a,lda) + pure subroutine stdlib${ii}$_${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 @@ -2418,7 +2420,7 @@ module stdlib_linalg_blas_${ri}$ ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments real(${rk}$), intent(in) :: alpha - integer(ilp), intent(in) :: incx, incy, lda, n + integer(${ik}$), intent(in) :: incx, incy, lda, n character, intent(in) :: uplo ! Array Arguments real(${rk}$), intent(inout) :: a(lda,*) @@ -2427,7 +2429,7 @@ module stdlib_linalg_blas_${ri}$ ! Local Scalars real(${rk}$) :: temp1, temp2 - integer(ilp) :: i, info, ix, iy, j, jx, jy, kx, ky + integer(${ik}$) :: i, info, ix, iy, j, jx, jy, kx, ky ! Intrinsic Functions intrinsic :: max ! test the input parameters. @@ -2444,7 +2446,7 @@ module stdlib_linalg_blas_${ri}$ info = 9 end if if (info/=0) then - call stdlib_xerbla('DSYR2 ',info) + call stdlib${ii}$_xerbla('DSYR2 ',info) return end if ! quick return if possible. @@ -2528,10 +2530,10 @@ module stdlib_linalg_blas_${ri}$ end if end if return - end subroutine stdlib_${ri}$syr2 + end subroutine stdlib${ii}$_${ri}$syr2 - pure subroutine stdlib_${ri}$syr2k(uplo,trans,n,k,alpha,a,lda,b,ldb,beta,c,ldc) + pure subroutine stdlib${ii}$_${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 @@ -2544,7 +2546,7 @@ module stdlib_linalg_blas_${ri}$ ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments real(${rk}$), intent(in) :: alpha, beta - integer(ilp), intent(in) :: k, lda, ldb, ldc, n + integer(${ik}$), intent(in) :: k, lda, ldb, ldc, n character, intent(in) :: trans, uplo ! Array Arguments real(${rk}$), intent(in) :: a(lda,*), b(ldb,*) @@ -2554,7 +2556,7 @@ module stdlib_linalg_blas_${ri}$ intrinsic :: max ! Local Scalars real(${rk}$) :: temp1, temp2 - integer(ilp) :: i, info, j, l, nrowa + integer(${ik}$) :: i, info, j, l, nrowa logical(lk) :: upper ! test the input parameters. @@ -2582,7 +2584,7 @@ module stdlib_linalg_blas_${ri}$ info = 12 end if if (info/=0) then - call stdlib_xerbla('DSYR2K',info) + call stdlib${ii}$_xerbla('DSYR2K',info) return end if ! quick return if possible. @@ -2703,10 +2705,10 @@ module stdlib_linalg_blas_${ri}$ end if end if return - end subroutine stdlib_${ri}$syr2k + end subroutine stdlib${ii}$_${ri}$syr2k - pure subroutine stdlib_${ri}$syrk(uplo,trans,n,k,alpha,a,lda,beta,c,ldc) + pure subroutine stdlib${ii}$_${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 @@ -2719,7 +2721,7 @@ module stdlib_linalg_blas_${ri}$ ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments real(${rk}$), intent(in) :: alpha, beta - integer(ilp), intent(in) :: k, lda, ldc, n + integer(${ik}$), intent(in) :: k, lda, ldc, n character, intent(in) :: trans, uplo ! Array Arguments real(${rk}$), intent(in) :: a(lda,*) @@ -2729,7 +2731,7 @@ module stdlib_linalg_blas_${ri}$ intrinsic :: max ! Local Scalars real(${rk}$) :: temp - integer(ilp) :: i, info, j, l, nrowa + integer(${ik}$) :: i, info, j, l, nrowa logical(lk) :: upper ! test the input parameters. @@ -2755,7 +2757,7 @@ module stdlib_linalg_blas_${ri}$ info = 10 end if if (info/=0) then - call stdlib_xerbla('DSYRK ',info) + call stdlib${ii}$_xerbla('DSYRK ',info) return end if ! quick return if possible. @@ -2870,10 +2872,10 @@ module stdlib_linalg_blas_${ri}$ end if end if return - end subroutine stdlib_${ri}$syrk + end subroutine stdlib${ii}$_${ri}$syrk - pure subroutine stdlib_${ri}$tbmv(uplo,trans,diag,n,k,a,lda,x,incx) + pure subroutine stdlib${ii}$_${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, @@ -2882,7 +2884,7 @@ module stdlib_linalg_blas_${ri}$ ! -- 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, k, lda, n + integer(${ik}$), intent(in) :: incx, k, lda, n character, intent(in) :: diag, trans, uplo ! Array Arguments real(${rk}$), intent(in) :: a(lda,*) @@ -2891,7 +2893,7 @@ module stdlib_linalg_blas_${ri}$ ! Local Scalars real(${rk}$) :: temp - integer(ilp) :: i, info, ix, j, jx, kplus1, kx, l + integer(${ik}$) :: i, info, ix, j, jx, kplus1, kx, l logical(lk) :: nounit ! Intrinsic Functions intrinsic :: max,min @@ -2914,7 +2916,7 @@ module stdlib_linalg_blas_${ri}$ info = 9 end if if (info/=0) then - call stdlib_xerbla('DTBMV ',info) + call stdlib${ii}$_xerbla('DTBMV ',info) return end if ! quick return if possible. @@ -3053,10 +3055,10 @@ module stdlib_linalg_blas_${ri}$ end if end if return - end subroutine stdlib_${ri}$tbmv + end subroutine stdlib${ii}$_${ri}$tbmv - pure subroutine stdlib_${ri}$tbsv(uplo,trans,diag,n,k,a,lda,x,incx) + pure subroutine stdlib${ii}$_${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 @@ -3068,7 +3070,7 @@ module stdlib_linalg_blas_${ri}$ ! -- 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, k, lda, n + integer(${ik}$), intent(in) :: incx, k, lda, n character, intent(in) :: diag, trans, uplo ! Array Arguments real(${rk}$), intent(in) :: a(lda,*) @@ -3077,7 +3079,7 @@ module stdlib_linalg_blas_${ri}$ ! Local Scalars real(${rk}$) :: temp - integer(ilp) :: i, info, ix, j, jx, kplus1, kx, l + integer(${ik}$) :: i, info, ix, j, jx, kplus1, kx, l logical(lk) :: nounit ! Intrinsic Functions intrinsic :: max,min @@ -3100,7 +3102,7 @@ module stdlib_linalg_blas_${ri}$ info = 9 end if if (info/=0) then - call stdlib_xerbla('DTBSV ',info) + call stdlib${ii}$_xerbla('DTBSV ',info) return end if ! quick return if possible. @@ -3239,10 +3241,10 @@ module stdlib_linalg_blas_${ri}$ end if end if return - end subroutine stdlib_${ri}$tbsv + end subroutine stdlib${ii}$_${ri}$tbsv - pure subroutine stdlib_${ri}$tpmv(uplo,trans,diag,n,ap,x,incx) + pure subroutine stdlib${ii}$_${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, @@ -3251,7 +3253,7 @@ module stdlib_linalg_blas_${ri}$ ! -- 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 + integer(${ik}$), intent(in) :: incx, n character, intent(in) :: diag, trans, uplo ! Array Arguments real(${rk}$), intent(in) :: ap(*) @@ -3260,7 +3262,7 @@ module stdlib_linalg_blas_${ri}$ ! Local Scalars real(${rk}$) :: temp - integer(ilp) :: i, info, ix, j, jx, k, kk, kx + integer(${ik}$) :: i, info, ix, j, jx, k, kk, kx logical(lk) :: nounit ! test the input parameters. info = 0 @@ -3277,7 +3279,7 @@ module stdlib_linalg_blas_${ri}$ info = 7 end if if (info/=0) then - call stdlib_xerbla('DTPMV ',info) + call stdlib${ii}$_xerbla('DTPMV ',info) return end if ! quick return if possible. @@ -3421,10 +3423,10 @@ module stdlib_linalg_blas_${ri}$ end if end if return - end subroutine stdlib_${ri}$tpmv + end subroutine stdlib${ii}$_${ri}$tpmv - pure subroutine stdlib_${ri}$tpsv(uplo,trans,diag,n,ap,x,incx) + pure subroutine stdlib${ii}$_${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 @@ -3435,7 +3437,7 @@ module stdlib_linalg_blas_${ri}$ ! -- 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 + integer(${ik}$), intent(in) :: incx, n character, intent(in) :: diag, trans, uplo ! Array Arguments real(${rk}$), intent(in) :: ap(*) @@ -3444,7 +3446,7 @@ module stdlib_linalg_blas_${ri}$ ! Local Scalars real(${rk}$) :: temp - integer(ilp) :: i, info, ix, j, jx, k, kk, kx + integer(${ik}$) :: i, info, ix, j, jx, k, kk, kx logical(lk) :: nounit ! test the input parameters. info = 0 @@ -3461,7 +3463,7 @@ module stdlib_linalg_blas_${ri}$ info = 7 end if if (info/=0) then - call stdlib_xerbla('DTPSV ',info) + call stdlib${ii}$_xerbla('DTPSV ',info) return end if ! quick return if possible. @@ -3605,10 +3607,10 @@ module stdlib_linalg_blas_${ri}$ end if end if return - end subroutine stdlib_${ri}$tpsv + end subroutine stdlib${ii}$_${ri}$tpsv - pure subroutine stdlib_${ri}$trmm(side,uplo,transa,diag,m,n,alpha,a,lda,b,ldb) + pure subroutine stdlib${ii}$_${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 @@ -3619,7 +3621,7 @@ module stdlib_linalg_blas_${ri}$ ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments real(${rk}$), intent(in) :: alpha - integer(ilp), intent(in) :: lda, ldb, m, n + integer(${ik}$), intent(in) :: lda, ldb, m, n character, intent(in) :: diag, side, transa, uplo ! Array Arguments real(${rk}$), intent(in) :: a(lda,*) @@ -3629,7 +3631,7 @@ module stdlib_linalg_blas_${ri}$ intrinsic :: max ! Local Scalars real(${rk}$) :: temp - integer(ilp) :: i, info, j, k, nrowa + integer(${ik}$) :: i, info, j, k, nrowa logical(lk) :: lside, nounit, upper ! test the input parameters. @@ -3662,7 +3664,7 @@ module stdlib_linalg_blas_${ri}$ info = 11 end if if (info/=0) then - call stdlib_xerbla('DTRMM ',info) + call stdlib${ii}$_xerbla('DTRMM ',info) return end if ! quick return if possible. @@ -3811,10 +3813,10 @@ module stdlib_linalg_blas_${ri}$ end if end if return - end subroutine stdlib_${ri}$trmm + end subroutine stdlib${ii}$_${ri}$trmm - pure subroutine stdlib_${ri}$trmv(uplo,trans,diag,n,a,lda,x,incx) + pure subroutine stdlib${ii}$_${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, @@ -3823,7 +3825,7 @@ module stdlib_linalg_blas_${ri}$ ! -- 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, lda, n + integer(${ik}$), intent(in) :: incx, lda, n character, intent(in) :: diag, trans, uplo ! Array Arguments real(${rk}$), intent(in) :: a(lda,*) @@ -3832,7 +3834,7 @@ module stdlib_linalg_blas_${ri}$ ! Local Scalars real(${rk}$) :: temp - integer(ilp) :: i, info, ix, j, jx, kx + integer(${ik}$) :: i, info, ix, j, jx, kx logical(lk) :: nounit ! Intrinsic Functions intrinsic :: max @@ -3853,7 +3855,7 @@ module stdlib_linalg_blas_${ri}$ info = 8 end if if (info/=0) then - call stdlib_xerbla('DTRMV ',info) + call stdlib${ii}$_xerbla('DTRMV ',info) return end if ! quick return if possible. @@ -3977,10 +3979,10 @@ module stdlib_linalg_blas_${ri}$ end if end if return - end subroutine stdlib_${ri}$trmv + end subroutine stdlib${ii}$_${ri}$trmv - pure subroutine stdlib_${ri}$trsm(side,uplo,transa,diag,m,n,alpha,a,lda,b,ldb) + pure subroutine stdlib${ii}$_${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 @@ -3992,7 +3994,7 @@ module stdlib_linalg_blas_${ri}$ ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments real(${rk}$), intent(in) :: alpha - integer(ilp), intent(in) :: lda, ldb, m, n + integer(${ik}$), intent(in) :: lda, ldb, m, n character, intent(in) :: diag, side, transa, uplo ! Array Arguments real(${rk}$), intent(in) :: a(lda,*) @@ -4002,7 +4004,7 @@ module stdlib_linalg_blas_${ri}$ intrinsic :: max ! Local Scalars real(${rk}$) :: temp - integer(ilp) :: i, info, j, k, nrowa + integer(${ik}$) :: i, info, j, k, nrowa logical(lk) :: lside, nounit, upper ! test the input parameters. @@ -4035,7 +4037,7 @@ module stdlib_linalg_blas_${ri}$ info = 11 end if if (info/=0) then - call stdlib_xerbla('DTRSM ',info) + call stdlib${ii}$_xerbla('DTRSM ',info) return end if ! quick return if possible. @@ -4208,10 +4210,10 @@ module stdlib_linalg_blas_${ri}$ end if end if return - end subroutine stdlib_${ri}$trsm + end subroutine stdlib${ii}$_${ri}$trsm - pure subroutine stdlib_${ri}$trsv(uplo,trans,diag,n,a,lda,x,incx) + pure subroutine stdlib${ii}$_${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 @@ -4222,7 +4224,7 @@ module stdlib_linalg_blas_${ri}$ ! -- 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, lda, n + integer(${ik}$), intent(in) :: incx, lda, n character, intent(in) :: diag, trans, uplo ! Array Arguments real(${rk}$), intent(in) :: a(lda,*) @@ -4231,7 +4233,7 @@ module stdlib_linalg_blas_${ri}$ ! Local Scalars real(${rk}$) :: temp - integer(ilp) :: i, info, ix, j, jx, kx + integer(${ik}$) :: i, info, ix, j, jx, kx logical(lk) :: nounit ! Intrinsic Functions intrinsic :: max @@ -4252,7 +4254,7 @@ module stdlib_linalg_blas_${ri}$ info = 8 end if if (info/=0) then - call stdlib_xerbla('DTRSV ',info) + call stdlib${ii}$_xerbla('DTRSV ',info) return end if ! quick return if possible. @@ -4376,24 +4378,24 @@ module stdlib_linalg_blas_${ri}$ end if end if return - end subroutine stdlib_${ri}$trsv + end subroutine stdlib${ii}$_${ri}$trsv - pure real(${rk}$) function stdlib_${ri}$zasum(n,zx,incx) + pure real(${rk}$) function stdlib${ii}$_${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 -- ! -- 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 + integer(${ik}$), intent(in) :: incx, n ! Array Arguments complex(${rk}$), intent(in) :: zx(*) ! ===================================================================== ! Local Scalars real(${rk}$) :: stemp - integer(ilp) :: i, nincx - stdlib_${ri}$zasum = zero + integer(${ik}$) :: i, nincx + stdlib${ii}$_${ri}$zasum = zero stemp = zero if (n<=0 .or. incx<=0) return if (incx==1) then @@ -4408,16 +4410,16 @@ module stdlib_linalg_blas_${ri}$ stemp = stemp + stdlib_cabs1(zx(i)) end do end if - stdlib_${ri}$zasum = stemp + stdlib${ii}$_${ri}$zasum = stemp return - end function stdlib_${ri}$zasum + end function stdlib${ii}$_${ri}$zasum - pure function stdlib_${ri}$znrm2( n, x, incx ) + pure function stdlib${ii}$_${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(${rk}$) :: stdlib_${ri}$znrm2 + real(${rk}$) :: stdlib${ii}$_${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..-- @@ -4426,15 +4428,15 @@ module stdlib_linalg_blas_${ri}$ real(${rk}$), parameter :: maxn = huge(0.0_${rk}$) ! .. blue's scaling constants .. ! Scalar Arguments - integer(ilp), intent(in) :: incx, n + integer(${ik}$), intent(in) :: incx, n ! Array Arguments complex(${rk}$), intent(in) :: x(*) ! Local Scalars - integer(ilp) :: i, ix - logical(lk) :: notbig + integer(${ik}$) :: i, ix + logical(lk) :: notbig real(${rk}$) :: abig, amed, asml, ax, scl, sumsq, ymax, ymin ! quick return if possible - stdlib_${ri}$znrm2 = zero + stdlib${ii}$_${ri}$znrm2 = zero if( n <= 0 ) return scl = one sumsq = zero @@ -4504,9 +4506,11 @@ module stdlib_linalg_blas_${ri}$ scl = one sumsq = amed end if - stdlib_${ri}$znrm2 = scl*sqrt( sumsq ) + stdlib${ii}$_${ri}$znrm2 = scl*sqrt( sumsq ) return - end function stdlib_${ri}$znrm2 + end function stdlib${ii}$_${ri}$znrm2 + + #:endfor end module stdlib_linalg_blas_${ri}$ #:endif From 7a35557d2a8e1e0788741d8cbe4ea598fe232e47 Mon Sep 17 00:00:00 2001 From: Federico Perini Date: Wed, 13 Nov 2024 18:40:35 +0100 Subject: [PATCH 08/31] `blas_c`: template integer type --- src/stdlib_linalg_blas_c.fypp | 414 +++++++++++++++++----------------- 1 file changed, 208 insertions(+), 206 deletions(-) diff --git a/src/stdlib_linalg_blas_c.fypp b/src/stdlib_linalg_blas_c.fypp index 380cb1992..f709dcea4 100644 --- a/src/stdlib_linalg_blas_c.fypp +++ b/src/stdlib_linalg_blas_c.fypp @@ -7,42 +7,44 @@ module stdlib_linalg_blas_c private - public :: sp,dp,qp,lk,ilp - public :: stdlib_caxpy - public :: stdlib_ccopy - public :: stdlib_cdotc - public :: stdlib_cdotu - public :: stdlib_cgbmv - public :: stdlib_cgemm - public :: stdlib_cgemv - public :: stdlib_cgerc - public :: stdlib_cgeru - public :: stdlib_chbmv - public :: stdlib_chemm - public :: stdlib_chemv - public :: stdlib_cher - public :: stdlib_cher2 - public :: stdlib_cher2k - public :: stdlib_cherk - public :: stdlib_chpmv - public :: stdlib_chpr - public :: stdlib_chpr2 - public :: stdlib_crotg - public :: stdlib_cscal - public :: stdlib_csrot - public :: stdlib_csscal - public :: stdlib_cswap - public :: stdlib_csymm - public :: stdlib_csyr2k - public :: stdlib_csyrk - public :: stdlib_ctbmv - public :: stdlib_ctbsv - public :: stdlib_ctpmv - public :: stdlib_ctpsv - public :: stdlib_ctrmm - public :: stdlib_ctrmv - public :: stdlib_ctrsm - public :: stdlib_ctrsv + public :: sp,dp,qp,lk,ilp,ilp64 + #:for ik,it,ii in LINALG_INT_KINDS_TYPES + public :: stdlib${ii}$_caxpy + public :: stdlib${ii}$_ccopy + public :: stdlib${ii}$_cdotc + public :: stdlib${ii}$_cdotu + public :: stdlib${ii}$_cgbmv + public :: stdlib${ii}$_cgemm + public :: stdlib${ii}$_cgemv + public :: stdlib${ii}$_cgerc + public :: stdlib${ii}$_cgeru + public :: stdlib${ii}$_chbmv + public :: stdlib${ii}$_chemm + public :: stdlib${ii}$_chemv + public :: stdlib${ii}$_cher + public :: stdlib${ii}$_cher2 + public :: stdlib${ii}$_cher2k + public :: stdlib${ii}$_cherk + public :: stdlib${ii}$_chpmv + public :: stdlib${ii}$_chpr + public :: stdlib${ii}$_chpr2 + public :: stdlib${ii}$_crotg + public :: stdlib${ii}$_cscal + public :: stdlib${ii}$_csrot + public :: stdlib${ii}$_csscal + public :: stdlib${ii}$_cswap + public :: stdlib${ii}$_csymm + public :: stdlib${ii}$_csyr2k + public :: stdlib${ii}$_csyrk + public :: stdlib${ii}$_ctbmv + public :: stdlib${ii}$_ctbsv + public :: stdlib${ii}$_ctpmv + public :: stdlib${ii}$_ctpsv + public :: stdlib${ii}$_ctrmm + public :: stdlib${ii}$_ctrmv + public :: stdlib${ii}$_ctrsm + public :: stdlib${ii}$_ctrsv + #:endfor ! 32-bit real constants real(sp), parameter, private :: negone = -1.00_sp @@ -84,21 +86,21 @@ module stdlib_linalg_blas_c contains - - pure subroutine stdlib_caxpy(n,ca,cx,incx,cy,incy) + #:for ik,it,ii in LINALG_INT_KINDS_TYPES + pure subroutine stdlib${ii}$_caxpy(n,ca,cx,incx,cy,incy) !! CAXPY 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(sp), intent(in) :: ca - integer(ilp), intent(in) :: incx, incy, n + integer(${ik}$), intent(in) :: incx, incy, n ! Array Arguments complex(sp), intent(in) :: cx(*) complex(sp), intent(inout) :: cy(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, ix, iy + integer(${ik}$) :: i, ix, iy if (n<=0) return if (stdlib_cabs1(ca)==0.0e+0_sp) return if (incx==1 .and. incy==1) then @@ -120,22 +122,22 @@ module stdlib_linalg_blas_c end do end if return - end subroutine stdlib_caxpy + end subroutine stdlib${ii}$_caxpy - pure subroutine stdlib_ccopy(n,cx,incx,cy,incy) + pure subroutine stdlib${ii}$_ccopy(n,cx,incx,cy,incy) !! CCOPY copies a vector x to a vector y. ! -- 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, incy, n + integer(${ik}$), intent(in) :: incx, incy, n ! Array Arguments complex(sp), intent(in) :: cx(*) complex(sp), intent(out) :: cy(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, ix, iy + integer(${ik}$) :: i, ix, iy if (n<=0) return if (incx==1 .and. incy==1) then ! code for both increments equal to 1 @@ -156,27 +158,27 @@ module stdlib_linalg_blas_c end do end if return - end subroutine stdlib_ccopy + end subroutine stdlib${ii}$_ccopy - pure complex(sp) function stdlib_cdotc(n,cx,incx,cy,incy) + pure complex(sp) function stdlib${ii}$_cdotc(n,cx,incx,cy,incy) !! CDOTC forms the dot product of two complex vectors !! CDOTC = X^H * Y ! -- 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, incy, n + integer(${ik}$), intent(in) :: incx, incy, n ! Array Arguments complex(sp), intent(in) :: cx(*), cy(*) ! ===================================================================== ! Local Scalars complex(sp) :: ctemp - integer(ilp) :: i, ix, iy + integer(${ik}$) :: i, ix, iy ! Intrinsic Functions intrinsic :: conjg ctemp = (0.0_sp,0.0_sp) - stdlib_cdotc = (0.0_sp,0.0_sp) + stdlib${ii}$_cdotc = (0.0_sp,0.0_sp) if (n<=0) return if (incx==1 .and. incy==1) then ! code for both increments equal to 1 @@ -196,27 +198,27 @@ module stdlib_linalg_blas_c iy = iy + incy end do end if - stdlib_cdotc = ctemp + stdlib${ii}$_cdotc = ctemp return - end function stdlib_cdotc + end function stdlib${ii}$_cdotc - pure complex(sp) function stdlib_cdotu(n,cx,incx,cy,incy) + pure complex(sp) function stdlib${ii}$_cdotu(n,cx,incx,cy,incy) !! CDOTU forms the dot product of two complex vectors !! CDOTU = X^T * Y ! -- 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, incy, n + integer(${ik}$), intent(in) :: incx, incy, n ! Array Arguments complex(sp), intent(in) :: cx(*), cy(*) ! ===================================================================== ! Local Scalars complex(sp) :: ctemp - integer(ilp) :: i, ix, iy + integer(${ik}$) :: i, ix, iy ctemp = (0.0_sp,0.0_sp) - stdlib_cdotu = (0.0_sp,0.0_sp) + stdlib${ii}$_cdotu = (0.0_sp,0.0_sp) if (n<=0) return if (incx==1 .and. incy==1) then ! code for both increments equal to 1 @@ -236,12 +238,12 @@ module stdlib_linalg_blas_c iy = iy + incy end do end if - stdlib_cdotu = ctemp + stdlib${ii}$_cdotu = ctemp return - end function stdlib_cdotu + end function stdlib${ii}$_cdotu - pure subroutine stdlib_cgbmv(trans,m,n,kl,ku,alpha,a,lda,x,incx,beta,y,incy) + pure subroutine stdlib${ii}$_cgbmv(trans,m,n,kl,ku,alpha,a,lda,x,incx,beta,y,incy) !! CGBMV 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, @@ -252,7 +254,7 @@ module stdlib_linalg_blas_c ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments complex(sp), intent(in) :: alpha, beta - integer(ilp), intent(in) :: incx, incy, kl, ku, lda, m, n + integer(${ik}$), intent(in) :: incx, incy, kl, ku, lda, m, n character, intent(in) :: trans ! Array Arguments complex(sp), intent(in) :: a(lda,*), x(*) @@ -262,7 +264,7 @@ module stdlib_linalg_blas_c ! Local Scalars complex(sp) :: temp - integer(ilp) :: i, info, ix, iy, j, jx, jy, k, kup1, kx, ky, lenx, leny + integer(${ik}$) :: i, info, ix, iy, j, jx, jy, k, kup1, kx, ky, lenx, leny logical(lk) :: noconj ! Intrinsic Functions intrinsic :: conjg,max,min @@ -287,7 +289,7 @@ module stdlib_linalg_blas_c info = 13 end if if (info/=0) then - call stdlib_xerbla('CGBMV ',info) + call stdlib${ii}$_xerbla('CGBMV ',info) return end if ! quick return if possible. @@ -410,10 +412,10 @@ module stdlib_linalg_blas_c end if end if return - end subroutine stdlib_cgbmv + end subroutine stdlib${ii}$_cgbmv - pure subroutine stdlib_cgemm(transa,transb,m,n,k,alpha,a,lda,b,ldb,beta,c,ldc) + pure subroutine stdlib${ii}$_cgemm(transa,transb,m,n,k,alpha,a,lda,b,ldb,beta,c,ldc) !! CGEMM performs one of the matrix-matrix operations !! C := alpha*op( A )*op( B ) + beta*C, !! where op( X ) is one of @@ -425,7 +427,7 @@ module stdlib_linalg_blas_c ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments complex(sp), intent(in) :: alpha, beta - integer(ilp), intent(in) :: k, lda, ldb, ldc, m, n + integer(${ik}$), intent(in) :: k, lda, ldb, ldc, m, n character, intent(in) :: transa, transb ! Array Arguments complex(sp), intent(in) :: a(lda,*), b(ldb,*) @@ -435,7 +437,7 @@ module stdlib_linalg_blas_c intrinsic :: conjg,max ! Local Scalars complex(sp) :: temp - integer(ilp) :: i, info, j, l, nrowa, nrowb + integer(${ik}$) :: i, info, j, l, nrowa, nrowb logical(lk) :: conja, conjb, nota, notb @@ -478,7 +480,7 @@ module stdlib_linalg_blas_c info = 13 end if if (info/=0) then - call stdlib_xerbla('CGEMM ',info) + call stdlib${ii}$_xerbla('CGEMM ',info) return end if ! quick return if possible. @@ -659,10 +661,10 @@ module stdlib_linalg_blas_c end if end if return - end subroutine stdlib_cgemm + end subroutine stdlib${ii}$_cgemm - pure subroutine stdlib_cgemv(trans,m,n,alpha,a,lda,x,incx,beta,y,incy) + pure subroutine stdlib${ii}$_cgemv(trans,m,n,alpha,a,lda,x,incx,beta,y,incy) !! CGEMV 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, @@ -673,7 +675,7 @@ module stdlib_linalg_blas_c ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments complex(sp), intent(in) :: alpha, beta - integer(ilp), intent(in) :: incx, incy, lda, m, n + integer(${ik}$), intent(in) :: incx, incy, lda, m, n character, intent(in) :: trans ! Array Arguments complex(sp), intent(in) :: a(lda,*), x(*) @@ -683,7 +685,7 @@ module stdlib_linalg_blas_c ! Local Scalars complex(sp) :: temp - integer(ilp) :: i, info, ix, iy, j, jx, jy, kx, ky, lenx, leny + integer(${ik}$) :: i, info, ix, iy, j, jx, jy, kx, ky, lenx, leny logical(lk) :: noconj ! Intrinsic Functions intrinsic :: conjg,max @@ -704,7 +706,7 @@ module stdlib_linalg_blas_c info = 11 end if if (info/=0) then - call stdlib_xerbla('CGEMV ',info) + call stdlib${ii}$_xerbla('CGEMV ',info) return end if ! quick return if possible. @@ -820,10 +822,10 @@ module stdlib_linalg_blas_c end if end if return - end subroutine stdlib_cgemv + end subroutine stdlib${ii}$_cgemv - pure subroutine stdlib_cgerc(m,n,alpha,x,incx,y,incy,a,lda) + pure subroutine stdlib${ii}$_cgerc(m,n,alpha,x,incx,y,incy,a,lda) !! CGERC 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 @@ -833,7 +835,7 @@ module stdlib_linalg_blas_c ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments complex(sp), intent(in) :: alpha - integer(ilp), intent(in) :: incx, incy, lda, m, n + integer(${ik}$), intent(in) :: incx, incy, lda, m, n ! Array Arguments complex(sp), intent(inout) :: a(lda,*) complex(sp), intent(in) :: x(*), y(*) @@ -841,7 +843,7 @@ module stdlib_linalg_blas_c ! Local Scalars complex(sp) :: temp - integer(ilp) :: i, info, ix, j, jy, kx + integer(${ik}$) :: i, info, ix, j, jy, kx ! Intrinsic Functions intrinsic :: conjg,max ! test the input parameters. @@ -858,7 +860,7 @@ module stdlib_linalg_blas_c info = 9 end if if (info/=0) then - call stdlib_xerbla('CGERC ',info) + call stdlib${ii}$_xerbla('CGERC ',info) return end if ! quick return if possible. @@ -899,10 +901,10 @@ module stdlib_linalg_blas_c end do end if return - end subroutine stdlib_cgerc + end subroutine stdlib${ii}$_cgerc - pure subroutine stdlib_cgeru(m,n,alpha,x,incx,y,incy,a,lda) + pure subroutine stdlib${ii}$_cgeru(m,n,alpha,x,incx,y,incy,a,lda) !! CGERU 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 @@ -912,7 +914,7 @@ module stdlib_linalg_blas_c ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments complex(sp), intent(in) :: alpha - integer(ilp), intent(in) :: incx, incy, lda, m, n + integer(${ik}$), intent(in) :: incx, incy, lda, m, n ! Array Arguments complex(sp), intent(inout) :: a(lda,*) complex(sp), intent(in) :: x(*), y(*) @@ -920,7 +922,7 @@ module stdlib_linalg_blas_c ! Local Scalars complex(sp) :: temp - integer(ilp) :: i, info, ix, j, jy, kx + integer(${ik}$) :: i, info, ix, j, jy, kx ! Intrinsic Functions intrinsic :: max ! test the input parameters. @@ -937,7 +939,7 @@ module stdlib_linalg_blas_c info = 9 end if if (info/=0) then - call stdlib_xerbla('CGERU ',info) + call stdlib${ii}$_xerbla('CGERU ',info) return end if ! quick return if possible. @@ -978,10 +980,10 @@ module stdlib_linalg_blas_c end do end if return - end subroutine stdlib_cgeru + end subroutine stdlib${ii}$_cgeru - pure subroutine stdlib_chbmv(uplo,n,k,alpha,a,lda,x,incx,beta,y,incy) + pure subroutine stdlib${ii}$_chbmv(uplo,n,k,alpha,a,lda,x,incx,beta,y,incy) !! CHBMV 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 @@ -991,7 +993,7 @@ module stdlib_linalg_blas_c ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments complex(sp), intent(in) :: alpha, beta - integer(ilp), intent(in) :: incx, incy, k, lda, n + integer(${ik}$), intent(in) :: incx, incy, k, lda, n character, intent(in) :: uplo ! Array Arguments complex(sp), intent(in) :: a(lda,*), x(*) @@ -1001,7 +1003,7 @@ module stdlib_linalg_blas_c ! Local Scalars complex(sp) :: temp1, temp2 - integer(ilp) :: i, info, ix, iy, j, jx, jy, kplus1, kx, ky, l + integer(${ik}$) :: i, info, ix, iy, j, jx, jy, kplus1, kx, ky, l ! Intrinsic Functions intrinsic :: conjg,max,min,real ! test the input parameters. @@ -1020,7 +1022,7 @@ module stdlib_linalg_blas_c info = 11 end if if (info/=0) then - call stdlib_xerbla('CHBMV ',info) + call stdlib${ii}$_xerbla('CHBMV ',info) return end if ! quick return if possible. @@ -1141,10 +1143,10 @@ module stdlib_linalg_blas_c end if end if return - end subroutine stdlib_chbmv + end subroutine stdlib${ii}$_chbmv - pure subroutine stdlib_chemm(side,uplo,m,n,alpha,a,lda,b,ldb,beta,c,ldc) + pure subroutine stdlib${ii}$_chemm(side,uplo,m,n,alpha,a,lda,b,ldb,beta,c,ldc) !! CHEMM performs one of the matrix-matrix operations !! C := alpha*A*B + beta*C, !! or @@ -1156,7 +1158,7 @@ module stdlib_linalg_blas_c ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments complex(sp), intent(in) :: alpha, beta - integer(ilp), intent(in) :: lda, ldb, ldc, m, n + integer(${ik}$), intent(in) :: lda, ldb, ldc, m, n character, intent(in) :: side, uplo ! Array Arguments complex(sp), intent(in) :: a(lda,*), b(ldb,*) @@ -1166,7 +1168,7 @@ module stdlib_linalg_blas_c intrinsic :: conjg,max,real ! Local Scalars complex(sp) :: temp1, temp2 - integer(ilp) :: i, info, j, k, nrowa + integer(${ik}$) :: i, info, j, k, nrowa logical(lk) :: upper @@ -1195,7 +1197,7 @@ module stdlib_linalg_blas_c info = 12 end if if (info/=0) then - call stdlib_xerbla('CHEMM ',info) + call stdlib${ii}$_xerbla('CHEMM ',info) return end if ! quick return if possible. @@ -1291,10 +1293,10 @@ module stdlib_linalg_blas_c end do loop_170 end if return - end subroutine stdlib_chemm + end subroutine stdlib${ii}$_chemm - pure subroutine stdlib_chemv(uplo,n,alpha,a,lda,x,incx,beta,y,incy) + pure subroutine stdlib${ii}$_chemv(uplo,n,alpha,a,lda,x,incx,beta,y,incy) !! CHEMV 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 @@ -1304,7 +1306,7 @@ module stdlib_linalg_blas_c ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments complex(sp), intent(in) :: alpha, beta - integer(ilp), intent(in) :: incx, incy, lda, n + integer(${ik}$), intent(in) :: incx, incy, lda, n character, intent(in) :: uplo ! Array Arguments complex(sp), intent(in) :: a(lda,*), x(*) @@ -1314,7 +1316,7 @@ module stdlib_linalg_blas_c ! Local Scalars complex(sp) :: temp1, temp2 - integer(ilp) :: i, info, ix, iy, j, jx, jy, kx, ky + integer(${ik}$) :: i, info, ix, iy, j, jx, jy, kx, ky ! Intrinsic Functions intrinsic :: conjg,max,real ! test the input parameters. @@ -1331,7 +1333,7 @@ module stdlib_linalg_blas_c info = 10 end if if (info/=0) then - call stdlib_xerbla('CHEMV ',info) + call stdlib${ii}$_xerbla('CHEMV ',info) return end if ! quick return if possible. @@ -1444,10 +1446,10 @@ module stdlib_linalg_blas_c end if end if return - end subroutine stdlib_chemv + end subroutine stdlib${ii}$_chemv - pure subroutine stdlib_cher(uplo,n,alpha,x,incx,a,lda) + pure subroutine stdlib${ii}$_cher(uplo,n,alpha,x,incx,a,lda) !! CHER 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 @@ -1457,7 +1459,7 @@ module stdlib_linalg_blas_c ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments real(sp), intent(in) :: alpha - integer(ilp), intent(in) :: incx, lda, n + integer(${ik}$), intent(in) :: incx, lda, n character, intent(in) :: uplo ! Array Arguments complex(sp), intent(inout) :: a(lda,*) @@ -1466,7 +1468,7 @@ module stdlib_linalg_blas_c ! Local Scalars complex(sp) :: temp - integer(ilp) :: i, info, ix, j, jx, kx + integer(${ik}$) :: i, info, ix, j, jx, kx ! Intrinsic Functions intrinsic :: conjg,max,real ! test the input parameters. @@ -1481,7 +1483,7 @@ module stdlib_linalg_blas_c info = 7 end if if (info/=0) then - call stdlib_xerbla('CHER ',info) + call stdlib${ii}$_xerbla('CHER ',info) return end if ! quick return if possible. @@ -1559,10 +1561,10 @@ module stdlib_linalg_blas_c end if end if return - end subroutine stdlib_cher + end subroutine stdlib${ii}$_cher - pure subroutine stdlib_cher2(uplo,n,alpha,x,incx,y,incy,a,lda) + pure subroutine stdlib${ii}$_cher2(uplo,n,alpha,x,incx,y,incy,a,lda) !! CHER2 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 @@ -1572,7 +1574,7 @@ module stdlib_linalg_blas_c ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments complex(sp), intent(in) :: alpha - integer(ilp), intent(in) :: incx, incy, lda, n + integer(${ik}$), intent(in) :: incx, incy, lda, n character, intent(in) :: uplo ! Array Arguments complex(sp), intent(inout) :: a(lda,*) @@ -1581,7 +1583,7 @@ module stdlib_linalg_blas_c ! Local Scalars complex(sp) :: temp1, temp2 - integer(ilp) :: i, info, ix, iy, j, jx, jy, kx, ky + integer(${ik}$) :: i, info, ix, iy, j, jx, jy, kx, ky ! Intrinsic Functions intrinsic :: conjg,max,real ! test the input parameters. @@ -1598,7 +1600,7 @@ module stdlib_linalg_blas_c info = 9 end if if (info/=0) then - call stdlib_xerbla('CHER2 ',info) + call stdlib${ii}$_xerbla('CHER2 ',info) return end if ! quick return if possible. @@ -1698,10 +1700,10 @@ module stdlib_linalg_blas_c end if end if return - end subroutine stdlib_cher2 + end subroutine stdlib${ii}$_cher2 - pure subroutine stdlib_cher2k(uplo,trans,n,k,alpha,a,lda,b,ldb,beta,c,ldc) + pure subroutine stdlib${ii}$_cher2k(uplo,trans,n,k,alpha,a,lda,b,ldb,beta,c,ldc) !! CHER2K performs one of the hermitian rank 2k operations !! C := alpha*A*B**H + conjg( alpha )*B*A**H + beta*C, !! or @@ -1715,7 +1717,7 @@ module stdlib_linalg_blas_c ! Scalar Arguments complex(sp), intent(in) :: alpha real(sp), intent(in) :: beta - integer(ilp), intent(in) :: k, lda, ldb, ldc, n + integer(${ik}$), intent(in) :: k, lda, ldb, ldc, n character, intent(in) :: trans, uplo ! Array Arguments complex(sp), intent(in) :: a(lda,*), b(ldb,*) @@ -1725,7 +1727,7 @@ module stdlib_linalg_blas_c intrinsic :: conjg,max,real ! Local Scalars complex(sp) :: temp1, temp2 - integer(ilp) :: i, info, j, l, nrowa + integer(${ik}$) :: i, info, j, l, nrowa logical(lk) :: upper @@ -1754,7 +1756,7 @@ module stdlib_linalg_blas_c info = 12 end if if (info/=0) then - call stdlib_xerbla('CHER2K',info) + call stdlib${ii}$_xerbla('CHER2K',info) return end if ! quick return if possible. @@ -1907,10 +1909,10 @@ module stdlib_linalg_blas_c end if end if return - end subroutine stdlib_cher2k + end subroutine stdlib${ii}$_cher2k - pure subroutine stdlib_cherk(uplo,trans,n,k,alpha,a,lda,beta,c,ldc) + pure subroutine stdlib${ii}$_cherk(uplo,trans,n,k,alpha,a,lda,beta,c,ldc) !! CHERK performs one of the hermitian rank k operations !! C := alpha*A*A**H + beta*C, !! or @@ -1923,7 +1925,7 @@ module stdlib_linalg_blas_c ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments real(sp), intent(in) :: alpha, beta - integer(ilp), intent(in) :: k, lda, ldc, n + integer(${ik}$), intent(in) :: k, lda, ldc, n character, intent(in) :: trans, uplo ! Array Arguments complex(sp), intent(in) :: a(lda,*) @@ -1934,7 +1936,7 @@ module stdlib_linalg_blas_c ! Local Scalars complex(sp) :: temp real(sp) :: rtemp - integer(ilp) :: i, info, j, l, nrowa + integer(${ik}$) :: i, info, j, l, nrowa logical(lk) :: upper ! test the input parameters. @@ -1960,7 +1962,7 @@ module stdlib_linalg_blas_c info = 10 end if if (info/=0) then - call stdlib_xerbla('CHERK ',info) + call stdlib${ii}$_xerbla('CHERK ',info) return end if ! quick return if possible. @@ -2103,10 +2105,10 @@ module stdlib_linalg_blas_c end if end if return - end subroutine stdlib_cherk + end subroutine stdlib${ii}$_cherk - pure subroutine stdlib_chpmv(uplo,n,alpha,ap,x,incx,beta,y,incy) + pure subroutine stdlib${ii}$_chpmv(uplo,n,alpha,ap,x,incx,beta,y,incy) !! CHPMV 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 @@ -2116,7 +2118,7 @@ module stdlib_linalg_blas_c ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments complex(sp), intent(in) :: alpha, beta - integer(ilp), intent(in) :: incx, incy, n + integer(${ik}$), intent(in) :: incx, incy, n character, intent(in) :: uplo ! Array Arguments complex(sp), intent(in) :: ap(*), x(*) @@ -2126,7 +2128,7 @@ module stdlib_linalg_blas_c ! Local Scalars complex(sp) :: temp1, temp2 - integer(ilp) :: i, info, ix, iy, j, jx, jy, k, kk, kx, ky + integer(${ik}$) :: i, info, ix, iy, j, jx, jy, k, kk, kx, ky ! Intrinsic Functions intrinsic :: conjg,real ! test the input parameters. @@ -2141,7 +2143,7 @@ module stdlib_linalg_blas_c info = 9 end if if (info/=0) then - call stdlib_xerbla('CHPMV ',info) + call stdlib${ii}$_xerbla('CHPMV ',info) return end if ! quick return if possible. @@ -2262,10 +2264,10 @@ module stdlib_linalg_blas_c end if end if return - end subroutine stdlib_chpmv + end subroutine stdlib${ii}$_chpmv - pure subroutine stdlib_chpr(uplo,n,alpha,x,incx,ap) + pure subroutine stdlib${ii}$_chpr(uplo,n,alpha,x,incx,ap) !! CHPR 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 @@ -2275,7 +2277,7 @@ module stdlib_linalg_blas_c ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments real(sp), intent(in) :: alpha - integer(ilp), intent(in) :: incx, n + integer(${ik}$), intent(in) :: incx, n character, intent(in) :: uplo ! Array Arguments complex(sp), intent(inout) :: ap(*) @@ -2284,7 +2286,7 @@ module stdlib_linalg_blas_c ! Local Scalars complex(sp) :: temp - integer(ilp) :: i, info, ix, j, jx, k, kk, kx + integer(${ik}$) :: i, info, ix, j, jx, k, kk, kx ! Intrinsic Functions intrinsic :: conjg,real ! test the input parameters. @@ -2297,7 +2299,7 @@ module stdlib_linalg_blas_c info = 5 end if if (info/=0) then - call stdlib_xerbla('CHPR ',info) + call stdlib${ii}$_xerbla('CHPR ',info) return end if ! quick return if possible. @@ -2384,10 +2386,10 @@ module stdlib_linalg_blas_c end if end if return - end subroutine stdlib_chpr + end subroutine stdlib${ii}$_chpr - pure subroutine stdlib_chpr2(uplo,n,alpha,x,incx,y,incy,ap) + pure subroutine stdlib${ii}$_chpr2(uplo,n,alpha,x,incx,y,incy,ap) !! CHPR2 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 @@ -2397,7 +2399,7 @@ module stdlib_linalg_blas_c ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments complex(sp), intent(in) :: alpha - integer(ilp), intent(in) :: incx, incy, n + integer(${ik}$), intent(in) :: incx, incy, n character, intent(in) :: uplo ! Array Arguments complex(sp), intent(inout) :: ap(*) @@ -2406,7 +2408,7 @@ module stdlib_linalg_blas_c ! Local Scalars complex(sp) :: temp1, temp2 - integer(ilp) :: i, info, ix, iy, j, jx, jy, k, kk, kx, ky + integer(${ik}$) :: i, info, ix, iy, j, jx, jy, k, kk, kx, ky ! Intrinsic Functions intrinsic :: conjg,real ! test the input parameters. @@ -2421,7 +2423,7 @@ module stdlib_linalg_blas_c info = 7 end if if (info/=0) then - call stdlib_xerbla('CHPR2 ',info) + call stdlib${ii}$_xerbla('CHPR2 ',info) return end if ! quick return if possible. @@ -2529,10 +2531,10 @@ module stdlib_linalg_blas_c end if end if return - end subroutine stdlib_chpr2 + end subroutine stdlib${ii}$_chpr2 - pure subroutine stdlib_crotg( a, b, c, s ) + pure subroutine stdlib${ii}$_crotg( a, b, c, s ) !! The computation uses the formulas !! |x| = sqrt( Re(x)**2 + Im(x)**2 ) !! sgn(x) = x / |x| if x /= 0 @@ -2642,22 +2644,22 @@ module stdlib_linalg_blas_c end if a = r return - end subroutine stdlib_crotg + end subroutine stdlib${ii}$_crotg - pure subroutine stdlib_cscal(n,ca,cx,incx) + pure subroutine stdlib${ii}$_cscal(n,ca,cx,incx) !! CSCAL 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(sp), intent(in) :: ca - integer(ilp), intent(in) :: incx, n + integer(${ik}$), intent(in) :: incx, n ! Array Arguments complex(sp), intent(inout) :: cx(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, nincx + integer(${ik}$) :: i, nincx if (n<=0 .or. incx<=0) return if (incx==1) then ! code for increment equal to 1 @@ -2672,10 +2674,10 @@ module stdlib_linalg_blas_c end do end if return - end subroutine stdlib_cscal + end subroutine stdlib${ii}$_cscal - pure subroutine stdlib_csrot( n, cx, incx, cy, incy, c, s ) + pure subroutine stdlib${ii}$_csrot( n, cx, incx, cy, incy, c, s ) !! CSROT 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. @@ -2683,13 +2685,13 @@ module stdlib_linalg_blas_c ! -- 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, incy, n + integer(${ik}$), intent(in) :: incx, incy, n real(sp), intent(in) :: c, s ! Array Arguments complex(sp), intent(inout) :: cx(*), cy(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, ix, iy + integer(${ik}$) :: i, ix, iy complex(sp) :: ctemp ! Executable Statements if( n<=0 )return @@ -2716,22 +2718,22 @@ module stdlib_linalg_blas_c end do end if return - end subroutine stdlib_csrot + end subroutine stdlib${ii}$_csrot - pure subroutine stdlib_csscal(n,sa,cx,incx) + pure subroutine stdlib${ii}$_csscal(n,sa,cx,incx) !! CSSCAL scales a complex vector by a real 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(sp), intent(in) :: sa - integer(ilp), intent(in) :: incx, n + integer(${ik}$), intent(in) :: incx, n ! Array Arguments complex(sp), intent(inout) :: cx(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, nincx + integer(${ik}$) :: i, nincx ! Intrinsic Functions intrinsic :: aimag,cmplx,real if (n<=0 .or. incx<=0) return @@ -2748,22 +2750,22 @@ module stdlib_linalg_blas_c end do end if return - end subroutine stdlib_csscal + end subroutine stdlib${ii}$_csscal - pure subroutine stdlib_cswap(n,cx,incx,cy,incy) + pure subroutine stdlib${ii}$_cswap(n,cx,incx,cy,incy) !! CSWAP interchanges two vectors. ! -- 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, incy, n + integer(${ik}$), intent(in) :: incx, incy, n ! Array Arguments complex(sp), intent(inout) :: cx(*), cy(*) ! ===================================================================== ! Local Scalars complex(sp) :: ctemp - integer(ilp) :: i, ix, iy + integer(${ik}$) :: i, ix, iy if (n<=0) return if (incx==1 .and. incy==1) then ! code for both increments equal to 1 @@ -2788,10 +2790,10 @@ module stdlib_linalg_blas_c end do end if return - end subroutine stdlib_cswap + end subroutine stdlib${ii}$_cswap - pure subroutine stdlib_csymm(side,uplo,m,n,alpha,a,lda,b,ldb,beta,c,ldc) + pure subroutine stdlib${ii}$_csymm(side,uplo,m,n,alpha,a,lda,b,ldb,beta,c,ldc) !! CSYMM performs one of the matrix-matrix operations !! C := alpha*A*B + beta*C, !! or @@ -2803,7 +2805,7 @@ module stdlib_linalg_blas_c ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments complex(sp), intent(in) :: alpha, beta - integer(ilp), intent(in) :: lda, ldb, ldc, m, n + integer(${ik}$), intent(in) :: lda, ldb, ldc, m, n character, intent(in) :: side, uplo ! Array Arguments complex(sp), intent(in) :: a(lda,*), b(ldb,*) @@ -2813,7 +2815,7 @@ module stdlib_linalg_blas_c intrinsic :: max ! Local Scalars complex(sp) :: temp1, temp2 - integer(ilp) :: i, info, j, k, nrowa + integer(${ik}$) :: i, info, j, k, nrowa logical(lk) :: upper @@ -2842,7 +2844,7 @@ module stdlib_linalg_blas_c info = 12 end if if (info/=0) then - call stdlib_xerbla('CSYMM ',info) + call stdlib${ii}$_xerbla('CSYMM ',info) return end if ! quick return if possible. @@ -2936,10 +2938,10 @@ module stdlib_linalg_blas_c end do loop_170 end if return - end subroutine stdlib_csymm + end subroutine stdlib${ii}$_csymm - pure subroutine stdlib_csyr2k(uplo,trans,n,k,alpha,a,lda,b,ldb,beta,c,ldc) + pure subroutine stdlib${ii}$_csyr2k(uplo,trans,n,k,alpha,a,lda,b,ldb,beta,c,ldc) !! CSYR2K performs one of the symmetric rank 2k operations !! C := alpha*A*B**T + alpha*B*A**T + beta*C, !! or @@ -2952,7 +2954,7 @@ module stdlib_linalg_blas_c ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments complex(sp), intent(in) :: alpha, beta - integer(ilp), intent(in) :: k, lda, ldb, ldc, n + integer(${ik}$), intent(in) :: k, lda, ldb, ldc, n character, intent(in) :: trans, uplo ! Array Arguments complex(sp), intent(in) :: a(lda,*), b(ldb,*) @@ -2962,7 +2964,7 @@ module stdlib_linalg_blas_c intrinsic :: max ! Local Scalars complex(sp) :: temp1, temp2 - integer(ilp) :: i, info, j, l, nrowa + integer(${ik}$) :: i, info, j, l, nrowa logical(lk) :: upper @@ -2991,7 +2993,7 @@ module stdlib_linalg_blas_c info = 12 end if if (info/=0) then - call stdlib_xerbla('CSYR2K',info) + call stdlib${ii}$_xerbla('CSYR2K',info) return end if ! quick return if possible. @@ -3112,10 +3114,10 @@ module stdlib_linalg_blas_c end if end if return - end subroutine stdlib_csyr2k + end subroutine stdlib${ii}$_csyr2k - pure subroutine stdlib_csyrk(uplo,trans,n,k,alpha,a,lda,beta,c,ldc) + pure subroutine stdlib${ii}$_csyrk(uplo,trans,n,k,alpha,a,lda,beta,c,ldc) !! CSYRK performs one of the symmetric rank k operations !! C := alpha*A*A**T + beta*C, !! or @@ -3128,7 +3130,7 @@ module stdlib_linalg_blas_c ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments complex(sp), intent(in) :: alpha, beta - integer(ilp), intent(in) :: k, lda, ldc, n + integer(${ik}$), intent(in) :: k, lda, ldc, n character, intent(in) :: trans, uplo ! Array Arguments complex(sp), intent(in) :: a(lda,*) @@ -3138,7 +3140,7 @@ module stdlib_linalg_blas_c intrinsic :: max ! Local Scalars complex(sp) :: temp - integer(ilp) :: i, info, j, l, nrowa + integer(${ik}$) :: i, info, j, l, nrowa logical(lk) :: upper @@ -3165,7 +3167,7 @@ module stdlib_linalg_blas_c info = 10 end if if (info/=0) then - call stdlib_xerbla('CSYRK ',info) + call stdlib${ii}$_xerbla('CSYRK ',info) return end if ! quick return if possible. @@ -3280,10 +3282,10 @@ module stdlib_linalg_blas_c end if end if return - end subroutine stdlib_csyrk + end subroutine stdlib${ii}$_csyrk - pure subroutine stdlib_ctbmv(uplo,trans,diag,n,k,a,lda,x,incx) + pure subroutine stdlib${ii}$_ctbmv(uplo,trans,diag,n,k,a,lda,x,incx) !! CTBMV 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, @@ -3292,7 +3294,7 @@ module stdlib_linalg_blas_c ! -- 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, k, lda, n + integer(${ik}$), intent(in) :: incx, k, lda, n character, intent(in) :: diag, trans, uplo ! Array Arguments complex(sp), intent(in) :: a(lda,*) @@ -3301,7 +3303,7 @@ module stdlib_linalg_blas_c ! Local Scalars complex(sp) :: temp - integer(ilp) :: i, info, ix, j, jx, kplus1, kx, l + integer(${ik}$) :: i, info, ix, j, jx, kplus1, kx, l logical(lk) :: noconj, nounit ! Intrinsic Functions intrinsic :: conjg,max,min @@ -3324,7 +3326,7 @@ module stdlib_linalg_blas_c info = 9 end if if (info/=0) then - call stdlib_xerbla('CTBMV ',info) + call stdlib${ii}$_xerbla('CTBMV ',info) return end if ! quick return if possible. @@ -3494,10 +3496,10 @@ module stdlib_linalg_blas_c end if end if return - end subroutine stdlib_ctbmv + end subroutine stdlib${ii}$_ctbmv - pure subroutine stdlib_ctbsv(uplo,trans,diag,n,k,a,lda,x,incx) + pure subroutine stdlib${ii}$_ctbsv(uplo,trans,diag,n,k,a,lda,x,incx) !! CTBSV 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 @@ -3509,7 +3511,7 @@ module stdlib_linalg_blas_c ! -- 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, k, lda, n + integer(${ik}$), intent(in) :: incx, k, lda, n character, intent(in) :: diag, trans, uplo ! Array Arguments complex(sp), intent(in) :: a(lda,*) @@ -3518,7 +3520,7 @@ module stdlib_linalg_blas_c ! Local Scalars complex(sp) :: temp - integer(ilp) :: i, info, ix, j, jx, kplus1, kx, l + integer(${ik}$) :: i, info, ix, j, jx, kplus1, kx, l logical(lk) :: noconj, nounit ! Intrinsic Functions intrinsic :: conjg,max,min @@ -3541,7 +3543,7 @@ module stdlib_linalg_blas_c info = 9 end if if (info/=0) then - call stdlib_xerbla('CTBSV ',info) + call stdlib${ii}$_xerbla('CTBSV ',info) return end if ! quick return if possible. @@ -3711,10 +3713,10 @@ module stdlib_linalg_blas_c end if end if return - end subroutine stdlib_ctbsv + end subroutine stdlib${ii}$_ctbsv - pure subroutine stdlib_ctpmv(uplo,trans,diag,n,ap,x,incx) + pure subroutine stdlib${ii}$_ctpmv(uplo,trans,diag,n,ap,x,incx) !! CTPMV 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, @@ -3723,7 +3725,7 @@ module stdlib_linalg_blas_c ! -- 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 + integer(${ik}$), intent(in) :: incx, n character, intent(in) :: diag, trans, uplo ! Array Arguments complex(sp), intent(in) :: ap(*) @@ -3732,7 +3734,7 @@ module stdlib_linalg_blas_c ! Local Scalars complex(sp) :: temp - integer(ilp) :: i, info, ix, j, jx, k, kk, kx + integer(${ik}$) :: i, info, ix, j, jx, k, kk, kx logical(lk) :: noconj, nounit ! Intrinsic Functions intrinsic :: conjg @@ -3751,7 +3753,7 @@ module stdlib_linalg_blas_c info = 7 end if if (info/=0) then - call stdlib_xerbla('CTPMV ',info) + call stdlib${ii}$_xerbla('CTPMV ',info) return end if ! quick return if possible. @@ -3928,10 +3930,10 @@ module stdlib_linalg_blas_c end if end if return - end subroutine stdlib_ctpmv + end subroutine stdlib${ii}$_ctpmv - pure subroutine stdlib_ctpsv(uplo,trans,diag,n,ap,x,incx) + pure subroutine stdlib${ii}$_ctpsv(uplo,trans,diag,n,ap,x,incx) !! CTPSV 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 @@ -3942,7 +3944,7 @@ module stdlib_linalg_blas_c ! -- 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 + integer(${ik}$), intent(in) :: incx, n character, intent(in) :: diag, trans, uplo ! Array Arguments complex(sp), intent(in) :: ap(*) @@ -3951,7 +3953,7 @@ module stdlib_linalg_blas_c ! Local Scalars complex(sp) :: temp - integer(ilp) :: i, info, ix, j, jx, k, kk, kx + integer(${ik}$) :: i, info, ix, j, jx, k, kk, kx logical(lk) :: noconj, nounit ! Intrinsic Functions intrinsic :: conjg @@ -3970,7 +3972,7 @@ module stdlib_linalg_blas_c info = 7 end if if (info/=0) then - call stdlib_xerbla('CTPSV ',info) + call stdlib${ii}$_xerbla('CTPSV ',info) return end if ! quick return if possible. @@ -4147,10 +4149,10 @@ module stdlib_linalg_blas_c end if end if return - end subroutine stdlib_ctpsv + end subroutine stdlib${ii}$_ctpsv - pure subroutine stdlib_ctrmm(side,uplo,transa,diag,m,n,alpha,a,lda,b,ldb) + pure subroutine stdlib${ii}$_ctrmm(side,uplo,transa,diag,m,n,alpha,a,lda,b,ldb) !! CTRMM 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 @@ -4161,7 +4163,7 @@ module stdlib_linalg_blas_c ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments complex(sp), intent(in) :: alpha - integer(ilp), intent(in) :: lda, ldb, m, n + integer(${ik}$), intent(in) :: lda, ldb, m, n character, intent(in) :: diag, side, transa, uplo ! Array Arguments complex(sp), intent(in) :: a(lda,*) @@ -4171,7 +4173,7 @@ module stdlib_linalg_blas_c intrinsic :: conjg,max ! Local Scalars complex(sp) :: temp - integer(ilp) :: i, info, j, k, nrowa + integer(${ik}$) :: i, info, j, k, nrowa logical(lk) :: lside, noconj, nounit, upper @@ -4206,7 +4208,7 @@ module stdlib_linalg_blas_c info = 11 end if if (info/=0) then - call stdlib_xerbla('CTRMM ',info) + call stdlib${ii}$_xerbla('CTRMM ',info) return end if ! quick return if possible. @@ -4389,10 +4391,10 @@ module stdlib_linalg_blas_c end if end if return - end subroutine stdlib_ctrmm + end subroutine stdlib${ii}$_ctrmm - pure subroutine stdlib_ctrmv(uplo,trans,diag,n,a,lda,x,incx) + pure subroutine stdlib${ii}$_ctrmv(uplo,trans,diag,n,a,lda,x,incx) !! CTRMV 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, @@ -4401,7 +4403,7 @@ module stdlib_linalg_blas_c ! -- 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, lda, n + integer(${ik}$), intent(in) :: incx, lda, n character, intent(in) :: diag, trans, uplo ! Array Arguments complex(sp), intent(in) :: a(lda,*) @@ -4410,7 +4412,7 @@ module stdlib_linalg_blas_c ! Local Scalars complex(sp) :: temp - integer(ilp) :: i, info, ix, j, jx, kx + integer(${ik}$) :: i, info, ix, j, jx, kx logical(lk) :: noconj, nounit ! Intrinsic Functions intrinsic :: conjg,max @@ -4431,7 +4433,7 @@ module stdlib_linalg_blas_c info = 8 end if if (info/=0) then - call stdlib_xerbla('CTRMV ',info) + call stdlib${ii}$_xerbla('CTRMV ',info) return end if ! quick return if possible. @@ -4586,10 +4588,10 @@ module stdlib_linalg_blas_c end if end if return - end subroutine stdlib_ctrmv + end subroutine stdlib${ii}$_ctrmv - pure subroutine stdlib_ctrsm(side,uplo,transa,diag,m,n,alpha,a,lda,b,ldb) + pure subroutine stdlib${ii}$_ctrsm(side,uplo,transa,diag,m,n,alpha,a,lda,b,ldb) !! CTRSM 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 @@ -4601,7 +4603,7 @@ module stdlib_linalg_blas_c ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments complex(sp), intent(in) :: alpha - integer(ilp), intent(in) :: lda, ldb, m, n + integer(${ik}$), intent(in) :: lda, ldb, m, n character, intent(in) :: diag, side, transa, uplo ! Array Arguments complex(sp), intent(in) :: a(lda,*) @@ -4611,7 +4613,7 @@ module stdlib_linalg_blas_c intrinsic :: conjg,max ! Local Scalars complex(sp) :: temp - integer(ilp) :: i, info, j, k, nrowa + integer(${ik}$) :: i, info, j, k, nrowa logical(lk) :: lside, noconj, nounit, upper @@ -4646,7 +4648,7 @@ module stdlib_linalg_blas_c info = 11 end if if (info/=0) then - call stdlib_xerbla('CTRSM ',info) + call stdlib${ii}$_xerbla('CTRSM ',info) return end if ! quick return if possible. @@ -4851,10 +4853,10 @@ module stdlib_linalg_blas_c end if end if return - end subroutine stdlib_ctrsm + end subroutine stdlib${ii}$_ctrsm - pure subroutine stdlib_ctrsv(uplo,trans,diag,n,a,lda,x,incx) + pure subroutine stdlib${ii}$_ctrsv(uplo,trans,diag,n,a,lda,x,incx) !! CTRSV 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 @@ -4865,7 +4867,7 @@ module stdlib_linalg_blas_c ! -- 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, lda, n + integer(${ik}$), intent(in) :: incx, lda, n character, intent(in) :: diag, trans, uplo ! Array Arguments complex(sp), intent(in) :: a(lda,*) @@ -4874,7 +4876,7 @@ module stdlib_linalg_blas_c ! Local Scalars complex(sp) :: temp - integer(ilp) :: i, info, ix, j, jx, kx + integer(${ik}$) :: i, info, ix, j, jx, kx logical(lk) :: noconj, nounit ! Intrinsic Functions intrinsic :: conjg,max @@ -4895,7 +4897,7 @@ module stdlib_linalg_blas_c info = 8 end if if (info/=0) then - call stdlib_xerbla('CTRSV ',info) + call stdlib${ii}$_xerbla('CTRSV ',info) return end if ! quick return if possible. @@ -5050,8 +5052,8 @@ module stdlib_linalg_blas_c end if end if return - end subroutine stdlib_ctrsv - + end subroutine stdlib${ii}$_ctrsv + #:endfor end module stdlib_linalg_blas_c From 9690464d4a4b5ce3283f52bab38f1c6cac428e9c Mon Sep 17 00:00:00 2001 From: Federico Perini Date: Wed, 13 Nov 2024 18:42:17 +0100 Subject: [PATCH 09/31] `blas_z`: template integer type --- src/stdlib_linalg_blas_z.fypp | 414 +++++++++++++++++----------------- 1 file changed, 208 insertions(+), 206 deletions(-) diff --git a/src/stdlib_linalg_blas_z.fypp b/src/stdlib_linalg_blas_z.fypp index e56a68443..12ce6ea87 100644 --- a/src/stdlib_linalg_blas_z.fypp +++ b/src/stdlib_linalg_blas_z.fypp @@ -9,42 +9,44 @@ module stdlib_linalg_blas_z private - public :: sp,dp,qp,lk,ilp - public :: stdlib_zaxpy - public :: stdlib_zcopy - public :: stdlib_zdotc - public :: stdlib_zdotu - public :: stdlib_zdrot - public :: stdlib_zdscal - public :: stdlib_zgbmv - public :: stdlib_zgemm - public :: stdlib_zgemv - public :: stdlib_zgerc - public :: stdlib_zgeru - public :: stdlib_zhbmv - public :: stdlib_zhemm - public :: stdlib_zhemv - public :: stdlib_zher - public :: stdlib_zher2 - public :: stdlib_zher2k - public :: stdlib_zherk - public :: stdlib_zhpmv - public :: stdlib_zhpr - public :: stdlib_zhpr2 - public :: stdlib_zrotg - public :: stdlib_zscal - public :: stdlib_zswap - public :: stdlib_zsymm - public :: stdlib_zsyr2k - public :: stdlib_zsyrk - public :: stdlib_ztbmv - public :: stdlib_ztbsv - public :: stdlib_ztpmv - public :: stdlib_ztpsv - public :: stdlib_ztrmm - public :: stdlib_ztrmv - public :: stdlib_ztrsm - public :: stdlib_ztrsv + public :: sp,dp,qp,lk,ilp,ilp64 + #:for ik,it,ii in LINALG_INT_KINDS_TYPES + public :: stdlib${ii}$_zaxpy + public :: stdlib${ii}$_zcopy + public :: stdlib${ii}$_zdotc + public :: stdlib${ii}$_zdotu + public :: stdlib${ii}$_zdrot + public :: stdlib${ii}$_zdscal + public :: stdlib${ii}$_zgbmv + public :: stdlib${ii}$_zgemm + public :: stdlib${ii}$_zgemv + public :: stdlib${ii}$_zgerc + public :: stdlib${ii}$_zgeru + public :: stdlib${ii}$_zhbmv + public :: stdlib${ii}$_zhemm + public :: stdlib${ii}$_zhemv + public :: stdlib${ii}$_zher + public :: stdlib${ii}$_zher2 + public :: stdlib${ii}$_zher2k + public :: stdlib${ii}$_zherk + public :: stdlib${ii}$_zhpmv + public :: stdlib${ii}$_zhpr + public :: stdlib${ii}$_zhpr2 + public :: stdlib${ii}$_zrotg + public :: stdlib${ii}$_zscal + public :: stdlib${ii}$_zswap + public :: stdlib${ii}$_zsymm + public :: stdlib${ii}$_zsyr2k + public :: stdlib${ii}$_zsyrk + public :: stdlib${ii}$_ztbmv + public :: stdlib${ii}$_ztbsv + public :: stdlib${ii}$_ztpmv + public :: stdlib${ii}$_ztpsv + public :: stdlib${ii}$_ztrmm + public :: stdlib${ii}$_ztrmv + public :: stdlib${ii}$_ztrsm + public :: stdlib${ii}$_ztrsv + #:endfor ! 64-bit real constants real(dp), parameter, private :: negone = -1.00_dp @@ -86,21 +88,21 @@ module stdlib_linalg_blas_z contains - - pure subroutine stdlib_zaxpy(n,za,zx,incx,zy,incy) + #:for ik,it,ii in LINALG_INT_KINDS_TYPES + pure subroutine stdlib${ii}$_zaxpy(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(dp), intent(in) :: za - integer(ilp), intent(in) :: incx, incy, n + integer(${ik}$), intent(in) :: incx, incy, n ! Array Arguments complex(dp), intent(in) :: zx(*) complex(dp), intent(inout) :: zy(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, ix, iy + integer(${ik}$) :: i, ix, iy if (n<=0) return if (stdlib_cabs1(za)==0.0_dp) return if (incx==1 .and. incy==1) then @@ -122,22 +124,22 @@ module stdlib_linalg_blas_z end do end if return - end subroutine stdlib_zaxpy + end subroutine stdlib${ii}$_zaxpy - pure subroutine stdlib_zcopy(n,zx,incx,zy,incy) + pure subroutine stdlib${ii}$_zcopy(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, -- ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments - integer(ilp), intent(in) :: incx, incy, n + integer(${ik}$), intent(in) :: incx, incy, n ! Array Arguments complex(dp), intent(in) :: zx(*) complex(dp), intent(out) :: zy(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, ix, iy + integer(${ik}$) :: i, ix, iy if (n<=0) return if (incx==1 .and. incy==1) then ! code for both increments equal to 1 @@ -158,27 +160,27 @@ module stdlib_linalg_blas_z end do end if return - end subroutine stdlib_zcopy + end subroutine stdlib${ii}$_zcopy - pure complex(dp) function stdlib_zdotc(n,zx,incx,zy,incy) + pure complex(dp) function stdlib${ii}$_zdotc(n,zx,incx,zy,incy) !! ZDOTC forms the dot product of two complex vectors !! ZDOTC = X^H * Y ! -- 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, incy, n + integer(${ik}$), intent(in) :: incx, incy, n ! Array Arguments complex(dp), intent(in) :: zx(*), zy(*) ! ===================================================================== ! Local Scalars complex(dp) :: ztemp - integer(ilp) :: i, ix, iy + integer(${ik}$) :: i, ix, iy ! Intrinsic Functions intrinsic :: conjg ztemp = (0.0_dp,0.0_dp) - stdlib_zdotc = (0.0_dp,0.0_dp) + stdlib${ii}$_zdotc = (0.0_dp,0.0_dp) if (n<=0) return if (incx==1 .and. incy==1) then ! code for both increments equal to 1 @@ -198,27 +200,27 @@ module stdlib_linalg_blas_z iy = iy + incy end do end if - stdlib_zdotc = ztemp + stdlib${ii}$_zdotc = ztemp return - end function stdlib_zdotc + end function stdlib${ii}$_zdotc - pure complex(dp) function stdlib_zdotu(n,zx,incx,zy,incy) + pure complex(dp) function stdlib${ii}$_zdotu(n,zx,incx,zy,incy) !! ZDOTU forms the dot product of two complex vectors !! ZDOTU = X^T * Y ! -- 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, incy, n + integer(${ik}$), intent(in) :: incx, incy, n ! Array Arguments complex(dp), intent(in) :: zx(*), zy(*) ! ===================================================================== ! Local Scalars complex(dp) :: ztemp - integer(ilp) :: i, ix, iy + integer(${ik}$) :: i, ix, iy ztemp = (0.0_dp,0.0_dp) - stdlib_zdotu = (0.0_dp,0.0_dp) + stdlib${ii}$_zdotu = (0.0_dp,0.0_dp) if (n<=0) return if (incx==1 .and. incy==1) then ! code for both increments equal to 1 @@ -238,12 +240,12 @@ module stdlib_linalg_blas_z iy = iy + incy end do end if - stdlib_zdotu = ztemp + stdlib${ii}$_zdotu = ztemp return - end function stdlib_zdotu + end function stdlib${ii}$_zdotu - pure subroutine stdlib_zdrot( n, zx, incx, zy, incy, c, s ) + pure subroutine stdlib${ii}$_zdrot( 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. @@ -251,13 +253,13 @@ module stdlib_linalg_blas_z ! -- 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, incy, n + integer(${ik}$), intent(in) :: incx, incy, n real(dp), intent(in) :: c, s ! Array Arguments complex(dp), intent(inout) :: zx(*), zy(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, ix, iy + integer(${ik}$) :: i, ix, iy complex(dp) :: ctemp ! Executable Statements if( n<=0 )return @@ -284,22 +286,22 @@ module stdlib_linalg_blas_z end do end if return - end subroutine stdlib_zdrot + end subroutine stdlib${ii}$_zdrot - pure subroutine stdlib_zdscal(n,da,zx,incx) + pure subroutine stdlib${ii}$_zdscal(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(dp), intent(in) :: da - integer(ilp), intent(in) :: incx, n + integer(${ik}$), intent(in) :: incx, n ! Array Arguments complex(dp), intent(inout) :: zx(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, nincx + integer(${ik}$) :: i, nincx ! Intrinsic Functions intrinsic :: cmplx if (n<=0 .or. incx<=0) return @@ -316,10 +318,10 @@ module stdlib_linalg_blas_z end do end if return - end subroutine stdlib_zdscal + end subroutine stdlib${ii}$_zdscal - pure subroutine stdlib_zgbmv(trans,m,n,kl,ku,alpha,a,lda,x,incx,beta,y,incy) + pure subroutine stdlib${ii}$_zgbmv(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, @@ -330,7 +332,7 @@ module stdlib_linalg_blas_z ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments complex(dp), intent(in) :: alpha, beta - integer(ilp), intent(in) :: incx, incy, kl, ku, lda, m, n + integer(${ik}$), intent(in) :: incx, incy, kl, ku, lda, m, n character, intent(in) :: trans ! Array Arguments complex(dp), intent(in) :: a(lda,*), x(*) @@ -340,7 +342,7 @@ module stdlib_linalg_blas_z ! Local Scalars complex(dp) :: temp - integer(ilp) :: i, info, ix, iy, j, jx, jy, k, kup1, kx, ky, lenx, leny + integer(${ik}$) :: i, info, ix, iy, j, jx, jy, k, kup1, kx, ky, lenx, leny logical(lk) :: noconj ! Intrinsic Functions intrinsic :: conjg,max,min @@ -365,7 +367,7 @@ module stdlib_linalg_blas_z info = 13 end if if (info/=0) then - call stdlib_xerbla('ZGBMV ',info) + call stdlib${ii}$_xerbla('ZGBMV ',info) return end if ! quick return if possible. @@ -488,10 +490,10 @@ module stdlib_linalg_blas_z end if end if return - end subroutine stdlib_zgbmv + end subroutine stdlib${ii}$_zgbmv - pure subroutine stdlib_zgemm(transa,transb,m,n,k,alpha,a,lda,b,ldb,beta,c,ldc) + pure subroutine stdlib${ii}$_zgemm(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 @@ -503,7 +505,7 @@ module stdlib_linalg_blas_z ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments complex(dp), intent(in) :: alpha, beta - integer(ilp), intent(in) :: k, lda, ldb, ldc, m, n + integer(${ik}$), intent(in) :: k, lda, ldb, ldc, m, n character, intent(in) :: transa, transb ! Array Arguments complex(dp), intent(in) :: a(lda,*), b(ldb,*) @@ -513,7 +515,7 @@ module stdlib_linalg_blas_z intrinsic :: conjg,max ! Local Scalars complex(dp) :: temp - integer(ilp) :: i, info, j, l, nrowa, nrowb + integer(${ik}$) :: i, info, j, l, nrowa, nrowb logical(lk) :: conja, conjb, nota, notb @@ -556,7 +558,7 @@ module stdlib_linalg_blas_z info = 13 end if if (info/=0) then - call stdlib_xerbla('ZGEMM ',info) + call stdlib${ii}$_xerbla('ZGEMM ',info) return end if ! quick return if possible. @@ -737,10 +739,10 @@ module stdlib_linalg_blas_z end if end if return - end subroutine stdlib_zgemm + end subroutine stdlib${ii}$_zgemm - pure subroutine stdlib_zgemv(trans,m,n,alpha,a,lda,x,incx,beta,y,incy) + pure subroutine stdlib${ii}$_zgemv(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, @@ -751,7 +753,7 @@ module stdlib_linalg_blas_z ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments complex(dp), intent(in) :: alpha, beta - integer(ilp), intent(in) :: incx, incy, lda, m, n + integer(${ik}$), intent(in) :: incx, incy, lda, m, n character, intent(in) :: trans ! Array Arguments complex(dp), intent(in) :: a(lda,*), x(*) @@ -761,7 +763,7 @@ module stdlib_linalg_blas_z ! Local Scalars complex(dp) :: temp - integer(ilp) :: i, info, ix, iy, j, jx, jy, kx, ky, lenx, leny + integer(${ik}$) :: i, info, ix, iy, j, jx, jy, kx, ky, lenx, leny logical(lk) :: noconj ! Intrinsic Functions intrinsic :: conjg,max @@ -782,7 +784,7 @@ module stdlib_linalg_blas_z info = 11 end if if (info/=0) then - call stdlib_xerbla('ZGEMV ',info) + call stdlib${ii}$_xerbla('ZGEMV ',info) return end if ! quick return if possible. @@ -898,10 +900,10 @@ module stdlib_linalg_blas_z end if end if return - end subroutine stdlib_zgemv + end subroutine stdlib${ii}$_zgemv - pure subroutine stdlib_zgerc(m,n,alpha,x,incx,y,incy,a,lda) + pure subroutine stdlib${ii}$_zgerc(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 @@ -911,7 +913,7 @@ module stdlib_linalg_blas_z ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments complex(dp), intent(in) :: alpha - integer(ilp), intent(in) :: incx, incy, lda, m, n + integer(${ik}$), intent(in) :: incx, incy, lda, m, n ! Array Arguments complex(dp), intent(inout) :: a(lda,*) complex(dp), intent(in) :: x(*), y(*) @@ -919,7 +921,7 @@ module stdlib_linalg_blas_z ! Local Scalars complex(dp) :: temp - integer(ilp) :: i, info, ix, j, jy, kx + integer(${ik}$) :: i, info, ix, j, jy, kx ! Intrinsic Functions intrinsic :: conjg,max ! test the input parameters. @@ -936,7 +938,7 @@ module stdlib_linalg_blas_z info = 9 end if if (info/=0) then - call stdlib_xerbla('ZGERC ',info) + call stdlib${ii}$_xerbla('ZGERC ',info) return end if ! quick return if possible. @@ -977,10 +979,10 @@ module stdlib_linalg_blas_z end do end if return - end subroutine stdlib_zgerc + end subroutine stdlib${ii}$_zgerc - pure subroutine stdlib_zgeru(m,n,alpha,x,incx,y,incy,a,lda) + pure subroutine stdlib${ii}$_zgeru(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 @@ -990,7 +992,7 @@ module stdlib_linalg_blas_z ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments complex(dp), intent(in) :: alpha - integer(ilp), intent(in) :: incx, incy, lda, m, n + integer(${ik}$), intent(in) :: incx, incy, lda, m, n ! Array Arguments complex(dp), intent(inout) :: a(lda,*) complex(dp), intent(in) :: x(*), y(*) @@ -998,7 +1000,7 @@ module stdlib_linalg_blas_z ! Local Scalars complex(dp) :: temp - integer(ilp) :: i, info, ix, j, jy, kx + integer(${ik}$) :: i, info, ix, j, jy, kx ! Intrinsic Functions intrinsic :: max ! test the input parameters. @@ -1015,7 +1017,7 @@ module stdlib_linalg_blas_z info = 9 end if if (info/=0) then - call stdlib_xerbla('ZGERU ',info) + call stdlib${ii}$_xerbla('ZGERU ',info) return end if ! quick return if possible. @@ -1056,10 +1058,10 @@ module stdlib_linalg_blas_z end do end if return - end subroutine stdlib_zgeru + end subroutine stdlib${ii}$_zgeru - pure subroutine stdlib_zhbmv(uplo,n,k,alpha,a,lda,x,incx,beta,y,incy) + pure subroutine stdlib${ii}$_zhbmv(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 @@ -1069,7 +1071,7 @@ module stdlib_linalg_blas_z ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments complex(dp), intent(in) :: alpha, beta - integer(ilp), intent(in) :: incx, incy, k, lda, n + integer(${ik}$), intent(in) :: incx, incy, k, lda, n character, intent(in) :: uplo ! Array Arguments complex(dp), intent(in) :: a(lda,*), x(*) @@ -1079,7 +1081,7 @@ module stdlib_linalg_blas_z ! Local Scalars complex(dp) :: temp1, temp2 - integer(ilp) :: i, info, ix, iy, j, jx, jy, kplus1, kx, ky, l + integer(${ik}$) :: i, info, ix, iy, j, jx, jy, kplus1, kx, ky, l ! Intrinsic Functions intrinsic :: real,conjg,max,min ! test the input parameters. @@ -1098,7 +1100,7 @@ module stdlib_linalg_blas_z info = 11 end if if (info/=0) then - call stdlib_xerbla('ZHBMV ',info) + call stdlib${ii}$_xerbla('ZHBMV ',info) return end if ! quick return if possible. @@ -1219,10 +1221,10 @@ module stdlib_linalg_blas_z end if end if return - end subroutine stdlib_zhbmv + end subroutine stdlib${ii}$_zhbmv - pure subroutine stdlib_zhemm(side,uplo,m,n,alpha,a,lda,b,ldb,beta,c,ldc) + pure subroutine stdlib${ii}$_zhemm(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 @@ -1234,7 +1236,7 @@ module stdlib_linalg_blas_z ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments complex(dp), intent(in) :: alpha, beta - integer(ilp), intent(in) :: lda, ldb, ldc, m, n + integer(${ik}$), intent(in) :: lda, ldb, ldc, m, n character, intent(in) :: side, uplo ! Array Arguments complex(dp), intent(in) :: a(lda,*), b(ldb,*) @@ -1244,7 +1246,7 @@ module stdlib_linalg_blas_z intrinsic :: real,conjg,max ! Local Scalars complex(dp) :: temp1, temp2 - integer(ilp) :: i, info, j, k, nrowa + integer(${ik}$) :: i, info, j, k, nrowa logical(lk) :: upper @@ -1273,7 +1275,7 @@ module stdlib_linalg_blas_z info = 12 end if if (info/=0) then - call stdlib_xerbla('ZHEMM ',info) + call stdlib${ii}$_xerbla('ZHEMM ',info) return end if ! quick return if possible. @@ -1369,10 +1371,10 @@ module stdlib_linalg_blas_z end do loop_170 end if return - end subroutine stdlib_zhemm + end subroutine stdlib${ii}$_zhemm - pure subroutine stdlib_zhemv(uplo,n,alpha,a,lda,x,incx,beta,y,incy) + pure subroutine stdlib${ii}$_zhemv(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 @@ -1382,7 +1384,7 @@ module stdlib_linalg_blas_z ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments complex(dp), intent(in) :: alpha, beta - integer(ilp), intent(in) :: incx, incy, lda, n + integer(${ik}$), intent(in) :: incx, incy, lda, n character, intent(in) :: uplo ! Array Arguments complex(dp), intent(in) :: a(lda,*), x(*) @@ -1392,7 +1394,7 @@ module stdlib_linalg_blas_z ! Local Scalars complex(dp) :: temp1, temp2 - integer(ilp) :: i, info, ix, iy, j, jx, jy, kx, ky + integer(${ik}$) :: i, info, ix, iy, j, jx, jy, kx, ky ! Intrinsic Functions intrinsic :: real,conjg,max ! test the input parameters. @@ -1409,7 +1411,7 @@ module stdlib_linalg_blas_z info = 10 end if if (info/=0) then - call stdlib_xerbla('ZHEMV ',info) + call stdlib${ii}$_xerbla('ZHEMV ',info) return end if ! quick return if possible. @@ -1522,10 +1524,10 @@ module stdlib_linalg_blas_z end if end if return - end subroutine stdlib_zhemv + end subroutine stdlib${ii}$_zhemv - pure subroutine stdlib_zher(uplo,n,alpha,x,incx,a,lda) + pure subroutine stdlib${ii}$_zher(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 @@ -1535,7 +1537,7 @@ module stdlib_linalg_blas_z ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments real(dp), intent(in) :: alpha - integer(ilp), intent(in) :: incx, lda, n + integer(${ik}$), intent(in) :: incx, lda, n character, intent(in) :: uplo ! Array Arguments complex(dp), intent(inout) :: a(lda,*) @@ -1544,7 +1546,7 @@ module stdlib_linalg_blas_z ! Local Scalars complex(dp) :: temp - integer(ilp) :: i, info, ix, j, jx, kx + integer(${ik}$) :: i, info, ix, j, jx, kx ! Intrinsic Functions intrinsic :: real,conjg,max ! test the input parameters. @@ -1559,7 +1561,7 @@ module stdlib_linalg_blas_z info = 7 end if if (info/=0) then - call stdlib_xerbla('ZHER ',info) + call stdlib${ii}$_xerbla('ZHER ',info) return end if ! quick return if possible. @@ -1637,10 +1639,10 @@ module stdlib_linalg_blas_z end if end if return - end subroutine stdlib_zher + end subroutine stdlib${ii}$_zher - pure subroutine stdlib_zher2(uplo,n,alpha,x,incx,y,incy,a,lda) + pure subroutine stdlib${ii}$_zher2(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 @@ -1650,7 +1652,7 @@ module stdlib_linalg_blas_z ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments complex(dp), intent(in) :: alpha - integer(ilp), intent(in) :: incx, incy, lda, n + integer(${ik}$), intent(in) :: incx, incy, lda, n character, intent(in) :: uplo ! Array Arguments complex(dp), intent(inout) :: a(lda,*) @@ -1659,7 +1661,7 @@ module stdlib_linalg_blas_z ! Local Scalars complex(dp) :: temp1, temp2 - integer(ilp) :: i, info, ix, iy, j, jx, jy, kx, ky + integer(${ik}$) :: i, info, ix, iy, j, jx, jy, kx, ky ! Intrinsic Functions intrinsic :: real,conjg,max ! test the input parameters. @@ -1676,7 +1678,7 @@ module stdlib_linalg_blas_z info = 9 end if if (info/=0) then - call stdlib_xerbla('ZHER2 ',info) + call stdlib${ii}$_xerbla('ZHER2 ',info) return end if ! quick return if possible. @@ -1776,10 +1778,10 @@ module stdlib_linalg_blas_z end if end if return - end subroutine stdlib_zher2 + end subroutine stdlib${ii}$_zher2 - pure subroutine stdlib_zher2k(uplo,trans,n,k,alpha,a,lda,b,ldb,beta,c,ldc) + pure subroutine stdlib${ii}$_zher2k(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 @@ -1793,7 +1795,7 @@ module stdlib_linalg_blas_z ! Scalar Arguments complex(dp), intent(in) :: alpha real(dp), intent(in) :: beta - integer(ilp), intent(in) :: k, lda, ldb, ldc, n + integer(${ik}$), intent(in) :: k, lda, ldb, ldc, n character, intent(in) :: trans, uplo ! Array Arguments complex(dp), intent(in) :: a(lda,*), b(ldb,*) @@ -1803,7 +1805,7 @@ module stdlib_linalg_blas_z intrinsic :: real,conjg,max ! Local Scalars complex(dp) :: temp1, temp2 - integer(ilp) :: i, info, j, l, nrowa + integer(${ik}$) :: i, info, j, l, nrowa logical(lk) :: upper @@ -1832,7 +1834,7 @@ module stdlib_linalg_blas_z info = 12 end if if (info/=0) then - call stdlib_xerbla('ZHER2K',info) + call stdlib${ii}$_xerbla('ZHER2K',info) return end if ! quick return if possible. @@ -1985,10 +1987,10 @@ module stdlib_linalg_blas_z end if end if return - end subroutine stdlib_zher2k + end subroutine stdlib${ii}$_zher2k - pure subroutine stdlib_zherk(uplo,trans,n,k,alpha,a,lda,beta,c,ldc) + pure subroutine stdlib${ii}$_zherk(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 @@ -2001,7 +2003,7 @@ module stdlib_linalg_blas_z ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments real(dp), intent(in) :: alpha, beta - integer(ilp), intent(in) :: k, lda, ldc, n + integer(${ik}$), intent(in) :: k, lda, ldc, n character, intent(in) :: trans, uplo ! Array Arguments complex(dp), intent(in) :: a(lda,*) @@ -2012,7 +2014,7 @@ module stdlib_linalg_blas_z ! Local Scalars complex(dp) :: temp real(dp) :: rtemp - integer(ilp) :: i, info, j, l, nrowa + integer(${ik}$) :: i, info, j, l, nrowa logical(lk) :: upper ! test the input parameters. @@ -2038,7 +2040,7 @@ module stdlib_linalg_blas_z info = 10 end if if (info/=0) then - call stdlib_xerbla('ZHERK ',info) + call stdlib${ii}$_xerbla('ZHERK ',info) return end if ! quick return if possible. @@ -2181,10 +2183,10 @@ module stdlib_linalg_blas_z end if end if return - end subroutine stdlib_zherk + end subroutine stdlib${ii}$_zherk - pure subroutine stdlib_zhpmv(uplo,n,alpha,ap,x,incx,beta,y,incy) + pure subroutine stdlib${ii}$_zhpmv(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 @@ -2194,7 +2196,7 @@ module stdlib_linalg_blas_z ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments complex(dp), intent(in) :: alpha, beta - integer(ilp), intent(in) :: incx, incy, n + integer(${ik}$), intent(in) :: incx, incy, n character, intent(in) :: uplo ! Array Arguments complex(dp), intent(in) :: ap(*), x(*) @@ -2204,7 +2206,7 @@ module stdlib_linalg_blas_z ! Local Scalars complex(dp) :: temp1, temp2 - integer(ilp) :: i, info, ix, iy, j, jx, jy, k, kk, kx, ky + integer(${ik}$) :: i, info, ix, iy, j, jx, jy, k, kk, kx, ky ! Intrinsic Functions intrinsic :: real,conjg ! test the input parameters. @@ -2219,7 +2221,7 @@ module stdlib_linalg_blas_z info = 9 end if if (info/=0) then - call stdlib_xerbla('ZHPMV ',info) + call stdlib${ii}$_xerbla('ZHPMV ',info) return end if ! quick return if possible. @@ -2340,10 +2342,10 @@ module stdlib_linalg_blas_z end if end if return - end subroutine stdlib_zhpmv + end subroutine stdlib${ii}$_zhpmv - pure subroutine stdlib_zhpr(uplo,n,alpha,x,incx,ap) + pure subroutine stdlib${ii}$_zhpr(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 @@ -2353,7 +2355,7 @@ module stdlib_linalg_blas_z ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments real(dp), intent(in) :: alpha - integer(ilp), intent(in) :: incx, n + integer(${ik}$), intent(in) :: incx, n character, intent(in) :: uplo ! Array Arguments complex(dp), intent(inout) :: ap(*) @@ -2362,7 +2364,7 @@ module stdlib_linalg_blas_z ! Local Scalars complex(dp) :: temp - integer(ilp) :: i, info, ix, j, jx, k, kk, kx + integer(${ik}$) :: i, info, ix, j, jx, k, kk, kx ! Intrinsic Functions intrinsic :: real,conjg ! test the input parameters. @@ -2375,7 +2377,7 @@ module stdlib_linalg_blas_z info = 5 end if if (info/=0) then - call stdlib_xerbla('ZHPR ',info) + call stdlib${ii}$_xerbla('ZHPR ',info) return end if ! quick return if possible. @@ -2462,10 +2464,10 @@ module stdlib_linalg_blas_z end if end if return - end subroutine stdlib_zhpr + end subroutine stdlib${ii}$_zhpr - pure subroutine stdlib_zhpr2(uplo,n,alpha,x,incx,y,incy,ap) + pure subroutine stdlib${ii}$_zhpr2(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 @@ -2475,7 +2477,7 @@ module stdlib_linalg_blas_z ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments complex(dp), intent(in) :: alpha - integer(ilp), intent(in) :: incx, incy, n + integer(${ik}$), intent(in) :: incx, incy, n character, intent(in) :: uplo ! Array Arguments complex(dp), intent(inout) :: ap(*) @@ -2484,7 +2486,7 @@ module stdlib_linalg_blas_z ! Local Scalars complex(dp) :: temp1, temp2 - integer(ilp) :: i, info, ix, iy, j, jx, jy, k, kk, kx, ky + integer(${ik}$) :: i, info, ix, iy, j, jx, jy, k, kk, kx, ky ! Intrinsic Functions intrinsic :: real,conjg ! test the input parameters. @@ -2499,7 +2501,7 @@ module stdlib_linalg_blas_z info = 7 end if if (info/=0) then - call stdlib_xerbla('ZHPR2 ',info) + call stdlib${ii}$_xerbla('ZHPR2 ',info) return end if ! quick return if possible. @@ -2607,10 +2609,10 @@ module stdlib_linalg_blas_z end if end if return - end subroutine stdlib_zhpr2 + end subroutine stdlib${ii}$_zhpr2 - pure subroutine stdlib_zrotg( a, b, c, s ) + pure subroutine stdlib${ii}$_zrotg( a, b, c, s ) !! The computation uses the formulas !! |x| = sqrt( Re(x)**2 + Im(x)**2 ) !! sgn(x) = x / |x| if x /= 0 @@ -2720,22 +2722,22 @@ module stdlib_linalg_blas_z end if a = r return - end subroutine stdlib_zrotg + end subroutine stdlib${ii}$_zrotg - pure subroutine stdlib_zscal(n,za,zx,incx) + pure subroutine stdlib${ii}$_zscal(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(dp), intent(in) :: za - integer(ilp), intent(in) :: incx, n + integer(${ik}$), intent(in) :: incx, n ! Array Arguments complex(dp), intent(inout) :: zx(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, nincx + integer(${ik}$) :: i, nincx if (n<=0 .or. incx<=0) return if (incx==1) then ! code for increment equal to 1 @@ -2750,22 +2752,22 @@ module stdlib_linalg_blas_z end do end if return - end subroutine stdlib_zscal + end subroutine stdlib${ii}$_zscal - pure subroutine stdlib_zswap(n,zx,incx,zy,incy) + pure subroutine stdlib${ii}$_zswap(n,zx,incx,zy,incy) !! ZSWAP interchanges two vectors. ! -- 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, incy, n + integer(${ik}$), intent(in) :: incx, incy, n ! Array Arguments complex(dp), intent(inout) :: zx(*), zy(*) ! ===================================================================== ! Local Scalars complex(dp) :: ztemp - integer(ilp) :: i, ix, iy + integer(${ik}$) :: i, ix, iy if (n<=0) return if (incx==1 .and. incy==1) then ! code for both increments equal to 1 @@ -2790,10 +2792,10 @@ module stdlib_linalg_blas_z end do end if return - end subroutine stdlib_zswap + end subroutine stdlib${ii}$_zswap - pure subroutine stdlib_zsymm(side,uplo,m,n,alpha,a,lda,b,ldb,beta,c,ldc) + pure subroutine stdlib${ii}$_zsymm(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 @@ -2805,7 +2807,7 @@ module stdlib_linalg_blas_z ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments complex(dp), intent(in) :: alpha, beta - integer(ilp), intent(in) :: lda, ldb, ldc, m, n + integer(${ik}$), intent(in) :: lda, ldb, ldc, m, n character, intent(in) :: side, uplo ! Array Arguments complex(dp), intent(in) :: a(lda,*), b(ldb,*) @@ -2815,7 +2817,7 @@ module stdlib_linalg_blas_z intrinsic :: max ! Local Scalars complex(dp) :: temp1, temp2 - integer(ilp) :: i, info, j, k, nrowa + integer(${ik}$) :: i, info, j, k, nrowa logical(lk) :: upper @@ -2844,7 +2846,7 @@ module stdlib_linalg_blas_z info = 12 end if if (info/=0) then - call stdlib_xerbla('ZSYMM ',info) + call stdlib${ii}$_xerbla('ZSYMM ',info) return end if ! quick return if possible. @@ -2938,10 +2940,10 @@ module stdlib_linalg_blas_z end do loop_170 end if return - end subroutine stdlib_zsymm + end subroutine stdlib${ii}$_zsymm - pure subroutine stdlib_zsyr2k(uplo,trans,n,k,alpha,a,lda,b,ldb,beta,c,ldc) + pure subroutine stdlib${ii}$_zsyr2k(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 @@ -2954,7 +2956,7 @@ module stdlib_linalg_blas_z ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments complex(dp), intent(in) :: alpha, beta - integer(ilp), intent(in) :: k, lda, ldb, ldc, n + integer(${ik}$), intent(in) :: k, lda, ldb, ldc, n character, intent(in) :: trans, uplo ! Array Arguments complex(dp), intent(in) :: a(lda,*), b(ldb,*) @@ -2964,7 +2966,7 @@ module stdlib_linalg_blas_z intrinsic :: max ! Local Scalars complex(dp) :: temp1, temp2 - integer(ilp) :: i, info, j, l, nrowa + integer(${ik}$) :: i, info, j, l, nrowa logical(lk) :: upper @@ -2993,7 +2995,7 @@ module stdlib_linalg_blas_z info = 12 end if if (info/=0) then - call stdlib_xerbla('ZSYR2K',info) + call stdlib${ii}$_xerbla('ZSYR2K',info) return end if ! quick return if possible. @@ -3114,10 +3116,10 @@ module stdlib_linalg_blas_z end if end if return - end subroutine stdlib_zsyr2k + end subroutine stdlib${ii}$_zsyr2k - pure subroutine stdlib_zsyrk(uplo,trans,n,k,alpha,a,lda,beta,c,ldc) + pure subroutine stdlib${ii}$_zsyrk(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 @@ -3130,7 +3132,7 @@ module stdlib_linalg_blas_z ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments complex(dp), intent(in) :: alpha, beta - integer(ilp), intent(in) :: k, lda, ldc, n + integer(${ik}$), intent(in) :: k, lda, ldc, n character, intent(in) :: trans, uplo ! Array Arguments complex(dp), intent(in) :: a(lda,*) @@ -3140,7 +3142,7 @@ module stdlib_linalg_blas_z intrinsic :: max ! Local Scalars complex(dp) :: temp - integer(ilp) :: i, info, j, l, nrowa + integer(${ik}$) :: i, info, j, l, nrowa logical(lk) :: upper @@ -3167,7 +3169,7 @@ module stdlib_linalg_blas_z info = 10 end if if (info/=0) then - call stdlib_xerbla('ZSYRK ',info) + call stdlib${ii}$_xerbla('ZSYRK ',info) return end if ! quick return if possible. @@ -3282,10 +3284,10 @@ module stdlib_linalg_blas_z end if end if return - end subroutine stdlib_zsyrk + end subroutine stdlib${ii}$_zsyrk - pure subroutine stdlib_ztbmv(uplo,trans,diag,n,k,a,lda,x,incx) + pure subroutine stdlib${ii}$_ztbmv(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, @@ -3294,7 +3296,7 @@ module stdlib_linalg_blas_z ! -- 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, k, lda, n + integer(${ik}$), intent(in) :: incx, k, lda, n character, intent(in) :: diag, trans, uplo ! Array Arguments complex(dp), intent(in) :: a(lda,*) @@ -3303,7 +3305,7 @@ module stdlib_linalg_blas_z ! Local Scalars complex(dp) :: temp - integer(ilp) :: i, info, ix, j, jx, kplus1, kx, l + integer(${ik}$) :: i, info, ix, j, jx, kplus1, kx, l logical(lk) :: noconj, nounit ! Intrinsic Functions intrinsic :: conjg,max,min @@ -3326,7 +3328,7 @@ module stdlib_linalg_blas_z info = 9 end if if (info/=0) then - call stdlib_xerbla('ZTBMV ',info) + call stdlib${ii}$_xerbla('ZTBMV ',info) return end if ! quick return if possible. @@ -3496,10 +3498,10 @@ module stdlib_linalg_blas_z end if end if return - end subroutine stdlib_ztbmv + end subroutine stdlib${ii}$_ztbmv - pure subroutine stdlib_ztbsv(uplo,trans,diag,n,k,a,lda,x,incx) + pure subroutine stdlib${ii}$_ztbsv(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 @@ -3511,7 +3513,7 @@ module stdlib_linalg_blas_z ! -- 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, k, lda, n + integer(${ik}$), intent(in) :: incx, k, lda, n character, intent(in) :: diag, trans, uplo ! Array Arguments complex(dp), intent(in) :: a(lda,*) @@ -3520,7 +3522,7 @@ module stdlib_linalg_blas_z ! Local Scalars complex(dp) :: temp - integer(ilp) :: i, info, ix, j, jx, kplus1, kx, l + integer(${ik}$) :: i, info, ix, j, jx, kplus1, kx, l logical(lk) :: noconj, nounit ! Intrinsic Functions intrinsic :: conjg,max,min @@ -3543,7 +3545,7 @@ module stdlib_linalg_blas_z info = 9 end if if (info/=0) then - call stdlib_xerbla('ZTBSV ',info) + call stdlib${ii}$_xerbla('ZTBSV ',info) return end if ! quick return if possible. @@ -3713,10 +3715,10 @@ module stdlib_linalg_blas_z end if end if return - end subroutine stdlib_ztbsv + end subroutine stdlib${ii}$_ztbsv - pure subroutine stdlib_ztpmv(uplo,trans,diag,n,ap,x,incx) + pure subroutine stdlib${ii}$_ztpmv(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, @@ -3725,7 +3727,7 @@ module stdlib_linalg_blas_z ! -- 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 + integer(${ik}$), intent(in) :: incx, n character, intent(in) :: diag, trans, uplo ! Array Arguments complex(dp), intent(in) :: ap(*) @@ -3734,7 +3736,7 @@ module stdlib_linalg_blas_z ! Local Scalars complex(dp) :: temp - integer(ilp) :: i, info, ix, j, jx, k, kk, kx + integer(${ik}$) :: i, info, ix, j, jx, k, kk, kx logical(lk) :: noconj, nounit ! Intrinsic Functions intrinsic :: conjg @@ -3753,7 +3755,7 @@ module stdlib_linalg_blas_z info = 7 end if if (info/=0) then - call stdlib_xerbla('ZTPMV ',info) + call stdlib${ii}$_xerbla('ZTPMV ',info) return end if ! quick return if possible. @@ -3930,10 +3932,10 @@ module stdlib_linalg_blas_z end if end if return - end subroutine stdlib_ztpmv + end subroutine stdlib${ii}$_ztpmv - pure subroutine stdlib_ztpsv(uplo,trans,diag,n,ap,x,incx) + pure subroutine stdlib${ii}$_ztpsv(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 @@ -3944,7 +3946,7 @@ module stdlib_linalg_blas_z ! -- 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 + integer(${ik}$), intent(in) :: incx, n character, intent(in) :: diag, trans, uplo ! Array Arguments complex(dp), intent(in) :: ap(*) @@ -3953,7 +3955,7 @@ module stdlib_linalg_blas_z ! Local Scalars complex(dp) :: temp - integer(ilp) :: i, info, ix, j, jx, k, kk, kx + integer(${ik}$) :: i, info, ix, j, jx, k, kk, kx logical(lk) :: noconj, nounit ! Intrinsic Functions intrinsic :: conjg @@ -3972,7 +3974,7 @@ module stdlib_linalg_blas_z info = 7 end if if (info/=0) then - call stdlib_xerbla('ZTPSV ',info) + call stdlib${ii}$_xerbla('ZTPSV ',info) return end if ! quick return if possible. @@ -4149,10 +4151,10 @@ module stdlib_linalg_blas_z end if end if return - end subroutine stdlib_ztpsv + end subroutine stdlib${ii}$_ztpsv - pure subroutine stdlib_ztrmm(side,uplo,transa,diag,m,n,alpha,a,lda,b,ldb) + pure subroutine stdlib${ii}$_ztrmm(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 @@ -4163,7 +4165,7 @@ module stdlib_linalg_blas_z ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments complex(dp), intent(in) :: alpha - integer(ilp), intent(in) :: lda, ldb, m, n + integer(${ik}$), intent(in) :: lda, ldb, m, n character, intent(in) :: diag, side, transa, uplo ! Array Arguments complex(dp), intent(in) :: a(lda,*) @@ -4173,7 +4175,7 @@ module stdlib_linalg_blas_z intrinsic :: conjg,max ! Local Scalars complex(dp) :: temp - integer(ilp) :: i, info, j, k, nrowa + integer(${ik}$) :: i, info, j, k, nrowa logical(lk) :: lside, noconj, nounit, upper @@ -4208,7 +4210,7 @@ module stdlib_linalg_blas_z info = 11 end if if (info/=0) then - call stdlib_xerbla('ZTRMM ',info) + call stdlib${ii}$_xerbla('ZTRMM ',info) return end if ! quick return if possible. @@ -4391,10 +4393,10 @@ module stdlib_linalg_blas_z end if end if return - end subroutine stdlib_ztrmm + end subroutine stdlib${ii}$_ztrmm - pure subroutine stdlib_ztrmv(uplo,trans,diag,n,a,lda,x,incx) + pure subroutine stdlib${ii}$_ztrmv(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, @@ -4403,7 +4405,7 @@ module stdlib_linalg_blas_z ! -- 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, lda, n + integer(${ik}$), intent(in) :: incx, lda, n character, intent(in) :: diag, trans, uplo ! Array Arguments complex(dp), intent(in) :: a(lda,*) @@ -4412,7 +4414,7 @@ module stdlib_linalg_blas_z ! Local Scalars complex(dp) :: temp - integer(ilp) :: i, info, ix, j, jx, kx + integer(${ik}$) :: i, info, ix, j, jx, kx logical(lk) :: noconj, nounit ! Intrinsic Functions intrinsic :: conjg,max @@ -4433,7 +4435,7 @@ module stdlib_linalg_blas_z info = 8 end if if (info/=0) then - call stdlib_xerbla('ZTRMV ',info) + call stdlib${ii}$_xerbla('ZTRMV ',info) return end if ! quick return if possible. @@ -4588,10 +4590,10 @@ module stdlib_linalg_blas_z end if end if return - end subroutine stdlib_ztrmv + end subroutine stdlib${ii}$_ztrmv - pure subroutine stdlib_ztrsm(side,uplo,transa,diag,m,n,alpha,a,lda,b,ldb) + pure subroutine stdlib${ii}$_ztrsm(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 @@ -4603,7 +4605,7 @@ module stdlib_linalg_blas_z ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments complex(dp), intent(in) :: alpha - integer(ilp), intent(in) :: lda, ldb, m, n + integer(${ik}$), intent(in) :: lda, ldb, m, n character, intent(in) :: diag, side, transa, uplo ! Array Arguments complex(dp), intent(in) :: a(lda,*) @@ -4613,7 +4615,7 @@ module stdlib_linalg_blas_z intrinsic :: conjg,max ! Local Scalars complex(dp) :: temp - integer(ilp) :: i, info, j, k, nrowa + integer(${ik}$) :: i, info, j, k, nrowa logical(lk) :: lside, noconj, nounit, upper @@ -4648,7 +4650,7 @@ module stdlib_linalg_blas_z info = 11 end if if (info/=0) then - call stdlib_xerbla('ZTRSM ',info) + call stdlib${ii}$_xerbla('ZTRSM ',info) return end if ! quick return if possible. @@ -4853,10 +4855,10 @@ module stdlib_linalg_blas_z end if end if return - end subroutine stdlib_ztrsm + end subroutine stdlib${ii}$_ztrsm - pure subroutine stdlib_ztrsv(uplo,trans,diag,n,a,lda,x,incx) + pure subroutine stdlib${ii}$_ztrsv(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 @@ -4867,7 +4869,7 @@ module stdlib_linalg_blas_z ! -- 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, lda, n + integer(${ik}$), intent(in) :: incx, lda, n character, intent(in) :: diag, trans, uplo ! Array Arguments complex(dp), intent(in) :: a(lda,*) @@ -4876,7 +4878,7 @@ module stdlib_linalg_blas_z ! Local Scalars complex(dp) :: temp - integer(ilp) :: i, info, ix, j, jx, kx + integer(${ik}$) :: i, info, ix, j, jx, kx logical(lk) :: noconj, nounit ! Intrinsic Functions intrinsic :: conjg,max @@ -4897,7 +4899,7 @@ module stdlib_linalg_blas_z info = 8 end if if (info/=0) then - call stdlib_xerbla('ZTRSV ',info) + call stdlib${ii}$_xerbla('ZTRSV ',info) return end if ! quick return if possible. @@ -5052,8 +5054,8 @@ module stdlib_linalg_blas_z end if end if return - end subroutine stdlib_ztrsv - + end subroutine stdlib${ii}$_ztrsv + #:endfor end module stdlib_linalg_blas_z From 6487c23f5226a7882855e61c5d5d261750ece162 Mon Sep 17 00:00:00 2001 From: Federico Perini Date: Wed, 13 Nov 2024 18:44:20 +0100 Subject: [PATCH 10/31] `blas_w`: template integer type --- src/stdlib_linalg_blas_w.fypp | 414 +++++++++++++++++----------------- 1 file changed, 208 insertions(+), 206 deletions(-) diff --git a/src/stdlib_linalg_blas_w.fypp b/src/stdlib_linalg_blas_w.fypp index c3e3ef089..15a148982 100644 --- a/src/stdlib_linalg_blas_w.fypp +++ b/src/stdlib_linalg_blas_w.fypp @@ -17,42 +17,44 @@ module stdlib_linalg_blas_${ci}$ private - 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 + public :: sp,dp,${ck}$,lk,ilp,ilp64 + #:for ik,it,ii in LINALG_INT_KINDS_TYPES + public :: stdlib${ii}$_${ci}$axpy + public :: stdlib${ii}$_${ci}$copy + public :: stdlib${ii}$_${ci}$dotc + public :: stdlib${ii}$_${ci}$dotu + public :: stdlib${ii}$_${ci}$drot + public :: stdlib${ii}$_${ci}$dscal + public :: stdlib${ii}$_${ci}$gbmv + public :: stdlib${ii}$_${ci}$gemm + public :: stdlib${ii}$_${ci}$gemv + public :: stdlib${ii}$_${ci}$gerc + public :: stdlib${ii}$_${ci}$geru + public :: stdlib${ii}$_${ci}$hbmv + public :: stdlib${ii}$_${ci}$hemm + public :: stdlib${ii}$_${ci}$hemv + public :: stdlib${ii}$_${ci}$her + public :: stdlib${ii}$_${ci}$her2 + public :: stdlib${ii}$_${ci}$her2k + public :: stdlib${ii}$_${ci}$herk + public :: stdlib${ii}$_${ci}$hpmv + public :: stdlib${ii}$_${ci}$hpr + public :: stdlib${ii}$_${ci}$hpr2 + public :: stdlib${ii}$_${ci}$rotg + public :: stdlib${ii}$_${ci}$scal + public :: stdlib${ii}$_${ci}$swap + public :: stdlib${ii}$_${ci}$symm + public :: stdlib${ii}$_${ci}$syr2k + public :: stdlib${ii}$_${ci}$syrk + public :: stdlib${ii}$_${ci}$tbmv + public :: stdlib${ii}$_${ci}$tbsv + public :: stdlib${ii}$_${ci}$tpmv + public :: stdlib${ii}$_${ci}$tpsv + public :: stdlib${ii}$_${ci}$trmm + public :: stdlib${ii}$_${ci}$trmv + public :: stdlib${ii}$_${ci}$trsm + public :: stdlib${ii}$_${ci}$trsv + #:endfor ! 128-bit real constants real(${ck}$), parameter, private :: negone = -1.00_${ck}$ @@ -94,21 +96,21 @@ module stdlib_linalg_blas_${ci}$ contains - - pure subroutine stdlib_${ci}$axpy(n,za,zx,incx,zy,incy) + #:for ik,it,ii in LINALG_INT_KINDS_TYPES + pure subroutine stdlib${ii}$_${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(${ck}$), intent(in) :: za - integer(ilp), intent(in) :: incx, incy, n + integer(${ik}$), intent(in) :: incx, incy, n ! Array Arguments complex(${ck}$), intent(in) :: zx(*) complex(${ck}$), intent(inout) :: zy(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, ix, iy + integer(${ik}$) :: i, ix, iy if (n<=0) return if (stdlib_cabs1(za)==0.0_${ck}$) return if (incx==1 .and. incy==1) then @@ -130,22 +132,22 @@ module stdlib_linalg_blas_${ci}$ end do end if return - end subroutine stdlib_${ci}$axpy + end subroutine stdlib${ii}$_${ci}$axpy - pure subroutine stdlib_${ci}$copy(n,zx,incx,zy,incy) + pure subroutine stdlib${ii}$_${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, -- ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments - integer(ilp), intent(in) :: incx, incy, n + integer(${ik}$), intent(in) :: incx, incy, n ! Array Arguments complex(${ck}$), intent(in) :: zx(*) complex(${ck}$), intent(out) :: zy(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, ix, iy + integer(${ik}$) :: i, ix, iy if (n<=0) return if (incx==1 .and. incy==1) then ! code for both increments equal to 1 @@ -166,27 +168,27 @@ module stdlib_linalg_blas_${ci}$ end do end if return - end subroutine stdlib_${ci}$copy + end subroutine stdlib${ii}$_${ci}$copy - pure complex(${ck}$) function stdlib_${ci}$dotc(n,zx,incx,zy,incy) + pure complex(${ck}$) function stdlib${ii}$_${ci}$dotc(n,zx,incx,zy,incy) !! ZDOTC: forms the dot product of two complex vectors !! ZDOTC = X^H * Y ! -- 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, incy, n + integer(${ik}$), intent(in) :: incx, incy, n ! Array Arguments complex(${ck}$), intent(in) :: zx(*), zy(*) ! ===================================================================== ! Local Scalars complex(${ck}$) :: ztemp - integer(ilp) :: i, ix, iy + integer(${ik}$) :: i, ix, iy ! Intrinsic Functions intrinsic :: conjg ztemp = (0.0_${ck}$,0.0_${ck}$) - stdlib_${ci}$dotc = (0.0_${ck}$,0.0_${ck}$) + stdlib${ii}$_${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 @@ -206,27 +208,27 @@ module stdlib_linalg_blas_${ci}$ iy = iy + incy end do end if - stdlib_${ci}$dotc = ztemp + stdlib${ii}$_${ci}$dotc = ztemp return - end function stdlib_${ci}$dotc + end function stdlib${ii}$_${ci}$dotc - pure complex(${ck}$) function stdlib_${ci}$dotu(n,zx,incx,zy,incy) + pure complex(${ck}$) function stdlib${ii}$_${ci}$dotu(n,zx,incx,zy,incy) !! ZDOTU: forms the dot product of two complex vectors !! ZDOTU = X^T * Y ! -- 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, incy, n + integer(${ik}$), intent(in) :: incx, incy, n ! Array Arguments complex(${ck}$), intent(in) :: zx(*), zy(*) ! ===================================================================== ! Local Scalars complex(${ck}$) :: ztemp - integer(ilp) :: i, ix, iy + integer(${ik}$) :: i, ix, iy ztemp = (0.0_${ck}$,0.0_${ck}$) - stdlib_${ci}$dotu = (0.0_${ck}$,0.0_${ck}$) + stdlib${ii}$_${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 @@ -246,12 +248,12 @@ module stdlib_linalg_blas_${ci}$ iy = iy + incy end do end if - stdlib_${ci}$dotu = ztemp + stdlib${ii}$_${ci}$dotu = ztemp return - end function stdlib_${ci}$dotu + end function stdlib${ii}$_${ci}$dotu - pure subroutine stdlib_${ci}$drot( n, zx, incx, zy, incy, c, s ) + pure subroutine stdlib${ii}$_${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. @@ -259,13 +261,13 @@ module stdlib_linalg_blas_${ci}$ ! -- 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, incy, n + integer(${ik}$), intent(in) :: incx, incy, n real(${ck}$), intent(in) :: c, s ! Array Arguments complex(${ck}$), intent(inout) :: zx(*), zy(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, ix, iy + integer(${ik}$) :: i, ix, iy complex(${ck}$) :: ctemp ! Executable Statements if( n<=0 )return @@ -292,22 +294,22 @@ module stdlib_linalg_blas_${ci}$ end do end if return - end subroutine stdlib_${ci}$drot + end subroutine stdlib${ii}$_${ci}$drot - pure subroutine stdlib_${ci}$dscal(n,da,zx,incx) + pure subroutine stdlib${ii}$_${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(${ck}$), intent(in) :: da - integer(ilp), intent(in) :: incx, n + integer(${ik}$), intent(in) :: incx, n ! Array Arguments complex(${ck}$), intent(inout) :: zx(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, nincx + integer(${ik}$) :: i, nincx ! Intrinsic Functions intrinsic :: cmplx if (n<=0 .or. incx<=0) return @@ -324,10 +326,10 @@ module stdlib_linalg_blas_${ci}$ end do end if return - end subroutine stdlib_${ci}$dscal + end subroutine stdlib${ii}$_${ci}$dscal - pure subroutine stdlib_${ci}$gbmv(trans,m,n,kl,ku,alpha,a,lda,x,incx,beta,y,incy) + pure subroutine stdlib${ii}$_${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, @@ -338,7 +340,7 @@ module stdlib_linalg_blas_${ci}$ ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments complex(${ck}$), intent(in) :: alpha, beta - integer(ilp), intent(in) :: incx, incy, kl, ku, lda, m, n + integer(${ik}$), intent(in) :: incx, incy, kl, ku, lda, m, n character, intent(in) :: trans ! Array Arguments complex(${ck}$), intent(in) :: a(lda,*), x(*) @@ -348,7 +350,7 @@ module stdlib_linalg_blas_${ci}$ ! Local Scalars complex(${ck}$) :: temp - integer(ilp) :: i, info, ix, iy, j, jx, jy, k, kup1, kx, ky, lenx, leny + integer(${ik}$) :: i, info, ix, iy, j, jx, jy, k, kup1, kx, ky, lenx, leny logical(lk) :: noconj ! Intrinsic Functions intrinsic :: conjg,max,min @@ -373,7 +375,7 @@ module stdlib_linalg_blas_${ci}$ info = 13 end if if (info/=0) then - call stdlib_xerbla('ZGBMV ',info) + call stdlib${ii}$_xerbla('ZGBMV ',info) return end if ! quick return if possible. @@ -496,10 +498,10 @@ module stdlib_linalg_blas_${ci}$ end if end if return - end subroutine stdlib_${ci}$gbmv + end subroutine stdlib${ii}$_${ci}$gbmv - pure subroutine stdlib_${ci}$gemm(transa,transb,m,n,k,alpha,a,lda,b,ldb,beta,c,ldc) + pure subroutine stdlib${ii}$_${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 @@ -511,7 +513,7 @@ module stdlib_linalg_blas_${ci}$ ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments complex(${ck}$), intent(in) :: alpha, beta - integer(ilp), intent(in) :: k, lda, ldb, ldc, m, n + integer(${ik}$), intent(in) :: k, lda, ldb, ldc, m, n character, intent(in) :: transa, transb ! Array Arguments complex(${ck}$), intent(in) :: a(lda,*), b(ldb,*) @@ -521,7 +523,7 @@ module stdlib_linalg_blas_${ci}$ intrinsic :: conjg,max ! Local Scalars complex(${ck}$) :: temp - integer(ilp) :: i, info, j, l, nrowa, nrowb + integer(${ik}$) :: i, info, j, l, nrowa, nrowb logical(lk) :: conja, conjb, nota, notb @@ -564,7 +566,7 @@ module stdlib_linalg_blas_${ci}$ info = 13 end if if (info/=0) then - call stdlib_xerbla('ZGEMM ',info) + call stdlib${ii}$_xerbla('ZGEMM ',info) return end if ! quick return if possible. @@ -745,10 +747,10 @@ module stdlib_linalg_blas_${ci}$ end if end if return - end subroutine stdlib_${ci}$gemm + end subroutine stdlib${ii}$_${ci}$gemm - pure subroutine stdlib_${ci}$gemv(trans,m,n,alpha,a,lda,x,incx,beta,y,incy) + pure subroutine stdlib${ii}$_${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, @@ -759,7 +761,7 @@ module stdlib_linalg_blas_${ci}$ ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments complex(${ck}$), intent(in) :: alpha, beta - integer(ilp), intent(in) :: incx, incy, lda, m, n + integer(${ik}$), intent(in) :: incx, incy, lda, m, n character, intent(in) :: trans ! Array Arguments complex(${ck}$), intent(in) :: a(lda,*), x(*) @@ -769,7 +771,7 @@ module stdlib_linalg_blas_${ci}$ ! Local Scalars complex(${ck}$) :: temp - integer(ilp) :: i, info, ix, iy, j, jx, jy, kx, ky, lenx, leny + integer(${ik}$) :: i, info, ix, iy, j, jx, jy, kx, ky, lenx, leny logical(lk) :: noconj ! Intrinsic Functions intrinsic :: conjg,max @@ -790,7 +792,7 @@ module stdlib_linalg_blas_${ci}$ info = 11 end if if (info/=0) then - call stdlib_xerbla('ZGEMV ',info) + call stdlib${ii}$_xerbla('ZGEMV ',info) return end if ! quick return if possible. @@ -906,10 +908,10 @@ module stdlib_linalg_blas_${ci}$ end if end if return - end subroutine stdlib_${ci}$gemv + end subroutine stdlib${ii}$_${ci}$gemv - pure subroutine stdlib_${ci}$gerc(m,n,alpha,x,incx,y,incy,a,lda) + pure subroutine stdlib${ii}$_${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 @@ -919,7 +921,7 @@ module stdlib_linalg_blas_${ci}$ ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments complex(${ck}$), intent(in) :: alpha - integer(ilp), intent(in) :: incx, incy, lda, m, n + integer(${ik}$), intent(in) :: incx, incy, lda, m, n ! Array Arguments complex(${ck}$), intent(inout) :: a(lda,*) complex(${ck}$), intent(in) :: x(*), y(*) @@ -927,7 +929,7 @@ module stdlib_linalg_blas_${ci}$ ! Local Scalars complex(${ck}$) :: temp - integer(ilp) :: i, info, ix, j, jy, kx + integer(${ik}$) :: i, info, ix, j, jy, kx ! Intrinsic Functions intrinsic :: conjg,max ! test the input parameters. @@ -944,7 +946,7 @@ module stdlib_linalg_blas_${ci}$ info = 9 end if if (info/=0) then - call stdlib_xerbla('ZGERC ',info) + call stdlib${ii}$_xerbla('ZGERC ',info) return end if ! quick return if possible. @@ -985,10 +987,10 @@ module stdlib_linalg_blas_${ci}$ end do end if return - end subroutine stdlib_${ci}$gerc + end subroutine stdlib${ii}$_${ci}$gerc - pure subroutine stdlib_${ci}$geru(m,n,alpha,x,incx,y,incy,a,lda) + pure subroutine stdlib${ii}$_${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 @@ -998,7 +1000,7 @@ module stdlib_linalg_blas_${ci}$ ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments complex(${ck}$), intent(in) :: alpha - integer(ilp), intent(in) :: incx, incy, lda, m, n + integer(${ik}$), intent(in) :: incx, incy, lda, m, n ! Array Arguments complex(${ck}$), intent(inout) :: a(lda,*) complex(${ck}$), intent(in) :: x(*), y(*) @@ -1006,7 +1008,7 @@ module stdlib_linalg_blas_${ci}$ ! Local Scalars complex(${ck}$) :: temp - integer(ilp) :: i, info, ix, j, jy, kx + integer(${ik}$) :: i, info, ix, j, jy, kx ! Intrinsic Functions intrinsic :: max ! test the input parameters. @@ -1023,7 +1025,7 @@ module stdlib_linalg_blas_${ci}$ info = 9 end if if (info/=0) then - call stdlib_xerbla('ZGERU ',info) + call stdlib${ii}$_xerbla('ZGERU ',info) return end if ! quick return if possible. @@ -1064,10 +1066,10 @@ module stdlib_linalg_blas_${ci}$ end do end if return - end subroutine stdlib_${ci}$geru + end subroutine stdlib${ii}$_${ci}$geru - pure subroutine stdlib_${ci}$hbmv(uplo,n,k,alpha,a,lda,x,incx,beta,y,incy) + pure subroutine stdlib${ii}$_${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 @@ -1077,7 +1079,7 @@ module stdlib_linalg_blas_${ci}$ ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments complex(${ck}$), intent(in) :: alpha, beta - integer(ilp), intent(in) :: incx, incy, k, lda, n + integer(${ik}$), intent(in) :: incx, incy, k, lda, n character, intent(in) :: uplo ! Array Arguments complex(${ck}$), intent(in) :: a(lda,*), x(*) @@ -1087,7 +1089,7 @@ module stdlib_linalg_blas_${ci}$ ! Local Scalars complex(${ck}$) :: temp1, temp2 - integer(ilp) :: i, info, ix, iy, j, jx, jy, kplus1, kx, ky, l + integer(${ik}$) :: i, info, ix, iy, j, jx, jy, kplus1, kx, ky, l ! Intrinsic Functions intrinsic :: real,conjg,max,min ! test the input parameters. @@ -1106,7 +1108,7 @@ module stdlib_linalg_blas_${ci}$ info = 11 end if if (info/=0) then - call stdlib_xerbla('ZHBMV ',info) + call stdlib${ii}$_xerbla('ZHBMV ',info) return end if ! quick return if possible. @@ -1227,10 +1229,10 @@ module stdlib_linalg_blas_${ci}$ end if end if return - end subroutine stdlib_${ci}$hbmv + end subroutine stdlib${ii}$_${ci}$hbmv - pure subroutine stdlib_${ci}$hemm(side,uplo,m,n,alpha,a,lda,b,ldb,beta,c,ldc) + pure subroutine stdlib${ii}$_${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 @@ -1242,7 +1244,7 @@ module stdlib_linalg_blas_${ci}$ ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments complex(${ck}$), intent(in) :: alpha, beta - integer(ilp), intent(in) :: lda, ldb, ldc, m, n + integer(${ik}$), intent(in) :: lda, ldb, ldc, m, n character, intent(in) :: side, uplo ! Array Arguments complex(${ck}$), intent(in) :: a(lda,*), b(ldb,*) @@ -1252,7 +1254,7 @@ module stdlib_linalg_blas_${ci}$ intrinsic :: real,conjg,max ! Local Scalars complex(${ck}$) :: temp1, temp2 - integer(ilp) :: i, info, j, k, nrowa + integer(${ik}$) :: i, info, j, k, nrowa logical(lk) :: upper @@ -1281,7 +1283,7 @@ module stdlib_linalg_blas_${ci}$ info = 12 end if if (info/=0) then - call stdlib_xerbla('ZHEMM ',info) + call stdlib${ii}$_xerbla('ZHEMM ',info) return end if ! quick return if possible. @@ -1377,10 +1379,10 @@ module stdlib_linalg_blas_${ci}$ end do loop_170 end if return - end subroutine stdlib_${ci}$hemm + end subroutine stdlib${ii}$_${ci}$hemm - pure subroutine stdlib_${ci}$hemv(uplo,n,alpha,a,lda,x,incx,beta,y,incy) + pure subroutine stdlib${ii}$_${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 @@ -1390,7 +1392,7 @@ module stdlib_linalg_blas_${ci}$ ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments complex(${ck}$), intent(in) :: alpha, beta - integer(ilp), intent(in) :: incx, incy, lda, n + integer(${ik}$), intent(in) :: incx, incy, lda, n character, intent(in) :: uplo ! Array Arguments complex(${ck}$), intent(in) :: a(lda,*), x(*) @@ -1400,7 +1402,7 @@ module stdlib_linalg_blas_${ci}$ ! Local Scalars complex(${ck}$) :: temp1, temp2 - integer(ilp) :: i, info, ix, iy, j, jx, jy, kx, ky + integer(${ik}$) :: i, info, ix, iy, j, jx, jy, kx, ky ! Intrinsic Functions intrinsic :: real,conjg,max ! test the input parameters. @@ -1417,7 +1419,7 @@ module stdlib_linalg_blas_${ci}$ info = 10 end if if (info/=0) then - call stdlib_xerbla('ZHEMV ',info) + call stdlib${ii}$_xerbla('ZHEMV ',info) return end if ! quick return if possible. @@ -1530,10 +1532,10 @@ module stdlib_linalg_blas_${ci}$ end if end if return - end subroutine stdlib_${ci}$hemv + end subroutine stdlib${ii}$_${ci}$hemv - pure subroutine stdlib_${ci}$her(uplo,n,alpha,x,incx,a,lda) + pure subroutine stdlib${ii}$_${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 @@ -1543,7 +1545,7 @@ module stdlib_linalg_blas_${ci}$ ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments real(${ck}$), intent(in) :: alpha - integer(ilp), intent(in) :: incx, lda, n + integer(${ik}$), intent(in) :: incx, lda, n character, intent(in) :: uplo ! Array Arguments complex(${ck}$), intent(inout) :: a(lda,*) @@ -1552,7 +1554,7 @@ module stdlib_linalg_blas_${ci}$ ! Local Scalars complex(${ck}$) :: temp - integer(ilp) :: i, info, ix, j, jx, kx + integer(${ik}$) :: i, info, ix, j, jx, kx ! Intrinsic Functions intrinsic :: real,conjg,max ! test the input parameters. @@ -1567,7 +1569,7 @@ module stdlib_linalg_blas_${ci}$ info = 7 end if if (info/=0) then - call stdlib_xerbla('ZHER ',info) + call stdlib${ii}$_xerbla('ZHER ',info) return end if ! quick return if possible. @@ -1645,10 +1647,10 @@ module stdlib_linalg_blas_${ci}$ end if end if return - end subroutine stdlib_${ci}$her + end subroutine stdlib${ii}$_${ci}$her - pure subroutine stdlib_${ci}$her2(uplo,n,alpha,x,incx,y,incy,a,lda) + pure subroutine stdlib${ii}$_${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 @@ -1658,7 +1660,7 @@ module stdlib_linalg_blas_${ci}$ ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments complex(${ck}$), intent(in) :: alpha - integer(ilp), intent(in) :: incx, incy, lda, n + integer(${ik}$), intent(in) :: incx, incy, lda, n character, intent(in) :: uplo ! Array Arguments complex(${ck}$), intent(inout) :: a(lda,*) @@ -1667,7 +1669,7 @@ module stdlib_linalg_blas_${ci}$ ! Local Scalars complex(${ck}$) :: temp1, temp2 - integer(ilp) :: i, info, ix, iy, j, jx, jy, kx, ky + integer(${ik}$) :: i, info, ix, iy, j, jx, jy, kx, ky ! Intrinsic Functions intrinsic :: real,conjg,max ! test the input parameters. @@ -1684,7 +1686,7 @@ module stdlib_linalg_blas_${ci}$ info = 9 end if if (info/=0) then - call stdlib_xerbla('ZHER2 ',info) + call stdlib${ii}$_xerbla('ZHER2 ',info) return end if ! quick return if possible. @@ -1784,10 +1786,10 @@ module stdlib_linalg_blas_${ci}$ end if end if return - end subroutine stdlib_${ci}$her2 + end subroutine stdlib${ii}$_${ci}$her2 - pure subroutine stdlib_${ci}$her2k(uplo,trans,n,k,alpha,a,lda,b,ldb,beta,c,ldc) + pure subroutine stdlib${ii}$_${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 @@ -1801,7 +1803,7 @@ module stdlib_linalg_blas_${ci}$ ! Scalar Arguments complex(${ck}$), intent(in) :: alpha real(${ck}$), intent(in) :: beta - integer(ilp), intent(in) :: k, lda, ldb, ldc, n + integer(${ik}$), intent(in) :: k, lda, ldb, ldc, n character, intent(in) :: trans, uplo ! Array Arguments complex(${ck}$), intent(in) :: a(lda,*), b(ldb,*) @@ -1811,7 +1813,7 @@ module stdlib_linalg_blas_${ci}$ intrinsic :: real,conjg,max ! Local Scalars complex(${ck}$) :: temp1, temp2 - integer(ilp) :: i, info, j, l, nrowa + integer(${ik}$) :: i, info, j, l, nrowa logical(lk) :: upper @@ -1840,7 +1842,7 @@ module stdlib_linalg_blas_${ci}$ info = 12 end if if (info/=0) then - call stdlib_xerbla('ZHER2K',info) + call stdlib${ii}$_xerbla('ZHER2K',info) return end if ! quick return if possible. @@ -1993,10 +1995,10 @@ module stdlib_linalg_blas_${ci}$ end if end if return - end subroutine stdlib_${ci}$her2k + end subroutine stdlib${ii}$_${ci}$her2k - pure subroutine stdlib_${ci}$herk(uplo,trans,n,k,alpha,a,lda,beta,c,ldc) + pure subroutine stdlib${ii}$_${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 @@ -2009,7 +2011,7 @@ module stdlib_linalg_blas_${ci}$ ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments real(${ck}$), intent(in) :: alpha, beta - integer(ilp), intent(in) :: k, lda, ldc, n + integer(${ik}$), intent(in) :: k, lda, ldc, n character, intent(in) :: trans, uplo ! Array Arguments complex(${ck}$), intent(in) :: a(lda,*) @@ -2020,7 +2022,7 @@ module stdlib_linalg_blas_${ci}$ ! Local Scalars complex(${ck}$) :: temp real(${ck}$) :: rtemp - integer(ilp) :: i, info, j, l, nrowa + integer(${ik}$) :: i, info, j, l, nrowa logical(lk) :: upper ! test the input parameters. @@ -2046,7 +2048,7 @@ module stdlib_linalg_blas_${ci}$ info = 10 end if if (info/=0) then - call stdlib_xerbla('ZHERK ',info) + call stdlib${ii}$_xerbla('ZHERK ',info) return end if ! quick return if possible. @@ -2189,10 +2191,10 @@ module stdlib_linalg_blas_${ci}$ end if end if return - end subroutine stdlib_${ci}$herk + end subroutine stdlib${ii}$_${ci}$herk - pure subroutine stdlib_${ci}$hpmv(uplo,n,alpha,ap,x,incx,beta,y,incy) + pure subroutine stdlib${ii}$_${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 @@ -2202,7 +2204,7 @@ module stdlib_linalg_blas_${ci}$ ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments complex(${ck}$), intent(in) :: alpha, beta - integer(ilp), intent(in) :: incx, incy, n + integer(${ik}$), intent(in) :: incx, incy, n character, intent(in) :: uplo ! Array Arguments complex(${ck}$), intent(in) :: ap(*), x(*) @@ -2212,7 +2214,7 @@ module stdlib_linalg_blas_${ci}$ ! Local Scalars complex(${ck}$) :: temp1, temp2 - integer(ilp) :: i, info, ix, iy, j, jx, jy, k, kk, kx, ky + integer(${ik}$) :: i, info, ix, iy, j, jx, jy, k, kk, kx, ky ! Intrinsic Functions intrinsic :: real,conjg ! test the input parameters. @@ -2227,7 +2229,7 @@ module stdlib_linalg_blas_${ci}$ info = 9 end if if (info/=0) then - call stdlib_xerbla('ZHPMV ',info) + call stdlib${ii}$_xerbla('ZHPMV ',info) return end if ! quick return if possible. @@ -2348,10 +2350,10 @@ module stdlib_linalg_blas_${ci}$ end if end if return - end subroutine stdlib_${ci}$hpmv + end subroutine stdlib${ii}$_${ci}$hpmv - pure subroutine stdlib_${ci}$hpr(uplo,n,alpha,x,incx,ap) + pure subroutine stdlib${ii}$_${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 @@ -2361,7 +2363,7 @@ module stdlib_linalg_blas_${ci}$ ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments real(${ck}$), intent(in) :: alpha - integer(ilp), intent(in) :: incx, n + integer(${ik}$), intent(in) :: incx, n character, intent(in) :: uplo ! Array Arguments complex(${ck}$), intent(inout) :: ap(*) @@ -2370,7 +2372,7 @@ module stdlib_linalg_blas_${ci}$ ! Local Scalars complex(${ck}$) :: temp - integer(ilp) :: i, info, ix, j, jx, k, kk, kx + integer(${ik}$) :: i, info, ix, j, jx, k, kk, kx ! Intrinsic Functions intrinsic :: real,conjg ! test the input parameters. @@ -2383,7 +2385,7 @@ module stdlib_linalg_blas_${ci}$ info = 5 end if if (info/=0) then - call stdlib_xerbla('ZHPR ',info) + call stdlib${ii}$_xerbla('ZHPR ',info) return end if ! quick return if possible. @@ -2470,10 +2472,10 @@ module stdlib_linalg_blas_${ci}$ end if end if return - end subroutine stdlib_${ci}$hpr + end subroutine stdlib${ii}$_${ci}$hpr - pure subroutine stdlib_${ci}$hpr2(uplo,n,alpha,x,incx,y,incy,ap) + pure subroutine stdlib${ii}$_${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 @@ -2483,7 +2485,7 @@ module stdlib_linalg_blas_${ci}$ ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments complex(${ck}$), intent(in) :: alpha - integer(ilp), intent(in) :: incx, incy, n + integer(${ik}$), intent(in) :: incx, incy, n character, intent(in) :: uplo ! Array Arguments complex(${ck}$), intent(inout) :: ap(*) @@ -2492,7 +2494,7 @@ module stdlib_linalg_blas_${ci}$ ! Local Scalars complex(${ck}$) :: temp1, temp2 - integer(ilp) :: i, info, ix, iy, j, jx, jy, k, kk, kx, ky + integer(${ik}$) :: i, info, ix, iy, j, jx, jy, k, kk, kx, ky ! Intrinsic Functions intrinsic :: real,conjg ! test the input parameters. @@ -2507,7 +2509,7 @@ module stdlib_linalg_blas_${ci}$ info = 7 end if if (info/=0) then - call stdlib_xerbla('ZHPR2 ',info) + call stdlib${ii}$_xerbla('ZHPR2 ',info) return end if ! quick return if possible. @@ -2615,10 +2617,10 @@ module stdlib_linalg_blas_${ci}$ end if end if return - end subroutine stdlib_${ci}$hpr2 + end subroutine stdlib${ii}$_${ci}$hpr2 - pure subroutine stdlib_${ci}$rotg( a, b, c, s ) + pure subroutine stdlib${ii}$_${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 @@ -2728,22 +2730,22 @@ module stdlib_linalg_blas_${ci}$ end if a = r return - end subroutine stdlib_${ci}$rotg + end subroutine stdlib${ii}$_${ci}$rotg - pure subroutine stdlib_${ci}$scal(n,za,zx,incx) + pure subroutine stdlib${ii}$_${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(${ck}$), intent(in) :: za - integer(ilp), intent(in) :: incx, n + integer(${ik}$), intent(in) :: incx, n ! Array Arguments complex(${ck}$), intent(inout) :: zx(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, nincx + integer(${ik}$) :: i, nincx if (n<=0 .or. incx<=0) return if (incx==1) then ! code for increment equal to 1 @@ -2758,22 +2760,22 @@ module stdlib_linalg_blas_${ci}$ end do end if return - end subroutine stdlib_${ci}$scal + end subroutine stdlib${ii}$_${ci}$scal - pure subroutine stdlib_${ci}$swap(n,zx,incx,zy,incy) + pure subroutine stdlib${ii}$_${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, -- ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments - integer(ilp), intent(in) :: incx, incy, n + integer(${ik}$), intent(in) :: incx, incy, n ! Array Arguments complex(${ck}$), intent(inout) :: zx(*), zy(*) ! ===================================================================== ! Local Scalars complex(${ck}$) :: ztemp - integer(ilp) :: i, ix, iy + integer(${ik}$) :: i, ix, iy if (n<=0) return if (incx==1 .and. incy==1) then ! code for both increments equal to 1 @@ -2798,10 +2800,10 @@ module stdlib_linalg_blas_${ci}$ end do end if return - end subroutine stdlib_${ci}$swap + end subroutine stdlib${ii}$_${ci}$swap - pure subroutine stdlib_${ci}$symm(side,uplo,m,n,alpha,a,lda,b,ldb,beta,c,ldc) + pure subroutine stdlib${ii}$_${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 @@ -2813,7 +2815,7 @@ module stdlib_linalg_blas_${ci}$ ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments complex(${ck}$), intent(in) :: alpha, beta - integer(ilp), intent(in) :: lda, ldb, ldc, m, n + integer(${ik}$), intent(in) :: lda, ldb, ldc, m, n character, intent(in) :: side, uplo ! Array Arguments complex(${ck}$), intent(in) :: a(lda,*), b(ldb,*) @@ -2823,7 +2825,7 @@ module stdlib_linalg_blas_${ci}$ intrinsic :: max ! Local Scalars complex(${ck}$) :: temp1, temp2 - integer(ilp) :: i, info, j, k, nrowa + integer(${ik}$) :: i, info, j, k, nrowa logical(lk) :: upper @@ -2852,7 +2854,7 @@ module stdlib_linalg_blas_${ci}$ info = 12 end if if (info/=0) then - call stdlib_xerbla('ZSYMM ',info) + call stdlib${ii}$_xerbla('ZSYMM ',info) return end if ! quick return if possible. @@ -2946,10 +2948,10 @@ module stdlib_linalg_blas_${ci}$ end do loop_170 end if return - end subroutine stdlib_${ci}$symm + end subroutine stdlib${ii}$_${ci}$symm - pure subroutine stdlib_${ci}$syr2k(uplo,trans,n,k,alpha,a,lda,b,ldb,beta,c,ldc) + pure subroutine stdlib${ii}$_${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 @@ -2962,7 +2964,7 @@ module stdlib_linalg_blas_${ci}$ ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments complex(${ck}$), intent(in) :: alpha, beta - integer(ilp), intent(in) :: k, lda, ldb, ldc, n + integer(${ik}$), intent(in) :: k, lda, ldb, ldc, n character, intent(in) :: trans, uplo ! Array Arguments complex(${ck}$), intent(in) :: a(lda,*), b(ldb,*) @@ -2972,7 +2974,7 @@ module stdlib_linalg_blas_${ci}$ intrinsic :: max ! Local Scalars complex(${ck}$) :: temp1, temp2 - integer(ilp) :: i, info, j, l, nrowa + integer(${ik}$) :: i, info, j, l, nrowa logical(lk) :: upper @@ -3001,7 +3003,7 @@ module stdlib_linalg_blas_${ci}$ info = 12 end if if (info/=0) then - call stdlib_xerbla('ZSYR2K',info) + call stdlib${ii}$_xerbla('ZSYR2K',info) return end if ! quick return if possible. @@ -3122,10 +3124,10 @@ module stdlib_linalg_blas_${ci}$ end if end if return - end subroutine stdlib_${ci}$syr2k + end subroutine stdlib${ii}$_${ci}$syr2k - pure subroutine stdlib_${ci}$syrk(uplo,trans,n,k,alpha,a,lda,beta,c,ldc) + pure subroutine stdlib${ii}$_${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 @@ -3138,7 +3140,7 @@ module stdlib_linalg_blas_${ci}$ ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments complex(${ck}$), intent(in) :: alpha, beta - integer(ilp), intent(in) :: k, lda, ldc, n + integer(${ik}$), intent(in) :: k, lda, ldc, n character, intent(in) :: trans, uplo ! Array Arguments complex(${ck}$), intent(in) :: a(lda,*) @@ -3148,7 +3150,7 @@ module stdlib_linalg_blas_${ci}$ intrinsic :: max ! Local Scalars complex(${ck}$) :: temp - integer(ilp) :: i, info, j, l, nrowa + integer(${ik}$) :: i, info, j, l, nrowa logical(lk) :: upper @@ -3175,7 +3177,7 @@ module stdlib_linalg_blas_${ci}$ info = 10 end if if (info/=0) then - call stdlib_xerbla('ZSYRK ',info) + call stdlib${ii}$_xerbla('ZSYRK ',info) return end if ! quick return if possible. @@ -3290,10 +3292,10 @@ module stdlib_linalg_blas_${ci}$ end if end if return - end subroutine stdlib_${ci}$syrk + end subroutine stdlib${ii}$_${ci}$syrk - pure subroutine stdlib_${ci}$tbmv(uplo,trans,diag,n,k,a,lda,x,incx) + pure subroutine stdlib${ii}$_${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,7 +3304,7 @@ module stdlib_linalg_blas_${ci}$ ! -- 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, k, lda, n + integer(${ik}$), intent(in) :: incx, k, lda, n character, intent(in) :: diag, trans, uplo ! Array Arguments complex(${ck}$), intent(in) :: a(lda,*) @@ -3311,7 +3313,7 @@ module stdlib_linalg_blas_${ci}$ ! Local Scalars complex(${ck}$) :: temp - integer(ilp) :: i, info, ix, j, jx, kplus1, kx, l + integer(${ik}$) :: i, info, ix, j, jx, kplus1, kx, l logical(lk) :: noconj, nounit ! Intrinsic Functions intrinsic :: conjg,max,min @@ -3334,7 +3336,7 @@ module stdlib_linalg_blas_${ci}$ info = 9 end if if (info/=0) then - call stdlib_xerbla('ZTBMV ',info) + call stdlib${ii}$_xerbla('ZTBMV ',info) return end if ! quick return if possible. @@ -3504,10 +3506,10 @@ module stdlib_linalg_blas_${ci}$ end if end if return - end subroutine stdlib_${ci}$tbmv + end subroutine stdlib${ii}$_${ci}$tbmv - pure subroutine stdlib_${ci}$tbsv(uplo,trans,diag,n,k,a,lda,x,incx) + pure subroutine stdlib${ii}$_${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,7 +3521,7 @@ module stdlib_linalg_blas_${ci}$ ! -- 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, k, lda, n + integer(${ik}$), intent(in) :: incx, k, lda, n character, intent(in) :: diag, trans, uplo ! Array Arguments complex(${ck}$), intent(in) :: a(lda,*) @@ -3528,7 +3530,7 @@ module stdlib_linalg_blas_${ci}$ ! Local Scalars complex(${ck}$) :: temp - integer(ilp) :: i, info, ix, j, jx, kplus1, kx, l + integer(${ik}$) :: i, info, ix, j, jx, kplus1, kx, l logical(lk) :: noconj, nounit ! Intrinsic Functions intrinsic :: conjg,max,min @@ -3551,7 +3553,7 @@ module stdlib_linalg_blas_${ci}$ info = 9 end if if (info/=0) then - call stdlib_xerbla('ZTBSV ',info) + call stdlib${ii}$_xerbla('ZTBSV ',info) return end if ! quick return if possible. @@ -3721,10 +3723,10 @@ module stdlib_linalg_blas_${ci}$ end if end if return - end subroutine stdlib_${ci}$tbsv + end subroutine stdlib${ii}$_${ci}$tbsv - pure subroutine stdlib_${ci}$tpmv(uplo,trans,diag,n,ap,x,incx) + pure subroutine stdlib${ii}$_${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,7 +3735,7 @@ module stdlib_linalg_blas_${ci}$ ! -- 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 + integer(${ik}$), intent(in) :: incx, n character, intent(in) :: diag, trans, uplo ! Array Arguments complex(${ck}$), intent(in) :: ap(*) @@ -3742,7 +3744,7 @@ module stdlib_linalg_blas_${ci}$ ! Local Scalars complex(${ck}$) :: temp - integer(ilp) :: i, info, ix, j, jx, k, kk, kx + integer(${ik}$) :: i, info, ix, j, jx, k, kk, kx logical(lk) :: noconj, nounit ! Intrinsic Functions intrinsic :: conjg @@ -3761,7 +3763,7 @@ module stdlib_linalg_blas_${ci}$ info = 7 end if if (info/=0) then - call stdlib_xerbla('ZTPMV ',info) + call stdlib${ii}$_xerbla('ZTPMV ',info) return end if ! quick return if possible. @@ -3938,10 +3940,10 @@ module stdlib_linalg_blas_${ci}$ end if end if return - end subroutine stdlib_${ci}$tpmv + end subroutine stdlib${ii}$_${ci}$tpmv - pure subroutine stdlib_${ci}$tpsv(uplo,trans,diag,n,ap,x,incx) + pure subroutine stdlib${ii}$_${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,7 +3954,7 @@ module stdlib_linalg_blas_${ci}$ ! -- 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 + integer(${ik}$), intent(in) :: incx, n character, intent(in) :: diag, trans, uplo ! Array Arguments complex(${ck}$), intent(in) :: ap(*) @@ -3961,7 +3963,7 @@ module stdlib_linalg_blas_${ci}$ ! Local Scalars complex(${ck}$) :: temp - integer(ilp) :: i, info, ix, j, jx, k, kk, kx + integer(${ik}$) :: i, info, ix, j, jx, k, kk, kx logical(lk) :: noconj, nounit ! Intrinsic Functions intrinsic :: conjg @@ -3980,7 +3982,7 @@ module stdlib_linalg_blas_${ci}$ info = 7 end if if (info/=0) then - call stdlib_xerbla('ZTPSV ',info) + call stdlib${ii}$_xerbla('ZTPSV ',info) return end if ! quick return if possible. @@ -4157,10 +4159,10 @@ module stdlib_linalg_blas_${ci}$ end if end if return - end subroutine stdlib_${ci}$tpsv + end subroutine stdlib${ii}$_${ci}$tpsv - pure subroutine stdlib_${ci}$trmm(side,uplo,transa,diag,m,n,alpha,a,lda,b,ldb) + pure subroutine stdlib${ii}$_${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 @@ -4171,7 +4173,7 @@ module stdlib_linalg_blas_${ci}$ ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments complex(${ck}$), intent(in) :: alpha - integer(ilp), intent(in) :: lda, ldb, m, n + integer(${ik}$), intent(in) :: lda, ldb, m, n character, intent(in) :: diag, side, transa, uplo ! Array Arguments complex(${ck}$), intent(in) :: a(lda,*) @@ -4181,7 +4183,7 @@ module stdlib_linalg_blas_${ci}$ intrinsic :: conjg,max ! Local Scalars complex(${ck}$) :: temp - integer(ilp) :: i, info, j, k, nrowa + integer(${ik}$) :: i, info, j, k, nrowa logical(lk) :: lside, noconj, nounit, upper @@ -4216,7 +4218,7 @@ module stdlib_linalg_blas_${ci}$ info = 11 end if if (info/=0) then - call stdlib_xerbla('ZTRMM ',info) + call stdlib${ii}$_xerbla('ZTRMM ',info) return end if ! quick return if possible. @@ -4399,10 +4401,10 @@ module stdlib_linalg_blas_${ci}$ end if end if return - end subroutine stdlib_${ci}$trmm + end subroutine stdlib${ii}$_${ci}$trmm - pure subroutine stdlib_${ci}$trmv(uplo,trans,diag,n,a,lda,x,incx) + pure subroutine stdlib${ii}$_${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,7 +4413,7 @@ module stdlib_linalg_blas_${ci}$ ! -- 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, lda, n + integer(${ik}$), intent(in) :: incx, lda, n character, intent(in) :: diag, trans, uplo ! Array Arguments complex(${ck}$), intent(in) :: a(lda,*) @@ -4420,7 +4422,7 @@ module stdlib_linalg_blas_${ci}$ ! Local Scalars complex(${ck}$) :: temp - integer(ilp) :: i, info, ix, j, jx, kx + integer(${ik}$) :: i, info, ix, j, jx, kx logical(lk) :: noconj, nounit ! Intrinsic Functions intrinsic :: conjg,max @@ -4441,7 +4443,7 @@ module stdlib_linalg_blas_${ci}$ info = 8 end if if (info/=0) then - call stdlib_xerbla('ZTRMV ',info) + call stdlib${ii}$_xerbla('ZTRMV ',info) return end if ! quick return if possible. @@ -4596,10 +4598,10 @@ module stdlib_linalg_blas_${ci}$ end if end if return - end subroutine stdlib_${ci}$trmv + end subroutine stdlib${ii}$_${ci}$trmv - pure subroutine stdlib_${ci}$trsm(side,uplo,transa,diag,m,n,alpha,a,lda,b,ldb) + pure subroutine stdlib${ii}$_${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 @@ -4611,7 +4613,7 @@ module stdlib_linalg_blas_${ci}$ ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments complex(${ck}$), intent(in) :: alpha - integer(ilp), intent(in) :: lda, ldb, m, n + integer(${ik}$), intent(in) :: lda, ldb, m, n character, intent(in) :: diag, side, transa, uplo ! Array Arguments complex(${ck}$), intent(in) :: a(lda,*) @@ -4621,7 +4623,7 @@ module stdlib_linalg_blas_${ci}$ intrinsic :: conjg,max ! Local Scalars complex(${ck}$) :: temp - integer(ilp) :: i, info, j, k, nrowa + integer(${ik}$) :: i, info, j, k, nrowa logical(lk) :: lside, noconj, nounit, upper @@ -4656,7 +4658,7 @@ module stdlib_linalg_blas_${ci}$ info = 11 end if if (info/=0) then - call stdlib_xerbla('ZTRSM ',info) + call stdlib${ii}$_xerbla('ZTRSM ',info) return end if ! quick return if possible. @@ -4861,10 +4863,10 @@ module stdlib_linalg_blas_${ci}$ end if end if return - end subroutine stdlib_${ci}$trsm + end subroutine stdlib${ii}$_${ci}$trsm - pure subroutine stdlib_${ci}$trsv(uplo,trans,diag,n,a,lda,x,incx) + pure subroutine stdlib${ii}$_${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,7 +4877,7 @@ module stdlib_linalg_blas_${ci}$ ! -- 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, lda, n + integer(${ik}$), intent(in) :: incx, lda, n character, intent(in) :: diag, trans, uplo ! Array Arguments complex(${ck}$), intent(in) :: a(lda,*) @@ -4884,7 +4886,7 @@ module stdlib_linalg_blas_${ci}$ ! Local Scalars complex(${ck}$) :: temp - integer(ilp) :: i, info, ix, j, jx, kx + integer(${ik}$) :: i, info, ix, j, jx, kx logical(lk) :: noconj, nounit ! Intrinsic Functions intrinsic :: conjg,max @@ -4905,7 +4907,7 @@ module stdlib_linalg_blas_${ci}$ info = 8 end if if (info/=0) then - call stdlib_xerbla('ZTRSV ',info) + call stdlib${ii}$_xerbla('ZTRSV ',info) return end if ! quick return if possible. @@ -5060,9 +5062,9 @@ module stdlib_linalg_blas_${ci}$ end if end if return - end subroutine stdlib_${ci}$trsv - + end subroutine stdlib${ii}$_${ci}$trsv + #:endfor end module stdlib_linalg_blas_${ci}$ From 2c8de7b9a3ed772eb356f3baae866f8a432bf323 Mon Sep 17 00:00:00 2001 From: Federico Perini Date: Wed, 13 Nov 2024 18:49:52 +0100 Subject: [PATCH 11/31] `lapack_aux`: template integer type --- src/stdlib_linalg_lapack_aux.fypp | 409 +++++++++++++++--------------- 1 file changed, 205 insertions(+), 204 deletions(-) diff --git a/src/stdlib_linalg_lapack_aux.fypp b/src/stdlib_linalg_lapack_aux.fypp index 2856e4f74..0184af23d 100644 --- a/src/stdlib_linalg_lapack_aux.fypp +++ b/src/stdlib_linalg_lapack_aux.fypp @@ -7,36 +7,37 @@ module stdlib_linalg_lapack_aux private - public :: sp,dp,qp,lk,ilp - public :: stdlib_chla_transtype - public :: stdlib_ieeeck - public :: stdlib_iladiag - public :: stdlib_ilaenv - public :: stdlib_ilaenv2stage - public :: stdlib_ilaprec - public :: stdlib_ilatrans - public :: stdlib_ilauplo - public :: stdlib_iparam2stage - public :: stdlib_iparmq - public :: stdlib_lsamen - public :: stdlib_xerbla - public :: stdlib_xerbla_array - + public :: sp,dp,qp,lk,ilp,ilp64 + #:for ik,it,ii in LINALG_INT_KINDS_TYPES + public :: stdlib${ii}$_chla_transtype + public :: stdlib${ii}$_ieeeck + public :: stdlib${ii}$_iladiag + public :: stdlib${ii}$_ilaenv + public :: stdlib${ii}$_ilaenv2stage + public :: stdlib${ii}$_ilaprec + public :: stdlib${ii}$_ilatrans + public :: stdlib${ii}$_ilauplo + public :: stdlib${ii}$_iparam2stage + public :: stdlib${ii}$_iparmq + public :: stdlib${ii}$_lsamen + public :: stdlib${ii}$_xerbla + public :: stdlib${ii}$_xerbla_array + #:for rk,rt,ri in REAL_KINDS_TYPES + public :: stdlib${ii}$_${ri}$roundup_lwork + #:endfor + #:for ck,ct,ci in CMPLX_KINDS_TYPES + public :: stdlib${ii}$_i${ci}$max1 + #:endfor + #:for rk,rt,ri in RC_KINDS_TYPES + public :: stdlib${ii}$_ila${ri}$lc + public :: stdlib${ii}$_ila${ri}$lr + #:endfor + #:endfor #: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 + #: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., @@ -69,8 +70,8 @@ module stdlib_linalg_lapack_aux contains - - pure character function stdlib_chla_transtype( trans ) + #:for ik,it,ii in LINALG_INT_KINDS_TYPES + pure character function stdlib${ii}$_chla_transtype( trans ) !! This subroutine translates from a BLAST-specified integer constant to !! the character string specifying a transposition operation. !! CHLA_TRANSTYPE returns an CHARACTER*1. If CHLA_TRANSTYPE: is 'X', @@ -81,78 +82,78 @@ module stdlib_linalg_lapack_aux ! -- 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) :: trans + integer(${ik}$), intent(in) :: trans ! ===================================================================== ! Parameters - integer(ilp), parameter :: blas_no_trans = 111 - integer(ilp), parameter :: blas_trans = 112 - integer(ilp), parameter :: blas_conj_trans = 113 + integer(${ik}$), parameter :: blas_no_trans = 111 + integer(${ik}$), parameter :: blas_trans = 112 + integer(${ik}$), parameter :: blas_conj_trans = 113 ! Executable Statements if( trans==blas_no_trans ) then - stdlib_chla_transtype = 'N' + stdlib${ii}$_chla_transtype = 'N' else if( trans==blas_trans ) then - stdlib_chla_transtype = 'T' + stdlib${ii}$_chla_transtype = 'T' else if( trans==blas_conj_trans ) then - stdlib_chla_transtype = 'C' + stdlib${ii}$_chla_transtype = 'C' else - stdlib_chla_transtype = 'X' + stdlib${ii}$_chla_transtype = 'X' end if return - end function stdlib_chla_transtype + end function stdlib${ii}$_chla_transtype - pure integer(ilp) function stdlib_ieeeck( ispec, zero, one ) + pure integer(${ik}$) function stdlib${ii}$_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 -- ! -- 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) :: ispec + integer(${ik}$), intent(in) :: ispec real(sp), intent(in) :: one, zero ! ===================================================================== ! Local Scalars real(sp) :: nan1, nan2, nan3, nan4, nan5, nan6, neginf, negzro, newzro, posinf ! Executable Statements - stdlib_ieeeck = 1 + stdlib${ii}$_ieeeck = 1 posinf = one / zero if( posinf<=one ) then - stdlib_ieeeck = 0 + stdlib${ii}$_ieeeck = 0 return end if neginf = -one / zero if( neginf>=zero ) then - stdlib_ieeeck = 0 + stdlib${ii}$_ieeeck = 0 return end if negzro = one / ( neginf+one ) if( negzro/=zero ) then - stdlib_ieeeck = 0 + stdlib${ii}$_ieeeck = 0 return end if neginf = one / negzro if( neginf>=zero ) then - stdlib_ieeeck = 0 + stdlib${ii}$_ieeeck = 0 return end if newzro = negzro + zero if( newzro/=zero ) then - stdlib_ieeeck = 0 + stdlib${ii}$_ieeeck = 0 return end if posinf = one / newzro if( posinf<=one ) then - stdlib_ieeeck = 0 + stdlib${ii}$_ieeeck = 0 return end if neginf = neginf*posinf if( neginf>=zero ) then - stdlib_ieeeck = 0 + stdlib${ii}$_ieeeck = 0 return end if posinf = posinf*posinf if( posinf<=one ) then - stdlib_ieeeck = 0 + stdlib${ii}$_ieeeck = 0 return end if ! return if we were only asked to check infinity arithmetic @@ -164,36 +165,36 @@ module stdlib_linalg_lapack_aux nan5 = neginf*negzro nan6 = nan5*zero if( nan1==nan1 ) then - stdlib_ieeeck = 0 + stdlib${ii}$_ieeeck = 0 return end if if( nan2==nan2 ) then - stdlib_ieeeck = 0 + stdlib${ii}$_ieeeck = 0 return end if if( nan3==nan3 ) then - stdlib_ieeeck = 0 + stdlib${ii}$_ieeeck = 0 return end if if( nan4==nan4 ) then - stdlib_ieeeck = 0 + stdlib${ii}$_ieeeck = 0 return end if if( nan5==nan5 ) then - stdlib_ieeeck = 0 + stdlib${ii}$_ieeeck = 0 return end if if( nan6==nan6 ) then - stdlib_ieeeck = 0 + stdlib${ii}$_ieeeck = 0 return end if return - end function stdlib_ieeeck + end function stdlib${ii}$_ieeeck - integer(ilp) function stdlib_iladiag( diag ) + integer(${ik}$) function stdlib${ii}$_iladiag( diag ) !! This subroutine translated from a character string specifying if a !! matrix has unit diagonal or not to the relevant BLAST-specified !! integer constant. @@ -207,24 +208,24 @@ module stdlib_linalg_lapack_aux character :: diag ! ===================================================================== ! Parameters - integer(ilp), parameter :: blas_non_unit_diag = 131 - integer(ilp), parameter :: blas_unit_diag = 132 + integer(${ik}$), parameter :: blas_non_unit_diag = 131 + integer(${ik}$), parameter :: blas_unit_diag = 132 ! Executable Statements if( stdlib_lsame( diag, 'N' ) ) then - stdlib_iladiag = blas_non_unit_diag + stdlib${ii}$_iladiag = blas_non_unit_diag else if( stdlib_lsame( diag, 'U' ) ) then - stdlib_iladiag = blas_unit_diag + stdlib${ii}$_iladiag = blas_unit_diag else - stdlib_iladiag = -1 + stdlib${ii}$_iladiag = -1 end if return - end function stdlib_iladiag + end function stdlib${ii}$_iladiag - integer(ilp) function stdlib_ilaprec( prec ) + integer(${ik}$) function stdlib${ii}$_ilaprec( prec ) !! This subroutine translated from a character string specifying an !! intermediate precision to the relevant BLAST-specified integer !! constant. @@ -238,29 +239,29 @@ module stdlib_linalg_lapack_aux character :: prec ! ===================================================================== ! Parameters - integer(ilp), parameter :: blas_prec_single = 211 - integer(ilp), parameter :: blas_prec_double = 212 - integer(ilp), parameter :: blas_prec_indigenous = 213 - integer(ilp), parameter :: blas_prec_extra = 214 + integer(${ik}$), parameter :: blas_prec_single = 211 + integer(${ik}$), parameter :: blas_prec_double = 212 + integer(${ik}$), parameter :: blas_prec_indigenous = 213 + integer(${ik}$), parameter :: blas_prec_extra = 214 ! Executable Statements if( stdlib_lsame( prec, 'S' ) ) then - stdlib_ilaprec = blas_prec_single + stdlib${ii}$_ilaprec = blas_prec_single else if( stdlib_lsame( prec, 'D' ) ) then - stdlib_ilaprec = blas_prec_double + stdlib${ii}$_ilaprec = blas_prec_double else if( stdlib_lsame( prec, 'I' ) ) then - stdlib_ilaprec = blas_prec_indigenous + stdlib${ii}$_ilaprec = blas_prec_indigenous else if( stdlib_lsame( prec, 'X' ) .or. stdlib_lsame( prec, 'E' ) ) then - stdlib_ilaprec = blas_prec_extra + stdlib${ii}$_ilaprec = blas_prec_extra else - stdlib_ilaprec = -1 + stdlib${ii}$_ilaprec = -1 end if return - end function stdlib_ilaprec + end function stdlib${ii}$_ilaprec - integer(ilp) function stdlib_ilatrans( trans ) + integer(${ik}$) function stdlib${ii}$_ilatrans( trans ) !! This subroutine translates from a character string specifying a !! transposition operation to the relevant BLAST-specified integer !! constant. @@ -274,25 +275,25 @@ module stdlib_linalg_lapack_aux character :: trans ! ===================================================================== ! Parameters - integer(ilp), parameter :: blas_no_trans = 111 - integer(ilp), parameter :: blas_trans = 112 - integer(ilp), parameter :: blas_conj_trans = 113 + integer(${ik}$), parameter :: blas_no_trans = 111 + integer(${ik}$), parameter :: blas_trans = 112 + integer(${ik}$), parameter :: blas_conj_trans = 113 ! Executable Statements if( stdlib_lsame( trans, 'N' ) ) then - stdlib_ilatrans = blas_no_trans + stdlib${ii}$_ilatrans = blas_no_trans else if( stdlib_lsame( trans, 'T' ) ) then - stdlib_ilatrans = blas_trans + stdlib${ii}$_ilatrans = blas_trans else if( stdlib_lsame( trans, 'C' ) ) then - stdlib_ilatrans = blas_conj_trans + stdlib${ii}$_ilatrans = blas_conj_trans else - stdlib_ilatrans = -1 + stdlib${ii}$_ilatrans = -1 end if return - end function stdlib_ilatrans + end function stdlib${ii}$_ilatrans - integer(ilp) function stdlib_ilauplo( uplo ) + integer(${ik}$) function stdlib${ii}$_ilauplo( uplo ) !! This subroutine translated from a character string specifying a !! upper- or lower-triangular matrix to the relevant BLAST-specified !! integer constant. @@ -306,22 +307,22 @@ module stdlib_linalg_lapack_aux character :: uplo ! ===================================================================== ! Parameters - integer(ilp), parameter :: blas_upper = 121 - integer(ilp), parameter :: blas_lower = 122 + integer(${ik}$), parameter :: blas_upper = 121 + integer(${ik}$), parameter :: blas_lower = 122 ! Executable Statements if( stdlib_lsame( uplo, 'U' ) ) then - stdlib_ilauplo = blas_upper + stdlib${ii}$_ilauplo = blas_upper else if( stdlib_lsame( uplo, 'L' ) ) then - stdlib_ilauplo = blas_lower + stdlib${ii}$_ilauplo = blas_lower else - stdlib_ilauplo = -1 + stdlib${ii}$_ilauplo = -1 end if return - end function stdlib_ilauplo + end function stdlib${ii}$_ilauplo - pure integer(ilp) function stdlib_iparmq( ispec, name, opts, n, ilo, ihi, lwork ) + pure integer(${ik}$) function stdlib${ii}$_iparmq( ispec, name, opts, n, ilo, ihi, lwork ) !! This program sets problem and machine dependent parameters !! useful for xHSEQR and related subroutines for eigenvalue !! problems. It is called whenever @@ -330,29 +331,29 @@ module stdlib_linalg_lapack_aux ! -- 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) :: ihi, ilo, ispec, lwork, n + integer(${ik}$), intent(in) :: ihi, ilo, ispec, lwork, n character, intent(in) :: name*(*), opts*(*) ! ================================================================ ! Parameters - integer(ilp), parameter :: inmin = 12 - integer(ilp), parameter :: inwin = 13 - integer(ilp), parameter :: inibl = 14 - integer(ilp), parameter :: ishfts = 15 - integer(ilp), parameter :: iacc22 = 16 - integer(ilp), parameter :: icost = 17 - integer(ilp), parameter :: nmin = 75 - integer(ilp), parameter :: k22min = 14 - integer(ilp), parameter :: kacmin = 14 - integer(ilp), parameter :: nibble = 14 - integer(ilp), parameter :: knwswp = 500 - integer(ilp), parameter :: rcost = 10 + integer(${ik}$), parameter :: inmin = 12 + integer(${ik}$), parameter :: inwin = 13 + integer(${ik}$), parameter :: inibl = 14 + integer(${ik}$), parameter :: ishfts = 15 + integer(${ik}$), parameter :: iacc22 = 16 + integer(${ik}$), parameter :: icost = 17 + integer(${ik}$), parameter :: nmin = 75 + integer(${ik}$), parameter :: k22min = 14 + integer(${ik}$), parameter :: kacmin = 14 + integer(${ik}$), parameter :: nibble = 14 + integer(${ik}$), parameter :: knwswp = 500 + integer(${ik}$), parameter :: rcost = 10 real(sp), parameter :: two = 2.0 ! Local Scalars - integer(ilp) :: nh, ns - integer(ilp) :: i, ic, iz + integer(${ik}$) :: nh, ns + integer(${ik}$) :: i, ic, iz character :: subnam*6 ! Intrinsic Functions intrinsic :: log,max,mod,nint,real @@ -374,21 +375,21 @@ module stdlib_linalg_lapack_aux ! ===== matrices of order smaller than nmin get sent ! . to xlahqr, the classic double shift algorithm. ! . this must be at least 11. ==== - stdlib_iparmq = nmin + stdlib${ii}$_iparmq = nmin else if( ispec==inibl ) then ! ==== inibl: skip a multi-shift qr iteration and ! . whenever aggressive early deflation finds ! . at least (nibble*(window size)/100) deflations. ==== - stdlib_iparmq = nibble + stdlib${ii}$_iparmq = nibble else if( ispec==ishfts ) then ! ==== nshfts: the number of simultaneous shifts ===== - stdlib_iparmq = ns + stdlib${ii}$_iparmq = ns else if( ispec==inwin ) then ! ==== nw: deflation window size. ==== if( nh<=knwswp ) then - stdlib_iparmq = ns + stdlib${ii}$_iparmq = ns else - stdlib_iparmq = 3*ns / 2 + stdlib${ii}$_iparmq = 3*ns / 2 end if else if( ispec==iacc22 ) then ! ==== iacc22: whether to accumulate reflections @@ -398,7 +399,7 @@ module stdlib_linalg_lapack_aux ! . by making this choice dependent also upon the ! . nh=ihi-ilo+1. ! convert name to upper case if the first character is lower case. - stdlib_iparmq = 0 + stdlib${ii}$_iparmq = 0 subnam = name ic = ichar( subnam( 1: 1 ) ) iz = ichar( 'Z' ) @@ -433,26 +434,26 @@ module stdlib_linalg_lapack_aux end if end if if( subnam( 2:6 )=='GGHRD' .or.subnam( 2:6 )=='GGHD3' ) then - stdlib_iparmq = 1 - if( nh>=k22min )stdlib_iparmq = 2 + stdlib${ii}$_iparmq = 1 + if( nh>=k22min )stdlib${ii}$_iparmq = 2 else if ( subnam( 4:6 )=='EXC' ) then - if( nh>=kacmin )stdlib_iparmq = 1 - if( nh>=k22min )stdlib_iparmq = 2 + if( nh>=kacmin )stdlib${ii}$_iparmq = 1 + if( nh>=k22min )stdlib${ii}$_iparmq = 2 else if ( subnam( 2:6 )=='HSEQR' .or.subnam( 2:5 )=='LAQR' ) then - if( ns>=kacmin )stdlib_iparmq = 1 - if( ns>=k22min )stdlib_iparmq = 2 + if( ns>=kacmin )stdlib${ii}$_iparmq = 1 + if( ns>=k22min )stdlib${ii}$_iparmq = 2 end if else if( ispec==icost ) then ! === relative cost of near-the-diagonal chase vs ! blas updates === - stdlib_iparmq = rcost + stdlib${ii}$_iparmq = rcost else ! ===== invalid value of ispec ===== - stdlib_iparmq = -1 + stdlib${ii}$_iparmq = -1 end if - end function stdlib_iparmq + end function stdlib${ii}$_iparmq - pure logical(lk) function stdlib_lsamen( n, ca, cb ) + pure logical(lk) function stdlib${ii}$_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 @@ -463,56 +464,56 @@ module stdlib_linalg_lapack_aux ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character(len=*), intent(in) :: ca, cb - integer(ilp), intent(in) :: n + integer(${ik}$), intent(in) :: n ! ===================================================================== ! Local Scalars - integer(ilp) :: i + integer(${ik}$) :: i ! Intrinsic Functions intrinsic :: len ! Executable Statements - stdlib_lsamen = .false. + stdlib${ii}$_lsamen = .false. if( len( ca )= 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..-- ! Scalar Arguments - integer(ilp), intent(in) :: lwork + integer(${ik}$), intent(in) :: lwork ! ===================================================================== ! Intrinsic Functions intrinsic :: epsilon,real,int ! Executable Statements - stdlib_${ri}$roundup_lwork = real(lwork,KIND=${rk}$) - if (int( stdlib_${ri}$roundup_lwork,KIND=ilp)=1)) i=i-1 enddo - stdlib_ila${ri}$lr = max( stdlib_ila${ri}$lr, i ) + stdlib${ii}$_ila${ri}$lr = max( stdlib${ii}$_ila${ri}$lr, i ) end do end if return - end function stdlib_ila${ri}$lr + end function stdlib${ii}$_ila${ri}$lr #:endfor #:for ck,ct,ci in CMPLX_KINDS_TYPES - pure integer(ilp) function stdlib_i${ci}$max1( n, zx, incx ) + pure integer(${ik}$) function stdlib${ii}$_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. @@ -584,26 +585,26 @@ module stdlib_linalg_lapack_aux ! -- 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 + integer(${ik}$), intent(in) :: incx, n ! Array Arguments complex(${ck}$), intent(in) :: zx(*) ! ===================================================================== ! Local Scalars real(${ck}$) :: dmax - integer(ilp) :: i, ix + integer(${ik}$) :: i, ix ! Intrinsic Functions intrinsic :: abs ! Executable Statements - stdlib_i${ci}$max1 = 0 + stdlib${ii}$_i${ci}$max1 = 0 if (n<1 .or. incx<=0) return - stdlib_i${ci}$max1 = 1 + stdlib${ii}$_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_i${ci}$max1 = i + stdlib${ii}$_i${ci}$max1 = i dmax = abs(zx(i)) end if end do @@ -614,18 +615,18 @@ module stdlib_linalg_lapack_aux ix = ix + incx do i = 2,n if (abs(zx(ix))>dmax) then - stdlib_i${ci}$max1 = i + stdlib${ii}$_i${ci}$max1 = i dmax = abs(zx(ix)) end if ix = ix + incx end do end if return - end function stdlib_i${ci}$max1 + end function stdlib${ii}$_i${ci}$max1 #:endfor - pure integer(ilp) function stdlib_ilaenv( ispec, name, opts, n1, n2, n3, n4 ) + pure integer(${ik}$) function stdlib${ii}$_ilaenv( ispec, name, opts, n1, n2, n3, n4 ) !! ILAENV is called from the LAPACK routines to choose problem-dependent !! parameters for the local environment. See ISPEC for a description of !! the parameters. @@ -644,10 +645,10 @@ module stdlib_linalg_lapack_aux ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character(len=*), intent(in) :: name, opts - integer(ilp), intent(in) :: ispec, n1, n2, n3, n4 + integer(${ik}$), intent(in) :: ispec, n1, n2, n3, n4 ! ===================================================================== ! Local Scalars - integer(ilp) :: i, ic, iz, nb, nbmin, nx + integer(${ik}$) :: i, ic, iz, nb, nbmin, nx logical(lk) :: cname, sname, twostage character :: c1*1, c2*2, c4*2, c3*3, subnam*16 ! Intrinsic Functions @@ -656,11 +657,11 @@ module stdlib_linalg_lapack_aux go to ( 10, 10, 10, 80, 90, 100, 110, 120,130, 140, 150, 160, 160, 160, 160, 160, 160)& ispec ! invalid value for ispec - stdlib_ilaenv = -1 + stdlib${ii}$_ilaenv = -1 return 10 continue ! convert name to upper case if the first character is lower case. - stdlib_ilaenv = 1 + stdlib${ii}$_ilaenv = 1 subnam = name ic = ichar( subnam( 1: 1 ) ) iz = ichar( 'Z' ) @@ -926,7 +927,7 @@ module stdlib_linalg_lapack_aux end if end if end if - stdlib_ilaenv = nb + stdlib${ii}$_ilaenv = nb return 60 continue ! ispec = 2: minimum block size @@ -1001,7 +1002,7 @@ module stdlib_linalg_lapack_aux nbmin = 2 end if end if - stdlib_ilaenv = nbmin + stdlib${ii}$_ilaenv = nbmin return 70 continue ! ispec = 3: crossover point @@ -1054,58 +1055,58 @@ module stdlib_linalg_lapack_aux nx = 128 end if end if - stdlib_ilaenv = nx + stdlib${ii}$_ilaenv = nx return 80 continue ! ispec = 4: number of shifts (used by xhseqr) - stdlib_ilaenv = 6 + stdlib${ii}$_ilaenv = 6 return 90 continue ! ispec = 5: minimum column dimension (not used) - stdlib_ilaenv = 2 + stdlib${ii}$_ilaenv = 2 return 100 continue ! ispec = 6: crossover point for svd (used by xgelss and xgesvd) - stdlib_ilaenv = int( real( min( n1, n2 ),KIND=dp)*1.6e0,KIND=ilp) + stdlib${ii}$_ilaenv = int( real( min( n1, n2 ),KIND=dp)*1.6e0,KIND=ilp) return 110 continue ! ispec = 7: number of processors (not used) - stdlib_ilaenv = 1 + stdlib${ii}$_ilaenv = 1 return 120 continue ! ispec = 8: crossover point for multishift (used by xhseqr) - stdlib_ilaenv = 50 + stdlib${ii}$_ilaenv = 50 return 130 continue ! ispec = 9: maximum size of the subproblems at the bottom of the ! computation tree in the divide-and-conquer algorithm ! (used by xgelsd and xgesdd) - stdlib_ilaenv = 25 + stdlib${ii}$_ilaenv = 25 return 140 continue ! ispec = 10: ieee and infinity nan arithmetic can be trusted not to trap - ! stdlib_ilaenv = 0 - stdlib_ilaenv = 1 - if( stdlib_ilaenv==1 ) then - stdlib_ilaenv = stdlib_ieeeck( 1, 0.0, 1.0 ) + ! stdlib${ii}$_ilaenv = 0 + stdlib${ii}$_ilaenv = 1 + if( stdlib${ii}$_ilaenv==1 ) then + stdlib${ii}$_ilaenv = stdlib${ii}$_ieeeck( 1_${ik}$, 0.0, 1.0 ) end if return 150 continue ! ispec = 11: ieee infinity arithmetic can be trusted not to trap - ! stdlib_ilaenv = 0 - stdlib_ilaenv = 1 - if( stdlib_ilaenv==1 ) then - stdlib_ilaenv = stdlib_ieeeck( 0, 0.0, 1.0 ) + ! stdlib${ii}$_ilaenv = 0 + stdlib${ii}$_ilaenv = 1 + if( stdlib${ii}$_ilaenv==1 ) then + stdlib${ii}$_ilaenv = stdlib${ii}$_ieeeck( 0_${ik}$, 0.0, 1.0 ) end if return 160 continue ! 12 <= ispec <= 17: xhseqr or related subroutines. - stdlib_ilaenv = stdlib_iparmq( ispec, name, opts, n1, n2, n3, n4 ) + stdlib${ii}$_ilaenv = stdlib${ii}$_iparmq( ispec, name, opts, n1, n2, n3, n4 ) return - end function stdlib_ilaenv + end function stdlib${ii}$_ilaenv - integer(ilp) function stdlib_iparam2stage( ispec, name, opts,ni, nbi, ibi, nxi ) + integer(${ik}$) function stdlib${ii}$_iparam2stage( ispec, name, opts,ni, nbi, ibi, nxi ) !! This program sets problem and machine dependent parameters !! useful for xHETRD_2STAGE, xHETRD_HE2HB, xHETRD_HB2ST, !! xGEBRD_2STAGE, xGEBRD_GE2GB, xGEBRD_GB2BD @@ -1118,10 +1119,10 @@ module stdlib_linalg_lapack_aux ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character(len=*), intent(in) :: name, opts - integer(ilp), intent(in) :: ispec, ni, nbi, ibi, nxi + integer(${ik}$), intent(in) :: ispec, ni, nbi, ibi, nxi ! ================================================================ ! Local Scalars - integer(ilp) :: i, ic, iz, kd, ib, lhous, lwork, nthreads, factoptnb, qroptnb, & + integer(${ik}$) :: i, ic, iz, kd, ib, lhous, lwork, nthreads, factoptnb, qroptnb, & lqoptnb logical(lk) :: rprec, cprec character :: prec*1, algo*3, stag*5, subnam*12, vect*1 @@ -1130,7 +1131,7 @@ module stdlib_linalg_lapack_aux ! Executable Statements ! invalid value for ispec if( (ispec<17).or.(ispec>21) ) then - stdlib_iparam2stage = -1 + stdlib${ii}$_iparam2stage = -1 return endif ! get the number of threads @@ -1140,7 +1141,7 @@ module stdlib_linalg_lapack_aux ! write(*,*) 'iparam voici nthreads ispec ',nthreads, ispec if( ispec /= 19 ) then ! convert name to upper case if the first character is lower case. - stdlib_iparam2stage = -1 + stdlib${ii}$_iparam2stage = -1 subnam = name ic = ichar( subnam( 1: 1 ) ) iz = ichar( 'Z' ) @@ -1181,7 +1182,7 @@ module stdlib_linalg_lapack_aux cprec = prec=='C' .or. prec=='Z' ! invalid value for precision if( .not.( rprec .or. cprec ) ) then - stdlib_iparam2stage = -1 + stdlib${ii}$_iparam2stage = -1 return endif endif @@ -1216,8 +1217,8 @@ module stdlib_linalg_lapack_aux ib = 16 endif endif - if( ispec==17 ) stdlib_iparam2stage = kd - if( ispec==18 ) stdlib_iparam2stage = ib + if( ispec==17 ) stdlib${ii}$_iparam2stage = kd + if( ispec==18 ) stdlib${ii}$_iparam2stage = ib else if ( ispec == 19 ) then ! ispec = 19: ! lhous length of the houselholder representation @@ -1231,9 +1232,9 @@ module stdlib_linalg_lapack_aux lhous = max( 1, 4*ni ) + ibi endif if( lhous>=0 ) then - stdlib_iparam2stage = lhous + stdlib${ii}$_iparam2stage = lhous else - stdlib_iparam2stage = -1 + stdlib${ii}$_iparam2stage = -1 endif else if ( ispec == 20 ) then ! ispec = 20: (21 for future use) @@ -1252,9 +1253,9 @@ module stdlib_linalg_lapack_aux lwork = -1 subnam(1:1) = prec subnam(2:6) = 'GEQRF' - qroptnb = stdlib_ilaenv( 1, subnam, ' ', ni, nbi, -1, -1 ) + qroptnb = stdlib${ii}$_ilaenv( 1_${ik}$, subnam, ' ', ni, nbi, -1_${ik}$, -1_${ik}$ ) subnam(2:6) = 'GELQF' - lqoptnb = stdlib_ilaenv( 1, subnam, ' ', nbi, ni, -1, -1 ) + lqoptnb = stdlib${ii}$_ilaenv( 1_${ik}$, subnam, ' ', nbi, ni, -1_${ik}$, -1_${ik}$ ) ! could be qr or lq for trd and the max for brd factoptnb = max(qroptnb, lqoptnb) if( algo=='TRD' ) then @@ -1278,18 +1279,18 @@ module stdlib_linalg_lapack_aux endif lwork = max ( 1, lwork ) if( lwork>0 ) then - stdlib_iparam2stage = lwork + stdlib${ii}$_iparam2stage = lwork else - stdlib_iparam2stage = -1 + stdlib${ii}$_iparam2stage = -1 endif else if ( ispec == 21 ) then ! ispec = 21 for future use - stdlib_iparam2stage = nxi + stdlib${ii}$_iparam2stage = nxi endif - end function stdlib_iparam2stage + end function stdlib${ii}$_iparam2stage - integer(ilp) function stdlib_ilaenv2stage( ispec, name, opts, n1, n2, n3, n4 ) + integer(${ik}$) function stdlib${ii}$_ilaenv2stage( ispec, name, opts, n1, n2, n3, n4 ) !! ILAENV2STAGE is called from the LAPACK routines to choose problem-dependent !! parameters for the local environment. See ISPEC for a description of !! the parameters. @@ -1313,22 +1314,22 @@ module stdlib_linalg_lapack_aux ! july 2017 ! Scalar Arguments character(len=*), intent(in) :: name, opts - integer(ilp), intent(in) :: ispec, n1, n2, n3, n4 + integer(${ik}$), intent(in) :: ispec, n1, n2, n3, n4 ! ===================================================================== ! Local Scalars - integer(ilp) :: iispec + integer(${ik}$) :: iispec ! Executable Statements go to ( 10, 10, 10, 10, 10 )ispec ! invalid value for ispec - stdlib_ilaenv2stage = -1 + stdlib${ii}$_ilaenv2stage = -1 return 10 continue ! 2stage eigenvalues and svd or related subroutines. iispec = 16 + ispec - stdlib_ilaenv2stage = stdlib_iparam2stage( iispec, name, opts,n1, n2, n3, n4 ) + stdlib${ii}$_ilaenv2stage = stdlib${ii}$_iparam2stage( iispec, name, opts,n1, n2, n3, n4 ) return - end function stdlib_ilaenv2stage - + end function stdlib${ii}$_ilaenv2stage + #:endfor end module stdlib_linalg_lapack_aux From fbac7a43345b2b36ac9680a24ce5a31e011317c5 Mon Sep 17 00:00:00 2001 From: Federico Perini Date: Wed, 13 Nov 2024 21:12:56 +0100 Subject: [PATCH 12/31] `lapack_s`: template integer kind --- src/stdlib_linalg_lapack_s.fypp | 52804 +++++++++++++++--------------- 1 file changed, 26403 insertions(+), 26401 deletions(-) diff --git a/src/stdlib_linalg_lapack_s.fypp b/src/stdlib_linalg_lapack_s.fypp index 24d0f1577..e5274464e 100644 --- a/src/stdlib_linalg_lapack_s.fypp +++ b/src/stdlib_linalg_lapack_s.fypp @@ -7,474 +7,476 @@ module stdlib_linalg_lapack_s private - public :: sp,dp,qp,lk,ilp - public :: stdlib_sbbcsd - public :: stdlib_sbdsdc - public :: stdlib_sbdsqr - public :: stdlib_scsum1 - public :: stdlib_sdisna - public :: stdlib_sgbbrd - public :: stdlib_sgbcon - public :: stdlib_sgbequ - public :: stdlib_sgbequb - public :: stdlib_sgbrfs - public :: stdlib_sgbsv - public :: stdlib_sgbsvx - public :: stdlib_sgbtf2 - public :: stdlib_sgbtrf - public :: stdlib_sgbtrs - public :: stdlib_sgebak - public :: stdlib_sgebal - public :: stdlib_sgebd2 - public :: stdlib_sgebrd - public :: stdlib_sgecon - public :: stdlib_sgeequ - public :: stdlib_sgeequb - public :: stdlib_sgees - public :: stdlib_sgeesx - public :: stdlib_sgeev - public :: stdlib_sgeevx - public :: stdlib_sgehd2 - public :: stdlib_sgehrd - public :: stdlib_sgejsv - public :: stdlib_sgelq - public :: stdlib_sgelq2 - public :: stdlib_sgelqf - public :: stdlib_sgelqt - public :: stdlib_sgelqt3 - public :: stdlib_sgels - public :: stdlib_sgelsd - public :: stdlib_sgelss - public :: stdlib_sgelsy - public :: stdlib_sgemlq - public :: stdlib_sgemlqt - public :: stdlib_sgemqr - public :: stdlib_sgemqrt - public :: stdlib_sgeql2 - public :: stdlib_sgeqlf - public :: stdlib_sgeqp3 - public :: stdlib_sgeqr - public :: stdlib_sgeqr2 - public :: stdlib_sgeqr2p - public :: stdlib_sgeqrf - public :: stdlib_sgeqrfp - public :: stdlib_sgeqrt - public :: stdlib_sgeqrt2 - public :: stdlib_sgeqrt3 - public :: stdlib_sgerfs - public :: stdlib_sgerq2 - public :: stdlib_sgerqf - public :: stdlib_sgesc2 - public :: stdlib_sgesdd - public :: stdlib_sgesv - public :: stdlib_sgesvd - public :: stdlib_sgesvdq - public :: stdlib_sgesvj - public :: stdlib_sgesvx - public :: stdlib_sgetc2 - public :: stdlib_sgetf2 - public :: stdlib_sgetrf - public :: stdlib_sgetrf2 - public :: stdlib_sgetri - public :: stdlib_sgetrs - public :: stdlib_sgetsls - public :: stdlib_sgetsqrhrt - public :: stdlib_sggbak - public :: stdlib_sggbal - public :: stdlib_sgges - public :: stdlib_sgges3 - public :: stdlib_sggesx - public :: stdlib_sggev - public :: stdlib_sggev3 - public :: stdlib_sggevx - public :: stdlib_sggglm - public :: stdlib_sgghd3 - public :: stdlib_sgghrd - public :: stdlib_sgglse - public :: stdlib_sggqrf - public :: stdlib_sggrqf - public :: stdlib_sgsvj0 - public :: stdlib_sgsvj1 - public :: stdlib_sgtcon - public :: stdlib_sgtrfs - public :: stdlib_sgtsv - public :: stdlib_sgtsvx - public :: stdlib_sgttrf - public :: stdlib_sgttrs - public :: stdlib_sgtts2 - public :: stdlib_shgeqz - public :: stdlib_shsein - public :: stdlib_shseqr - public :: stdlib_sisnan - public :: stdlib_sla_gbamv - public :: stdlib_sla_gbrcond - public :: stdlib_sla_gbrpvgrw - public :: stdlib_sla_geamv - public :: stdlib_sla_gercond - public :: stdlib_sla_gerpvgrw - public :: stdlib_sla_lin_berr - public :: stdlib_sla_porcond - public :: stdlib_sla_porpvgrw - public :: stdlib_sla_syamv - public :: stdlib_sla_syrcond - public :: stdlib_sla_syrpvgrw - public :: stdlib_sla_wwaddw - public :: stdlib_slabad - public :: stdlib_slabrd - public :: stdlib_slacn2 - public :: stdlib_slacon - public :: stdlib_slacpy - public :: stdlib_sladiv - public :: stdlib_sladiv1 - public :: stdlib_sladiv2 - public :: stdlib_slae2 - public :: stdlib_slaebz - public :: stdlib_slaed0 - public :: stdlib_slaed1 - public :: stdlib_slaed2 - public :: stdlib_slaed3 - public :: stdlib_slaed4 - public :: stdlib_slaed5 - public :: stdlib_slaed6 - public :: stdlib_slaed7 - public :: stdlib_slaed8 - public :: stdlib_slaed9 - public :: stdlib_slaeda - public :: stdlib_slaein - public :: stdlib_slaev2 - public :: stdlib_slaexc - public :: stdlib_slag2 - public :: stdlib_slag2d - public :: stdlib_slags2 - public :: stdlib_slagtf - public :: stdlib_slagtm - public :: stdlib_slagts - public :: stdlib_slagv2 - public :: stdlib_slahqr - public :: stdlib_slahr2 - public :: stdlib_slaic1 - public :: stdlib_slaisnan - public :: stdlib_slaln2 - public :: stdlib_slals0 - public :: stdlib_slalsa - public :: stdlib_slalsd - public :: stdlib_slamch - public :: stdlib_slamc3 - public :: stdlib_slamrg - public :: stdlib_slamswlq - public :: stdlib_slamtsqr - public :: stdlib_slaneg - public :: stdlib_slangb - public :: stdlib_slange - public :: stdlib_slangt - public :: stdlib_slanhs - public :: stdlib_slansb - public :: stdlib_slansf - public :: stdlib_slansp - public :: stdlib_slanst - public :: stdlib_slansy - public :: stdlib_slantb - public :: stdlib_slantp - public :: stdlib_slantr - public :: stdlib_slanv2 - public :: stdlib_slaorhr_col_getrfnp - public :: stdlib_slaorhr_col_getrfnp2 - public :: stdlib_slapll - public :: stdlib_slapmr - public :: stdlib_slapmt - public :: stdlib_slapy2 - public :: stdlib_slapy3 - public :: stdlib_slaqgb - public :: stdlib_slaqge - public :: stdlib_slaqp2 - public :: stdlib_slaqps - public :: stdlib_slaqr0 - public :: stdlib_slaqr1 - public :: stdlib_slaqr2 - public :: stdlib_slaqr3 - public :: stdlib_slaqr4 - public :: stdlib_slaqr5 - public :: stdlib_slaqsb - public :: stdlib_slaqsp - public :: stdlib_slaqsy - public :: stdlib_slaqtr - public :: stdlib_slaqz0 - public :: stdlib_slaqz1 - public :: stdlib_slaqz2 - public :: stdlib_slaqz3 - public :: stdlib_slaqz4 - public :: stdlib_slar1v - public :: stdlib_slar2v - public :: stdlib_slarf - public :: stdlib_slarfb - public :: stdlib_slarfb_gett - public :: stdlib_slarfg - public :: stdlib_slarfgp - public :: stdlib_slarft - public :: stdlib_slarfx - public :: stdlib_slarfy - public :: stdlib_slargv - public :: stdlib_slarnv - public :: stdlib_slarra - public :: stdlib_slarrb - public :: stdlib_slarrc - public :: stdlib_slarrd - public :: stdlib_slarre - public :: stdlib_slarrf - public :: stdlib_slarrj - public :: stdlib_slarrk - public :: stdlib_slarrr - public :: stdlib_slarrv - public :: stdlib_slartg - public :: stdlib_slartgp - public :: stdlib_slartgs - public :: stdlib_slartv - public :: stdlib_slaruv - public :: stdlib_slarz - public :: stdlib_slarzb - public :: stdlib_slarzt - public :: stdlib_slas2 - public :: stdlib_slascl - public :: stdlib_slasd0 - public :: stdlib_slasd1 - public :: stdlib_slasd2 - public :: stdlib_slasd3 - public :: stdlib_slasd4 - public :: stdlib_slasd5 - public :: stdlib_slasd6 - public :: stdlib_slasd7 - public :: stdlib_slasd8 - public :: stdlib_slasda - public :: stdlib_slasdq - public :: stdlib_slasdt - public :: stdlib_slaset - public :: stdlib_slasq1 - public :: stdlib_slasq2 - public :: stdlib_slasq3 - public :: stdlib_slasq4 - public :: stdlib_slasq5 - public :: stdlib_slasq6 - public :: stdlib_slasr - public :: stdlib_slasrt - public :: stdlib_slassq - public :: stdlib_slasv2 - public :: stdlib_slaswlq - public :: stdlib_slaswp - public :: stdlib_slasy2 - public :: stdlib_slasyf - public :: stdlib_slasyf_aa - public :: stdlib_slasyf_rk - public :: stdlib_slasyf_rook - public :: stdlib_slatbs - public :: stdlib_slatdf - public :: stdlib_slatps - public :: stdlib_slatrd - public :: stdlib_slatrs - public :: stdlib_slatrz - public :: stdlib_slatsqr - public :: stdlib_slauu2 - public :: stdlib_slauum - public :: stdlib_sopgtr - public :: stdlib_sopmtr - public :: stdlib_sorbdb - public :: stdlib_sorbdb1 - public :: stdlib_sorbdb2 - public :: stdlib_sorbdb3 - public :: stdlib_sorbdb4 - public :: stdlib_sorbdb5 - public :: stdlib_sorbdb6 - public :: stdlib_sorcsd - public :: stdlib_sorcsd2by1 - public :: stdlib_sorg2l - public :: stdlib_sorg2r - public :: stdlib_sorgbr - public :: stdlib_sorghr - public :: stdlib_sorgl2 - public :: stdlib_sorglq - public :: stdlib_sorgql - public :: stdlib_sorgqr - public :: stdlib_sorgr2 - public :: stdlib_sorgrq - public :: stdlib_sorgtr - public :: stdlib_sorgtsqr - public :: stdlib_sorgtsqr_row - public :: stdlib_sorhr_col - public :: stdlib_sorm22 - public :: stdlib_sorm2l - public :: stdlib_sorm2r - public :: stdlib_sormbr - public :: stdlib_sormhr - public :: stdlib_sorml2 - public :: stdlib_sormlq - public :: stdlib_sormql - public :: stdlib_sormqr - public :: stdlib_sormr2 - public :: stdlib_sormr3 - public :: stdlib_sormrq - public :: stdlib_sormrz - public :: stdlib_sormtr - public :: stdlib_spbcon - public :: stdlib_spbequ - public :: stdlib_spbrfs - public :: stdlib_spbstf - public :: stdlib_spbsv - public :: stdlib_spbsvx - public :: stdlib_spbtf2 - public :: stdlib_spbtrf - public :: stdlib_spbtrs - public :: stdlib_spftrf - public :: stdlib_spftri - public :: stdlib_spftrs - public :: stdlib_spocon - public :: stdlib_spoequ - public :: stdlib_spoequb - public :: stdlib_sporfs - public :: stdlib_sposv - public :: stdlib_sposvx - public :: stdlib_spotf2 - public :: stdlib_spotrf - public :: stdlib_spotrf2 - public :: stdlib_spotri - public :: stdlib_spotrs - public :: stdlib_sppcon - public :: stdlib_sppequ - public :: stdlib_spprfs - public :: stdlib_sppsv - public :: stdlib_sppsvx - public :: stdlib_spptrf - public :: stdlib_spptri - public :: stdlib_spptrs - public :: stdlib_spstf2 - public :: stdlib_spstrf - public :: stdlib_sptcon - public :: stdlib_spteqr - public :: stdlib_sptrfs - public :: stdlib_sptsv - public :: stdlib_sptsvx - public :: stdlib_spttrf - public :: stdlib_spttrs - public :: stdlib_sptts2 - public :: stdlib_srscl - public :: stdlib_ssb2st_kernels - public :: stdlib_ssbev - public :: stdlib_ssbevd - public :: stdlib_ssbevx - public :: stdlib_ssbgst - public :: stdlib_ssbgv - public :: stdlib_ssbgvd - public :: stdlib_ssbgvx - public :: stdlib_ssbtrd - public :: stdlib_ssfrk - public :: stdlib_sspcon - public :: stdlib_sspev - public :: stdlib_sspevd - public :: stdlib_sspevx - public :: stdlib_sspgst - public :: stdlib_sspgv - public :: stdlib_sspgvd - public :: stdlib_sspgvx - public :: stdlib_ssprfs - public :: stdlib_sspsv - public :: stdlib_sspsvx - public :: stdlib_ssptrd - public :: stdlib_ssptrf - public :: stdlib_ssptri - public :: stdlib_ssptrs - public :: stdlib_sstebz - public :: stdlib_sstedc - public :: stdlib_sstegr - public :: stdlib_sstein - public :: stdlib_sstemr - public :: stdlib_ssteqr - public :: stdlib_ssterf - public :: stdlib_sstev - public :: stdlib_sstevd - public :: stdlib_sstevr - public :: stdlib_sstevx - public :: stdlib_ssycon - public :: stdlib_ssycon_rook - public :: stdlib_ssyconv - public :: stdlib_ssyconvf - public :: stdlib_ssyconvf_rook - public :: stdlib_ssyequb - public :: stdlib_ssyev - public :: stdlib_ssyevd - public :: stdlib_ssyevr - public :: stdlib_ssyevx - public :: stdlib_ssygs2 - public :: stdlib_ssygst - public :: stdlib_ssygv - public :: stdlib_ssygvd - public :: stdlib_ssygvx - public :: stdlib_ssyrfs - public :: stdlib_ssysv - public :: stdlib_ssysv_aa - public :: stdlib_ssysv_rk - public :: stdlib_ssysv_rook - public :: stdlib_ssysvx - public :: stdlib_ssyswapr - public :: stdlib_ssytd2 - public :: stdlib_ssytf2 - public :: stdlib_ssytf2_rk - public :: stdlib_ssytf2_rook - public :: stdlib_ssytrd - public :: stdlib_ssytrd_sb2st - public :: stdlib_ssytrd_sy2sb - public :: stdlib_ssytrf - public :: stdlib_ssytrf_aa - public :: stdlib_ssytrf_rk - public :: stdlib_ssytrf_rook - public :: stdlib_ssytri - public :: stdlib_ssytri_rook - public :: stdlib_ssytrs - public :: stdlib_ssytrs2 - public :: stdlib_ssytrs_3 - public :: stdlib_ssytrs_aa - public :: stdlib_ssytrs_rook - public :: stdlib_stbcon - public :: stdlib_stbrfs - public :: stdlib_stbtrs - public :: stdlib_stfsm - public :: stdlib_stftri - public :: stdlib_stfttp - public :: stdlib_stfttr - public :: stdlib_stgevc - public :: stdlib_stgex2 - public :: stdlib_stgexc - public :: stdlib_stgsen - public :: stdlib_stgsja - public :: stdlib_stgsna - public :: stdlib_stgsy2 - public :: stdlib_stgsyl - public :: stdlib_stpcon - public :: stdlib_stplqt - public :: stdlib_stplqt2 - public :: stdlib_stpmlqt - public :: stdlib_stpmqrt - public :: stdlib_stpqrt - public :: stdlib_stpqrt2 - public :: stdlib_stprfb - public :: stdlib_stprfs - public :: stdlib_stptri - public :: stdlib_stptrs - public :: stdlib_stpttf - public :: stdlib_stpttr - public :: stdlib_strcon - public :: stdlib_strevc - public :: stdlib_strevc3 - public :: stdlib_strexc - public :: stdlib_strrfs - public :: stdlib_strsen - public :: stdlib_strsna - public :: stdlib_strsyl - public :: stdlib_strti2 - public :: stdlib_strtri - public :: stdlib_strtrs - public :: stdlib_strttf - public :: stdlib_strttp - public :: stdlib_stzrzf - - ! 32-bit real constants + public :: sp,dp,qp,lk,ilp,ilp64 + #:for ik,it,ii in LINALG_INT_KINDS_TYPES + public :: stdlib${ii}$_sbbcsd + public :: stdlib${ii}$_sbdsdc + public :: stdlib${ii}$_sbdsqr + public :: stdlib${ii}$_scsum1 + public :: stdlib${ii}$_sdisna + public :: stdlib${ii}$_sgbbrd + public :: stdlib${ii}$_sgbcon + public :: stdlib${ii}$_sgbequ + public :: stdlib${ii}$_sgbequb + public :: stdlib${ii}$_sgbrfs + public :: stdlib${ii}$_sgbsv + public :: stdlib${ii}$_sgbsvx + public :: stdlib${ii}$_sgbtf2 + public :: stdlib${ii}$_sgbtrf + public :: stdlib${ii}$_sgbtrs + public :: stdlib${ii}$_sgebak + public :: stdlib${ii}$_sgebal + public :: stdlib${ii}$_sgebd2 + public :: stdlib${ii}$_sgebrd + public :: stdlib${ii}$_sgecon + public :: stdlib${ii}$_sgeequ + public :: stdlib${ii}$_sgeequb + public :: stdlib${ii}$_sgees + public :: stdlib${ii}$_sgeesx + public :: stdlib${ii}$_sgeev + public :: stdlib${ii}$_sgeevx + public :: stdlib${ii}$_sgehd2 + public :: stdlib${ii}$_sgehrd + public :: stdlib${ii}$_sgejsv + public :: stdlib${ii}$_sgelq + public :: stdlib${ii}$_sgelq2 + public :: stdlib${ii}$_sgelqf + public :: stdlib${ii}$_sgelqt + public :: stdlib${ii}$_sgelqt3 + public :: stdlib${ii}$_sgels + public :: stdlib${ii}$_sgelsd + public :: stdlib${ii}$_sgelss + public :: stdlib${ii}$_sgelsy + public :: stdlib${ii}$_sgemlq + public :: stdlib${ii}$_sgemlqt + public :: stdlib${ii}$_sgemqr + public :: stdlib${ii}$_sgemqrt + public :: stdlib${ii}$_sgeql2 + public :: stdlib${ii}$_sgeqlf + public :: stdlib${ii}$_sgeqp3 + public :: stdlib${ii}$_sgeqr + public :: stdlib${ii}$_sgeqr2 + public :: stdlib${ii}$_sgeqr2p + public :: stdlib${ii}$_sgeqrf + public :: stdlib${ii}$_sgeqrfp + public :: stdlib${ii}$_sgeqrt + public :: stdlib${ii}$_sgeqrt2 + public :: stdlib${ii}$_sgeqrt3 + public :: stdlib${ii}$_sgerfs + public :: stdlib${ii}$_sgerq2 + public :: stdlib${ii}$_sgerqf + public :: stdlib${ii}$_sgesc2 + public :: stdlib${ii}$_sgesdd + public :: stdlib${ii}$_sgesv + public :: stdlib${ii}$_sgesvd + public :: stdlib${ii}$_sgesvdq + public :: stdlib${ii}$_sgesvj + public :: stdlib${ii}$_sgesvx + public :: stdlib${ii}$_sgetc2 + public :: stdlib${ii}$_sgetf2 + public :: stdlib${ii}$_sgetrf + public :: stdlib${ii}$_sgetrf2 + public :: stdlib${ii}$_sgetri + public :: stdlib${ii}$_sgetrs + public :: stdlib${ii}$_sgetsls + public :: stdlib${ii}$_sgetsqrhrt + public :: stdlib${ii}$_sggbak + public :: stdlib${ii}$_sggbal + public :: stdlib${ii}$_sgges + public :: stdlib${ii}$_sgges3 + public :: stdlib${ii}$_sggesx + public :: stdlib${ii}$_sggev + public :: stdlib${ii}$_sggev3 + public :: stdlib${ii}$_sggevx + public :: stdlib${ii}$_sggglm + public :: stdlib${ii}$_sgghd3 + public :: stdlib${ii}$_sgghrd + public :: stdlib${ii}$_sgglse + public :: stdlib${ii}$_sggqrf + public :: stdlib${ii}$_sggrqf + public :: stdlib${ii}$_sgsvj0 + public :: stdlib${ii}$_sgsvj1 + public :: stdlib${ii}$_sgtcon + public :: stdlib${ii}$_sgtrfs + public :: stdlib${ii}$_sgtsv + public :: stdlib${ii}$_sgtsvx + public :: stdlib${ii}$_sgttrf + public :: stdlib${ii}$_sgttrs + public :: stdlib${ii}$_sgtts2 + public :: stdlib${ii}$_shgeqz + public :: stdlib${ii}$_shsein + public :: stdlib${ii}$_shseqr + public :: stdlib${ii}$_sisnan + public :: stdlib${ii}$_sla_gbamv + public :: stdlib${ii}$_sla_gbrcond + public :: stdlib${ii}$_sla_gbrpvgrw + public :: stdlib${ii}$_sla_geamv + public :: stdlib${ii}$_sla_gercond + public :: stdlib${ii}$_sla_gerpvgrw + public :: stdlib${ii}$_sla_lin_berr + public :: stdlib${ii}$_sla_porcond + public :: stdlib${ii}$_sla_porpvgrw + public :: stdlib${ii}$_sla_syamv + public :: stdlib${ii}$_sla_syrcond + public :: stdlib${ii}$_sla_syrpvgrw + public :: stdlib${ii}$_sla_wwaddw + public :: stdlib${ii}$_slabad + public :: stdlib${ii}$_slabrd + public :: stdlib${ii}$_slacn2 + public :: stdlib${ii}$_slacon + public :: stdlib${ii}$_slacpy + public :: stdlib${ii}$_sladiv + public :: stdlib${ii}$_sladiv1 + public :: stdlib${ii}$_sladiv2 + public :: stdlib${ii}$_slae2 + public :: stdlib${ii}$_slaebz + public :: stdlib${ii}$_slaed0 + public :: stdlib${ii}$_slaed1 + public :: stdlib${ii}$_slaed2 + public :: stdlib${ii}$_slaed3 + public :: stdlib${ii}$_slaed4 + public :: stdlib${ii}$_slaed5 + public :: stdlib${ii}$_slaed6 + public :: stdlib${ii}$_slaed7 + public :: stdlib${ii}$_slaed8 + public :: stdlib${ii}$_slaed9 + public :: stdlib${ii}$_slaeda + public :: stdlib${ii}$_slaein + public :: stdlib${ii}$_slaev2 + public :: stdlib${ii}$_slaexc + public :: stdlib${ii}$_slag2 + public :: stdlib${ii}$_slag2d + public :: stdlib${ii}$_slags2 + public :: stdlib${ii}$_slagtf + public :: stdlib${ii}$_slagtm + public :: stdlib${ii}$_slagts + public :: stdlib${ii}$_slagv2 + public :: stdlib${ii}$_slahqr + public :: stdlib${ii}$_slahr2 + public :: stdlib${ii}$_slaic1 + public :: stdlib${ii}$_slaisnan + public :: stdlib${ii}$_slaln2 + public :: stdlib${ii}$_slals0 + public :: stdlib${ii}$_slalsa + public :: stdlib${ii}$_slalsd + public :: stdlib${ii}$_slamch + public :: stdlib${ii}$_slamc3 + public :: stdlib${ii}$_slamrg + public :: stdlib${ii}$_slamswlq + public :: stdlib${ii}$_slamtsqr + public :: stdlib${ii}$_slaneg + public :: stdlib${ii}$_slangb + public :: stdlib${ii}$_slange + public :: stdlib${ii}$_slangt + public :: stdlib${ii}$_slanhs + public :: stdlib${ii}$_slansb + public :: stdlib${ii}$_slansf + public :: stdlib${ii}$_slansp + public :: stdlib${ii}$_slanst + public :: stdlib${ii}$_slansy + public :: stdlib${ii}$_slantb + public :: stdlib${ii}$_slantp + public :: stdlib${ii}$_slantr + public :: stdlib${ii}$_slanv2 + public :: stdlib${ii}$_slaorhr_col_getrfnp + public :: stdlib${ii}$_slaorhr_col_getrfnp2 + public :: stdlib${ii}$_slapll + public :: stdlib${ii}$_slapmr + public :: stdlib${ii}$_slapmt + public :: stdlib${ii}$_slapy2 + public :: stdlib${ii}$_slapy3 + public :: stdlib${ii}$_slaqgb + public :: stdlib${ii}$_slaqge + public :: stdlib${ii}$_slaqp2 + public :: stdlib${ii}$_slaqps + public :: stdlib${ii}$_slaqr0 + public :: stdlib${ii}$_slaqr1 + public :: stdlib${ii}$_slaqr2 + public :: stdlib${ii}$_slaqr3 + public :: stdlib${ii}$_slaqr4 + public :: stdlib${ii}$_slaqr5 + public :: stdlib${ii}$_slaqsb + public :: stdlib${ii}$_slaqsp + public :: stdlib${ii}$_slaqsy + public :: stdlib${ii}$_slaqtr + public :: stdlib${ii}$_slaqz0 + public :: stdlib${ii}$_slaqz1 + public :: stdlib${ii}$_slaqz2 + public :: stdlib${ii}$_slaqz3 + public :: stdlib${ii}$_slaqz4 + public :: stdlib${ii}$_slar1v + public :: stdlib${ii}$_slar2v + public :: stdlib${ii}$_slarf + public :: stdlib${ii}$_slarfb + public :: stdlib${ii}$_slarfb_gett + public :: stdlib${ii}$_slarfg + public :: stdlib${ii}$_slarfgp + public :: stdlib${ii}$_slarft + public :: stdlib${ii}$_slarfx + public :: stdlib${ii}$_slarfy + public :: stdlib${ii}$_slargv + public :: stdlib${ii}$_slarnv + public :: stdlib${ii}$_slarra + public :: stdlib${ii}$_slarrb + public :: stdlib${ii}$_slarrc + public :: stdlib${ii}$_slarrd + public :: stdlib${ii}$_slarre + public :: stdlib${ii}$_slarrf + public :: stdlib${ii}$_slarrj + public :: stdlib${ii}$_slarrk + public :: stdlib${ii}$_slarrr + public :: stdlib${ii}$_slarrv + public :: stdlib${ii}$_slartg + public :: stdlib${ii}$_slartgp + public :: stdlib${ii}$_slartgs + public :: stdlib${ii}$_slartv + public :: stdlib${ii}$_slaruv + public :: stdlib${ii}$_slarz + public :: stdlib${ii}$_slarzb + public :: stdlib${ii}$_slarzt + public :: stdlib${ii}$_slas2 + public :: stdlib${ii}$_slascl + public :: stdlib${ii}$_slasd0 + public :: stdlib${ii}$_slasd1 + public :: stdlib${ii}$_slasd2 + public :: stdlib${ii}$_slasd3 + public :: stdlib${ii}$_slasd4 + public :: stdlib${ii}$_slasd5 + public :: stdlib${ii}$_slasd6 + public :: stdlib${ii}$_slasd7 + public :: stdlib${ii}$_slasd8 + public :: stdlib${ii}$_slasda + public :: stdlib${ii}$_slasdq + public :: stdlib${ii}$_slasdt + public :: stdlib${ii}$_slaset + public :: stdlib${ii}$_slasq1 + public :: stdlib${ii}$_slasq2 + public :: stdlib${ii}$_slasq3 + public :: stdlib${ii}$_slasq4 + public :: stdlib${ii}$_slasq5 + public :: stdlib${ii}$_slasq6 + public :: stdlib${ii}$_slasr + public :: stdlib${ii}$_slasrt + public :: stdlib${ii}$_slassq + public :: stdlib${ii}$_slasv2 + public :: stdlib${ii}$_slaswlq + public :: stdlib${ii}$_slaswp + public :: stdlib${ii}$_slasy2 + public :: stdlib${ii}$_slasyf + public :: stdlib${ii}$_slasyf_aa + public :: stdlib${ii}$_slasyf_rk + public :: stdlib${ii}$_slasyf_rook + public :: stdlib${ii}$_slatbs + public :: stdlib${ii}$_slatdf + public :: stdlib${ii}$_slatps + public :: stdlib${ii}$_slatrd + public :: stdlib${ii}$_slatrs + public :: stdlib${ii}$_slatrz + public :: stdlib${ii}$_slatsqr + public :: stdlib${ii}$_slauu2 + public :: stdlib${ii}$_slauum + public :: stdlib${ii}$_sopgtr + public :: stdlib${ii}$_sopmtr + public :: stdlib${ii}$_sorbdb + public :: stdlib${ii}$_sorbdb1 + public :: stdlib${ii}$_sorbdb2 + public :: stdlib${ii}$_sorbdb3 + public :: stdlib${ii}$_sorbdb4 + public :: stdlib${ii}$_sorbdb5 + public :: stdlib${ii}$_sorbdb6 + public :: stdlib${ii}$_sorcsd + public :: stdlib${ii}$_sorcsd2by1 + public :: stdlib${ii}$_sorg2l + public :: stdlib${ii}$_sorg2r + public :: stdlib${ii}$_sorgbr + public :: stdlib${ii}$_sorghr + public :: stdlib${ii}$_sorgl2 + public :: stdlib${ii}$_sorglq + public :: stdlib${ii}$_sorgql + public :: stdlib${ii}$_sorgqr + public :: stdlib${ii}$_sorgr2 + public :: stdlib${ii}$_sorgrq + public :: stdlib${ii}$_sorgtr + public :: stdlib${ii}$_sorgtsqr + public :: stdlib${ii}$_sorgtsqr_row + public :: stdlib${ii}$_sorhr_col + public :: stdlib${ii}$_sorm22 + public :: stdlib${ii}$_sorm2l + public :: stdlib${ii}$_sorm2r + public :: stdlib${ii}$_sormbr + public :: stdlib${ii}$_sormhr + public :: stdlib${ii}$_sorml2 + public :: stdlib${ii}$_sormlq + public :: stdlib${ii}$_sormql + public :: stdlib${ii}$_sormqr + public :: stdlib${ii}$_sormr2 + public :: stdlib${ii}$_sormr3 + public :: stdlib${ii}$_sormrq + public :: stdlib${ii}$_sormrz + public :: stdlib${ii}$_sormtr + public :: stdlib${ii}$_spbcon + public :: stdlib${ii}$_spbequ + public :: stdlib${ii}$_spbrfs + public :: stdlib${ii}$_spbstf + public :: stdlib${ii}$_spbsv + public :: stdlib${ii}$_spbsvx + public :: stdlib${ii}$_spbtf2 + public :: stdlib${ii}$_spbtrf + public :: stdlib${ii}$_spbtrs + public :: stdlib${ii}$_spftrf + public :: stdlib${ii}$_spftri + public :: stdlib${ii}$_spftrs + public :: stdlib${ii}$_spocon + public :: stdlib${ii}$_spoequ + public :: stdlib${ii}$_spoequb + public :: stdlib${ii}$_sporfs + public :: stdlib${ii}$_sposv + public :: stdlib${ii}$_sposvx + public :: stdlib${ii}$_spotf2 + public :: stdlib${ii}$_spotrf + public :: stdlib${ii}$_spotrf2 + public :: stdlib${ii}$_spotri + public :: stdlib${ii}$_spotrs + public :: stdlib${ii}$_sppcon + public :: stdlib${ii}$_sppequ + public :: stdlib${ii}$_spprfs + public :: stdlib${ii}$_sppsv + public :: stdlib${ii}$_sppsvx + public :: stdlib${ii}$_spptrf + public :: stdlib${ii}$_spptri + public :: stdlib${ii}$_spptrs + public :: stdlib${ii}$_spstf2 + public :: stdlib${ii}$_spstrf + public :: stdlib${ii}$_sptcon + public :: stdlib${ii}$_spteqr + public :: stdlib${ii}$_sptrfs + public :: stdlib${ii}$_sptsv + public :: stdlib${ii}$_sptsvx + public :: stdlib${ii}$_spttrf + public :: stdlib${ii}$_spttrs + public :: stdlib${ii}$_sptts2 + public :: stdlib${ii}$_srscl + public :: stdlib${ii}$_ssb2st_kernels + public :: stdlib${ii}$_ssbev + public :: stdlib${ii}$_ssbevd + public :: stdlib${ii}$_ssbevx + public :: stdlib${ii}$_ssbgst + public :: stdlib${ii}$_ssbgv + public :: stdlib${ii}$_ssbgvd + public :: stdlib${ii}$_ssbgvx + public :: stdlib${ii}$_ssbtrd + public :: stdlib${ii}$_ssfrk + public :: stdlib${ii}$_sspcon + public :: stdlib${ii}$_sspev + public :: stdlib${ii}$_sspevd + public :: stdlib${ii}$_sspevx + public :: stdlib${ii}$_sspgst + public :: stdlib${ii}$_sspgv + public :: stdlib${ii}$_sspgvd + public :: stdlib${ii}$_sspgvx + public :: stdlib${ii}$_ssprfs + public :: stdlib${ii}$_sspsv + public :: stdlib${ii}$_sspsvx + public :: stdlib${ii}$_ssptrd + public :: stdlib${ii}$_ssptrf + public :: stdlib${ii}$_ssptri + public :: stdlib${ii}$_ssptrs + public :: stdlib${ii}$_sstebz + public :: stdlib${ii}$_sstedc + public :: stdlib${ii}$_sstegr + public :: stdlib${ii}$_sstein + public :: stdlib${ii}$_sstemr + public :: stdlib${ii}$_ssteqr + public :: stdlib${ii}$_ssterf + public :: stdlib${ii}$_sstev + public :: stdlib${ii}$_sstevd + public :: stdlib${ii}$_sstevr + public :: stdlib${ii}$_sstevx + public :: stdlib${ii}$_ssycon + public :: stdlib${ii}$_ssycon_rook + public :: stdlib${ii}$_ssyconv + public :: stdlib${ii}$_ssyconvf + public :: stdlib${ii}$_ssyconvf_rook + public :: stdlib${ii}$_ssyequb + public :: stdlib${ii}$_ssyev + public :: stdlib${ii}$_ssyevd + public :: stdlib${ii}$_ssyevr + public :: stdlib${ii}$_ssyevx + public :: stdlib${ii}$_ssygs2 + public :: stdlib${ii}$_ssygst + public :: stdlib${ii}$_ssygv + public :: stdlib${ii}$_ssygvd + public :: stdlib${ii}$_ssygvx + public :: stdlib${ii}$_ssyrfs + public :: stdlib${ii}$_ssysv + public :: stdlib${ii}$_ssysv_aa + public :: stdlib${ii}$_ssysv_rk + public :: stdlib${ii}$_ssysv_rook + public :: stdlib${ii}$_ssysvx + public :: stdlib${ii}$_ssyswapr + public :: stdlib${ii}$_ssytd2 + public :: stdlib${ii}$_ssytf2 + public :: stdlib${ii}$_ssytf2_rk + public :: stdlib${ii}$_ssytf2_rook + public :: stdlib${ii}$_ssytrd + public :: stdlib${ii}$_ssytrd_sb2st + public :: stdlib${ii}$_ssytrd_sy2sb + public :: stdlib${ii}$_ssytrf + public :: stdlib${ii}$_ssytrf_aa + public :: stdlib${ii}$_ssytrf_rk + public :: stdlib${ii}$_ssytrf_rook + public :: stdlib${ii}$_ssytri + public :: stdlib${ii}$_ssytri_rook + public :: stdlib${ii}$_ssytrs + public :: stdlib${ii}$_ssytrs2 + public :: stdlib${ii}$_ssytrs_3 + public :: stdlib${ii}$_ssytrs_aa + public :: stdlib${ii}$_ssytrs_rook + public :: stdlib${ii}$_stbcon + public :: stdlib${ii}$_stbrfs + public :: stdlib${ii}$_stbtrs + public :: stdlib${ii}$_stfsm + public :: stdlib${ii}$_stftri + public :: stdlib${ii}$_stfttp + public :: stdlib${ii}$_stfttr + public :: stdlib${ii}$_stgevc + public :: stdlib${ii}$_stgex2 + public :: stdlib${ii}$_stgexc + public :: stdlib${ii}$_stgsen + public :: stdlib${ii}$_stgsja + public :: stdlib${ii}$_stgsna + public :: stdlib${ii}$_stgsy2 + public :: stdlib${ii}$_stgsyl + public :: stdlib${ii}$_stpcon + public :: stdlib${ii}$_stplqt + public :: stdlib${ii}$_stplqt2 + public :: stdlib${ii}$_stpmlqt + public :: stdlib${ii}$_stpmqrt + public :: stdlib${ii}$_stpqrt + public :: stdlib${ii}$_stpqrt2 + public :: stdlib${ii}$_stprfb + public :: stdlib${ii}$_stprfs + public :: stdlib${ii}$_stptri + public :: stdlib${ii}$_stptrs + public :: stdlib${ii}$_stpttf + public :: stdlib${ii}$_stpttr + public :: stdlib${ii}$_strcon + public :: stdlib${ii}$_strevc + public :: stdlib${ii}$_strevc3 + public :: stdlib${ii}$_strexc + public :: stdlib${ii}$_strrfs + public :: stdlib${ii}$_strsen + public :: stdlib${ii}$_strsna + public :: stdlib${ii}$_strsyl + public :: stdlib${ii}$_strti2 + public :: stdlib${ii}$_strtri + public :: stdlib${ii}$_strtrs + public :: stdlib${ii}$_strttf + public :: stdlib${ii}$_strttp + public :: stdlib${ii}$_stzrzf + #:endfor + + ! 32_${ik}$-bit real constants real(sp), parameter, private :: negone = -1.00_sp real(sp), parameter, private :: zero = 0.00_sp real(sp), parameter, private :: half = 0.50_sp @@ -485,95 +487,95 @@ module stdlib_linalg_lapack_s real(sp), parameter, private :: eight = 8.00_sp real(sp), parameter, private :: ten = 10.00_sp - ! 32-bit complex constants + ! 32_${ik}$-bit complex constants complex(sp), parameter, private :: czero = ( 0.0_sp,0.0_sp) complex(sp), parameter, private :: chalf = ( 0.5_sp,0.0_sp) complex(sp), parameter, private :: cone = ( 1.0_sp,0.0_sp) complex(sp), parameter, private :: cnegone = (-1.0_sp,0.0_sp) - ! 32-bit scaling constants + ! 32_${ik}$-bit scaling constants integer, parameter, private :: maxexp = maxexponent(zero) integer, parameter, private :: minexp = minexponent(zero) real(sp), parameter, private :: rradix = real(radix(zero),sp) real(sp), parameter, private :: ulp = epsilon(zero) real(sp), parameter, private :: eps = ulp*half - real(sp), parameter, private :: safmin = rradix**max(minexp-1,1-maxexp) + real(sp), parameter, private :: safmin = rradix**max(minexp-1,1_${ik}$-maxexp) real(sp), parameter, private :: safmax = one/safmin real(sp), parameter, private :: smlnum = safmin/ulp real(sp), parameter, private :: bignum = safmax*ulp real(sp), parameter, private :: rtmin = sqrt(smlnum) real(sp), parameter, private :: rtmax = sqrt(bignum) - ! 32-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 + ! 32_${ik}$-bit Blue's scaling constants + ! ssml>=1_${ik}$/s and sbig==1_${ik}$/S with s,S as defined in https://doi.org/10.1145/355769.355771 real(sp), parameter, private :: tsml = rradix**ceiling((minexp-1)*half) - real(sp), parameter, private :: tbig = rradix**floor((maxexp-digits(zero)+1)*half) + real(sp), parameter, private :: tbig = rradix**floor((maxexp-digits(zero)+1_${ik}$)*half) real(sp), parameter, private :: ssml = rradix**(-floor((minexp-digits(zero))*half)) - real(sp), parameter, private :: sbig = rradix**(-ceiling((maxexp+digits(zero)-1)*half)) + real(sp), parameter, private :: sbig = rradix**(-ceiling((maxexp+digits(zero)-1_${ik}$)*half)) contains - - pure real(sp) function stdlib_scsum1( n, cx, incx ) + #:for ik,it,ii in LINALG_INT_KINDS_TYPES + pure real(sp) function stdlib${ii}$_scsum1( n, cx, incx ) !! SCSUM1 takes the sum of the absolute values of a complex !! vector and returns a single precision result. - !! Based on SCASUM from the Level 1 BLAS. + !! Based on SCASUM from the Level 1_${ik}$ 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 + integer(${ik}$), intent(in) :: incx, n ! Array Arguments complex(sp), intent(in) :: cx(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, nincx + integer(${ik}$) :: i, nincx real(sp) :: stemp ! Intrinsic Functions intrinsic :: abs ! Executable Statements - stdlib_scsum1 = zero + stdlib${ii}$_scsum1 = zero stemp = zero if( n<=0 )return if( incx==1 )go to 20 - ! code for increment not equal to 1 + ! code for increment not equal to 1_${ik}$ nincx = n*incx do i = 1, nincx, incx ! next line modified. stemp = stemp + abs( cx( i ) ) end do - stdlib_scsum1 = stemp + stdlib${ii}$_scsum1 = stemp return - ! code for increment equal to 1 + ! code for increment equal to 1_${ik}$ 20 continue do i = 1, n ! next line modified. stemp = stemp + abs( cx( i ) ) end do - stdlib_scsum1 = stemp + stdlib${ii}$_scsum1 = stemp return - end function stdlib_scsum1 + end function stdlib${ii}$_scsum1 - pure subroutine stdlib_sgbtf2( m, n, kl, ku, ab, ldab, ipiv, info ) + pure subroutine stdlib${ii}$_sgbtf2( m, n, kl, ku, ab, ldab, ipiv, info ) !! SGBTF2 computes an LU factorization of a real m-by-n band matrix A !! using partial pivoting with row interchanges. - !! This is the unblocked version of the algorithm, calling Level 2 BLAS. + !! This is the unblocked version of the algorithm, calling Level 2_${ik}$ BLAS. ! -- lapack computational routine -- ! -- lapack is a software package provided by univ. of tennessee, -- ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: kl, ku, ldab, m, n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: kl, ku, ldab, m, n ! Array Arguments - integer(ilp), intent(out) :: ipiv(*) + integer(${ik}$), intent(out) :: ipiv(*) real(sp), intent(inout) :: ab(ldab,*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, j, jp, ju, km, kv + integer(${ik}$) :: i, j, jp, ju, km, kv ! Intrinsic Functions intrinsic :: max,min ! Executable Statements @@ -581,20 +583,20 @@ module stdlib_linalg_lapack_s ! fill-in. kv = ku + kl ! test the input parameters. - info = 0 - if( m<0 ) then - info = -1 - else if( n<0 ) then - info = -2 - else if( kl<0 ) then - info = -3 - else if( ku<0 ) then - info = -4 + info = 0_${ik}$ + if( m<0_${ik}$ ) then + info = -1_${ik}$ + else if( n<0_${ik}$ ) then + info = -2_${ik}$ + else if( kl<0_${ik}$ ) then + info = -3_${ik}$ + else if( ku<0_${ik}$ ) then + info = -4_${ik}$ else if( ldab0 ) then + if( jp/=1_${ik}$ )call stdlib${ii}$_sswap( ju-j+1, ab( kv+jp, j ), ldab-1,ab( kv+1, j ), ldab-& + 1_${ik}$ ) + if( km>0_${ik}$ ) then ! compute multipliers. - call stdlib_sscal( km, one / ab( kv+1, j ), ab( kv+2, j ), 1 ) + call stdlib${ii}$_sscal( km, one / ab( kv+1, j ), ab( kv+2, j ), 1_${ik}$ ) ! update trailing submatrix within the band. - if( ju>j )call stdlib_sger( km, ju-j, -one, ab( kv+2, j ), 1,ab( kv, j+1 ), & + if( ju>j )call stdlib${ii}$_sger( km, ju-j, -one, ab( kv+2, j ), 1_${ik}$,ab( kv, j+1 ), & ldab-1, ab( kv+1, j+1 ),ldab-1 ) end if else ! if pivot is zero, set info to the index of the pivot ! unless a zero pivot has already been found. - if( info==0 )info = j + if( info==0_${ik}$ )info = j end if end do loop_40 return - end subroutine stdlib_sgbtf2 + end subroutine stdlib${ii}$_sgbtf2 - pure subroutine stdlib_sgbtrs( trans, n, kl, ku, nrhs, ab, ldab, ipiv, b, ldb,info ) + pure subroutine stdlib${ii}$_sgbtrs( trans, n, kl, ku, nrhs, ab, ldab, ipiv, b, ldb,info ) !! SGBTRS 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 @@ -653,91 +655,91 @@ module stdlib_linalg_lapack_s ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: trans - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: kl, ku, ldab, ldb, n, nrhs + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: kl, ku, ldab, ldb, n, nrhs ! Array Arguments - integer(ilp), intent(in) :: ipiv(*) + integer(${ik}$), intent(in) :: ipiv(*) real(sp), intent(in) :: ab(ldab,*) real(sp), intent(inout) :: b(ldb,*) ! ===================================================================== ! Local Scalars logical(lk) :: lnoti, notran - integer(ilp) :: i, j, kd, l, lm + integer(${ik}$) :: i, j, kd, l, lm ! Intrinsic Functions intrinsic :: max,min ! Executable Statements ! test the input parameters. - info = 0 + info = 0_${ik}$ notran = stdlib_lsame( trans, 'N' ) if( .not.notran .and. .not.stdlib_lsame( trans, 'T' ) .and. .not.stdlib_lsame( trans, & 'C' ) ) then - info = -1 - else if( n<0 ) then - info = -2 - else if( kl<0 ) then - info = -3 - else if( ku<0 ) then - info = -4 - else if( nrhs<0 ) then - info = -5 - else if( ldab<( 2*kl+ku+1 ) ) then - info = -7 - else if( ldb0 + kd = ku + kl + 1_${ik}$ + lnoti = kl>0_${ik}$ if( notran ) then ! solve a*x = b. ! solve l*x = b, overwriting b with x. ! l is represented as a product of permutations and unit lower - ! triangular matrices l = p(1) * l(1) * ... * p(n-1) * l(n-1), + ! triangular matrices l = p(1_${ik}$) * l(1_${ik}$) * ... * p(n-1) * l(n-1), ! where each transformation l(i) is a rank-one modification of ! the identity matrix. if( lnoti ) then do j = 1, n - 1 lm = min( kl, n-j ) l = ipiv( j ) - if( l/=j )call stdlib_sswap( nrhs, b( l, 1 ), ldb, b( j, 1 ), ldb ) - call stdlib_sger( lm, nrhs, -one, ab( kd+1, j ), 1, b( j, 1 ),ldb, b( j+1, 1 )& + if( l/=j )call stdlib${ii}$_sswap( nrhs, b( l, 1_${ik}$ ), ldb, b( j, 1_${ik}$ ), ldb ) + call stdlib${ii}$_sger( lm, nrhs, -one, ab( kd+1, j ), 1_${ik}$, b( j, 1_${ik}$ ),ldb, b( j+1, 1_${ik}$ )& , ldb ) end do end if do i = 1, nrhs ! solve u*x = b, overwriting b with x. - call stdlib_stbsv( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', n, kl+ku,ab, ldab, b( 1, & - i ), 1 ) + call stdlib${ii}$_stbsv( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', n, kl+ku,ab, ldab, b( 1_${ik}$, & + i ), 1_${ik}$ ) end do else ! solve a**t*x = b. do i = 1, nrhs ! solve u**t*x = b, overwriting b with x. - call stdlib_stbsv( 'UPPER', 'TRANSPOSE', 'NON-UNIT', n, kl+ku, ab,ldab, b( 1, i )& - , 1 ) + call stdlib${ii}$_stbsv( 'UPPER', 'TRANSPOSE', 'NON-UNIT', n, kl+ku, ab,ldab, b( 1_${ik}$, i )& + , 1_${ik}$ ) 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_sgemv( 'TRANSPOSE', lm, nrhs, -one, b( j+1, 1 ),ldb, ab( kd+1, j )& - , 1, one, b( j, 1 ), ldb ) + call stdlib${ii}$_sgemv( 'TRANSPOSE', lm, nrhs, -one, b( j+1, 1_${ik}$ ),ldb, ab( kd+1, j )& + , 1_${ik}$, one, b( j, 1_${ik}$ ), ldb ) l = ipiv( j ) - if( l/=j )call stdlib_sswap( nrhs, b( l, 1 ), ldb, b( j, 1 ), ldb ) + if( l/=j )call stdlib${ii}$_sswap( nrhs, b( l, 1_${ik}$ ), ldb, b( j, 1_${ik}$ ), ldb ) end do end if end if return - end subroutine stdlib_sgbtrs + end subroutine stdlib${ii}$_sgbtrs - pure subroutine stdlib_sgebak( job, side, n, ilo, ihi, scale, m, v, ldv,info ) + pure subroutine stdlib${ii}$_sgebak( job, side, n, ilo, ihi, scale, m, v, ldv,info ) !! SGEBAK forms the right or left eigenvectors of a real general matrix !! by backward transformation on the computed eigenvectors of the !! balanced matrix output by SGEBAL. @@ -746,8 +748,8 @@ module stdlib_linalg_lapack_s ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: job, side - integer(ilp), intent(in) :: ihi, ilo, ldv, m, n - integer(ilp), intent(out) :: info + integer(${ik}$), intent(in) :: ihi, ilo, ldv, m, n + integer(${ik}$), intent(out) :: info ! Array Arguments real(sp), intent(inout) :: v(ldv,*) real(sp), intent(in) :: scale(*) @@ -755,7 +757,7 @@ module stdlib_linalg_lapack_s ! Local Scalars logical(lk) :: leftv, rightv - integer(ilp) :: i, ii, k + integer(${ik}$) :: i, ii, k real(sp) :: s ! Intrinsic Functions intrinsic :: max,min @@ -763,25 +765,25 @@ module stdlib_linalg_lapack_s ! decode and test the input parameters rightv = stdlib_lsame( side, 'R' ) leftv = stdlib_lsame( side, 'L' ) - info = 0 + info = 0_${ik}$ if( .not.stdlib_lsame( job, 'N' ) .and. .not.stdlib_lsame( job, 'P' ) & .and..not.stdlib_lsame( job, 'S' ) .and. .not.stdlib_lsame( job, 'B' ) ) then - info = -1 + info = -1_${ik}$ else if( .not.rightv .and. .not.leftv ) then - info = -2 - else if( n<0 ) then - info = -3 - else if( ilo<1 .or. ilo>max( 1, n ) ) then - info = -4 + info = -2_${ik}$ + else if( n<0_${ik}$ ) then + info = -3_${ik}$ + else if( ilo<1_${ik}$ .or. ilo>max( 1_${ik}$, n ) ) then + info = -4_${ik}$ else if( ihin ) then - info = -5 - else if( m<0 ) then - info = -7 - else if( ldv0 .and. ( ihimax( 1, n ) ) )then - info = -5 - else if( n==0 .and. ilo==1 .and. ihi/=0 ) then - info = -5 - else if( m<0 ) then - info = -8 - else if( ldv0_${ik}$ .and. ( ihimax( 1_${ik}$, n ) ) )then + info = -5_${ik}$ + else if( n==0_${ik}$ .and. ilo==1_${ik}$ .and. ihi/=0_${ik}$ ) then + info = -5_${ik}$ + else if( m<0_${ik}$ ) then + info = -8_${ik}$ + else if( ldv=abs( dl( i ) ) ) then ! no row interchange required if( d( i )/=zero ) then fact = dl( i ) / d( i ) d( i+1 ) = d( i+1 ) - fact*du( i ) - b( i+1, 1 ) = b( i+1, 1 ) - fact*b( i, 1 ) + b( i+1, 1_${ik}$ ) = b( i+1, 1_${ik}$ ) - fact*b( i, 1_${ik}$ ) else info = i return @@ -1005,18 +1007,18 @@ module stdlib_linalg_lapack_s dl( i ) = du( i+1 ) du( i+1 ) = -fact*dl( i ) du( i ) = temp - temp = b( i, 1 ) - b( i, 1 ) = b( i+1, 1 ) - b( i+1, 1 ) = temp - fact*b( i+1, 1 ) + temp = b( i, 1_${ik}$ ) + b( i, 1_${ik}$ ) = b( i+1, 1_${ik}$ ) + b( i+1, 1_${ik}$ ) = temp - fact*b( i+1, 1_${ik}$ ) end if end do loop_10 - if( n>1 ) then - i = n - 1 + if( n>1_${ik}$ ) then + i = n - 1_${ik}$ if( abs( d( i ) )>=abs( dl( i ) ) ) then if( d( i )/=zero ) then fact = dl( i ) / d( i ) d( i+1 ) = d( i+1 ) - fact*du( i ) - b( i+1, 1 ) = b( i+1, 1 ) - fact*b( i, 1 ) + b( i+1, 1_${ik}$ ) = b( i+1, 1_${ik}$ ) - fact*b( i, 1_${ik}$ ) else info = i return @@ -1027,9 +1029,9 @@ module stdlib_linalg_lapack_s temp = d( i+1 ) d( i+1 ) = du( i ) - fact*temp du( i ) = temp - temp = b( i, 1 ) - b( i, 1 ) = b( i+1, 1 ) - b( i+1, 1 ) = temp - fact*b( i+1, 1 ) + temp = b( i, 1_${ik}$ ) + b( i, 1_${ik}$ ) = b( i+1, 1_${ik}$ ) + b( i+1, 1_${ik}$ ) = temp - fact*b( i+1, 1_${ik}$ ) end if end if if( d( n )==zero ) then @@ -1067,8 +1069,8 @@ module stdlib_linalg_lapack_s end do end if end do loop_40 - if( n>1 ) then - i = n - 1 + if( n>1_${ik}$ ) then + i = n - 1_${ik}$ if( abs( d( i ) )>=abs( dl( i ) ) ) then if( d( i )/=zero ) then fact = dl( i ) / d( i ) @@ -1099,23 +1101,23 @@ module stdlib_linalg_lapack_s end if end if ! back solve with the matrix u from the factorization. - if( nrhs<=2 ) then - j = 1 + if( nrhs<=2_${ik}$ ) then + j = 1_${ik}$ 70 continue b( n, j ) = b( n, j ) / d( n ) - if( n>1 )b( n-1, j ) = ( b( n-1, j )-du( n-1 )*b( n, j ) ) / d( n-1 ) + if( n>1_${ik}$ )b( n-1, j ) = ( b( n-1, j )-du( n-1 )*b( n, j ) ) / d( n-1 ) do i = n - 2, 1, -1 b( i, j ) = ( b( i, j )-du( i )*b( i+1, j )-dl( i )*b( i+2, j ) ) / d( i ) end do if( j1 )b( n-1, j ) = ( b( n-1, j )-du( n-1 )*b( n, j ) ) /d( n-1 ) + if( n>1_${ik}$ )b( n-1, j ) = ( b( n-1, j )-du( n-1 )*b( n, j ) ) /d( n-1 ) do i = n - 2, 1, -1 b( i, j ) = ( b( i, j )-du( i )*b( i+1, j )-dl( i )*b( i+2, j ) ) / d( i ) @@ -1123,10 +1125,10 @@ module stdlib_linalg_lapack_s end do end if return - end subroutine stdlib_sgtsv + end subroutine stdlib${ii}$_sgtsv - pure subroutine stdlib_sgttrf( n, dl, d, du, du2, ipiv, info ) + pure subroutine stdlib${ii}$_sgttrf( n, dl, d, du, du2, ipiv, info ) !! SGTTRF computes an LU factorization of a real tridiagonal matrix A !! using elimination with partial pivoting and row interchanges. !! The factorization has the form @@ -1138,29 +1140,29 @@ module stdlib_linalg_lapack_s ! -- 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) :: n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: n ! Array Arguments - integer(ilp), intent(out) :: ipiv(*) + integer(${ik}$), intent(out) :: ipiv(*) real(sp), intent(inout) :: d(*), dl(*), du(*) real(sp), intent(out) :: du2(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i + integer(${ik}$) :: i real(sp) :: fact, temp ! Intrinsic Functions intrinsic :: abs ! Executable Statements - info = 0 - if( n<0 ) then - info = -1 - call stdlib_xerbla( 'SGTTRF', -info ) + info = 0_${ik}$ + if( n<0_${ik}$ ) then + info = -1_${ik}$ + call stdlib${ii}$_xerbla( 'SGTTRF', -info ) return end if ! quick return if possible if( n==0 )return - ! initialize ipiv(i) = i and du2(i) = 0 + ! initialize ipiv(i) = i and du2(i) = 0_${ik}$ do i = 1, n ipiv( i ) = i end do @@ -1185,11 +1187,11 @@ module stdlib_linalg_lapack_s d( i+1 ) = temp - fact*d( i+1 ) du2( i ) = du( i+1 ) du( i+1 ) = -fact*du( i+1 ) - ipiv( i ) = i + 1 + ipiv( i ) = i + 1_${ik}$ end if end do - if( n>1 ) then - i = n - 1 + if( n>1_${ik}$ ) then + i = n - 1_${ik}$ if( abs( d( i ) )>=abs( dl( i ) ) ) then if( d( i )/=zero ) then fact = dl( i ) / d( i ) @@ -1203,7 +1205,7 @@ module stdlib_linalg_lapack_s temp = du( i ) du( i ) = d( i+1 ) d( i+1 ) = temp - fact*d( i+1 ) - ipiv( i ) = i + 1 + ipiv( i ) = i + 1_${ik}$ end if end if ! check for a zero on the diagonal of u. @@ -1215,10 +1217,10 @@ module stdlib_linalg_lapack_s end do 50 continue return - end subroutine stdlib_sgttrf + end subroutine stdlib${ii}$_sgttrf - pure subroutine stdlib_sgtts2( itrans, n, nrhs, dl, d, du, du2, ipiv, b, ldb ) + pure subroutine stdlib${ii}$_sgtts2( itrans, n, nrhs, dl, d, du, du2, ipiv, b, ldb ) !! SGTTS2 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 @@ -1227,23 +1229,23 @@ module stdlib_linalg_lapack_s ! -- 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) :: itrans, ldb, n, nrhs + integer(${ik}$), intent(in) :: itrans, ldb, n, nrhs ! Array Arguments - integer(ilp), intent(in) :: ipiv(*) + integer(${ik}$), intent(in) :: ipiv(*) real(sp), intent(inout) :: b(ldb,*) real(sp), intent(in) :: d(*), dl(*), du(*), du2(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, ip, j + integer(${ik}$) :: i, ip, j real(sp) :: temp ! Executable Statements ! quick return if possible if( n==0 .or. nrhs==0 )return - if( itrans==0 ) then + if( itrans==0_${ik}$ ) then ! solve a*x = b using the lu factorization of a, ! overwriting each right hand side vector with its solution. - if( nrhs<=1 ) then - j = 1 + if( nrhs<=1_${ik}$ ) then + j = 1_${ik}$ 10 continue ! solve l*x = b. do i = 1, n - 1 @@ -1254,13 +1256,13 @@ module stdlib_linalg_lapack_s end do ! solve u*x = b. b( n, j ) = b( n, j ) / d( n ) - if( n>1 )b( n-1, j ) = ( b( n-1, j )-du( n-1 )*b( n, j ) ) /d( n-1 ) + if( n>1_${ik}$ )b( n-1, j ) = ( b( n-1, j )-du( n-1 )*b( n, j ) ) /d( n-1 ) do i = n - 2, 1, -1 b( i, j ) = ( b( i, j )-du( i )*b( i+1, j )-du2( i )*b( i+2, j ) ) / d( i ) end do if( j1 )b( n-1, j ) = ( b( n-1, j )-du( n-1 )*b( n, j ) ) /d( n-1 ) + if( n>1_${ik}$ )b( n-1, j ) = ( b( n-1, j )-du( n-1 )*b( n, j ) ) /d( n-1 ) do i = n - 2, 1, -1 b( i, j ) = ( b( i, j )-du( i )*b( i+1, j )-du2( i )*b( i+2, j ) ) / d( i ) @@ -1286,12 +1288,12 @@ module stdlib_linalg_lapack_s end if else ! solve a**t * x = b. - if( nrhs<=1 ) then + if( nrhs<=1_${ik}$ ) then ! solve u**t*x = b. - j = 1 + j = 1_${ik}$ 70 continue - b( 1, j ) = b( 1, j ) / d( 1 ) - if( n>1 )b( 2, j ) = ( b( 2, j )-du( 1 )*b( 1, j ) ) / d( 2 ) + b( 1_${ik}$, j ) = b( 1_${ik}$, j ) / d( 1_${ik}$ ) + if( n>1_${ik}$ )b( 2_${ik}$, j ) = ( b( 2_${ik}$, j )-du( 1_${ik}$ )*b( 1_${ik}$, j ) ) / d( 2_${ik}$ ) do i = 3, n b( i, j ) = ( b( i, j )-du( i-1 )*b( i-1, j )-du2( i-2 )*b( i-2, j ) ) / d( i & ) @@ -1304,14 +1306,14 @@ module stdlib_linalg_lapack_s b( ip, j ) = temp end do if( j1 )b( 2, j ) = ( b( 2, j )-du( 1 )*b( 1, j ) ) / d( 2 ) + b( 1_${ik}$, j ) = b( 1_${ik}$, j ) / d( 1_${ik}$ ) + if( n>1_${ik}$ )b( 2_${ik}$, j ) = ( b( 2_${ik}$, j )-du( 1_${ik}$ )*b( 1_${ik}$, j ) ) / d( 2_${ik}$ ) do i = 3, n b( i, j ) = ( b( i, j )-du( i-1 )*b( i-1, j )-du2( i-2 )*b( i-2, j ) ) / d(& i ) @@ -1328,13 +1330,13 @@ module stdlib_linalg_lapack_s end do end if end if - end subroutine stdlib_sgtts2 + end subroutine stdlib${ii}$_sgtts2 - pure real(sp) function stdlib_sla_gbrpvgrw( n, kl, ku, ncols, ab, ldab, afb,ldafb ) + pure real(sp) function stdlib${ii}$_sla_gbrpvgrw( n, kl, ku, ncols, ab, ldab, afb,ldafb ) !! SLA_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 + !! much less than 1_${ik}$, the stability of the LU factorization of the !! (equilibrated) matrix A could be poor. This also means that the !! solution X, estimated condition numbers, and error bounds could be !! unreliable. @@ -1342,18 +1344,18 @@ module stdlib_linalg_lapack_s ! -- 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) :: n, kl, ku, ncols, ldab, ldafb + integer(${ik}$), intent(in) :: n, kl, ku, ncols, ldab, ldafb ! Array Arguments real(sp), intent(in) :: ab(ldab,*), afb(ldafb,*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, j, kd + integer(${ik}$) :: i, j, kd real(sp) :: amax, umax, rpvgrw ! Intrinsic Functions intrinsic :: abs,max,min ! Executable Statements rpvgrw = one - kd = ku + 1 + kd = ku + 1_${ik}$ do j = 1, ncols amax = zero umax = zero @@ -1367,14 +1369,14 @@ module stdlib_linalg_lapack_s rpvgrw = min( amax / umax, rpvgrw ) end if end do - stdlib_sla_gbrpvgrw = rpvgrw - end function stdlib_sla_gbrpvgrw + stdlib${ii}$_sla_gbrpvgrw = rpvgrw + end function stdlib${ii}$_sla_gbrpvgrw - pure real(sp) function stdlib_sla_gerpvgrw( n, ncols, a, lda, af, ldaf ) + pure real(sp) function stdlib${ii}$_sla_gerpvgrw( n, ncols, a, lda, af, ldaf ) !! SLA_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 + !! much less than 1_${ik}$, the stability of the LU factorization of the !! (equilibrated) matrix A could be poor. This also means that the !! solution X, estimated condition numbers, and error bounds could be !! unreliable. @@ -1382,12 +1384,12 @@ module stdlib_linalg_lapack_s ! -- 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) :: n, ncols, lda, ldaf + integer(${ik}$), intent(in) :: n, ncols, lda, ldaf ! Array Arguments real(sp), intent(in) :: a(lda,*), af(ldaf,*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, j + integer(${ik}$) :: i, j real(sp) :: amax, umax, rpvgrw ! Intrinsic Functions intrinsic :: abs,max,min @@ -1406,11 +1408,11 @@ module stdlib_linalg_lapack_s rpvgrw = min( amax / umax, rpvgrw ) end if end do - stdlib_sla_gerpvgrw = rpvgrw - end function stdlib_sla_gerpvgrw + stdlib${ii}$_sla_gerpvgrw = rpvgrw + end function stdlib${ii}$_sla_gerpvgrw - pure subroutine stdlib_sla_wwaddw( n, x, y, w ) + pure subroutine stdlib${ii}$_sla_wwaddw( n, x, y, w ) !! SLA_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. @@ -1418,14 +1420,14 @@ module stdlib_linalg_lapack_s ! -- 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) :: n + integer(${ik}$), intent(in) :: n ! Array Arguments real(sp), intent(inout) :: x(*), y(*) real(sp), intent(in) :: w(*) ! ===================================================================== ! Local Scalars real(sp) :: s - integer(ilp) :: i + integer(${ik}$) :: i ! Executable Statements do 10 i = 1, n s = x(i) + w(i) @@ -1434,10 +1436,10 @@ module stdlib_linalg_lapack_s x(i) = s 10 continue return - end subroutine stdlib_sla_wwaddw + end subroutine stdlib${ii}$_sla_wwaddw - pure subroutine stdlib_slabad( small, large ) + pure subroutine stdlib${ii}$_slabad( small, large ) !! SLABAD takes as input the values computed by SLAMCH 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 @@ -1462,92 +1464,92 @@ module stdlib_linalg_lapack_s large = sqrt( large ) end if return - end subroutine stdlib_slabad + end subroutine stdlib${ii}$_slabad - pure subroutine stdlib_slacn2( n, v, x, isgn, est, kase, isave ) - !! SLACN2 estimates the 1-norm of a square, real matrix A. + pure subroutine stdlib${ii}$_slacn2( n, v, x, isgn, est, kase, isave ) + !! SLACN2 estimates the 1_${ik}$-norm of a square, real matrix A. !! Reverse communication is used for evaluating matrix-vector products. ! -- 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(inout) :: kase - integer(ilp), intent(in) :: n + integer(${ik}$), intent(inout) :: kase + integer(${ik}$), intent(in) :: n real(sp), intent(inout) :: est ! Array Arguments - integer(ilp), intent(out) :: isgn(*) - integer(ilp), intent(inout) :: isave(3) + integer(${ik}$), intent(out) :: isgn(*) + integer(${ik}$), intent(inout) :: isave(3_${ik}$) real(sp), intent(out) :: v(*) real(sp), intent(inout) :: x(*) ! ===================================================================== ! Parameters - integer(ilp), parameter :: itmax = 5 + integer(${ik}$), parameter :: itmax = 5_${ik}$ ! Local Scalars - integer(ilp) :: i, jlast + integer(${ik}$) :: i, jlast real(sp) :: altsgn, estold, temp, xs ! Intrinsic Functions intrinsic :: abs,nint,real ! Executable Statements - if( kase==0 ) then + if( kase==0_${ik}$ ) then do i = 1, n x( i ) = one / real( n,KIND=sp) end do - kase = 1 - isave( 1 ) = 1 + kase = 1_${ik}$ + isave( 1_${ik}$ ) = 1_${ik}$ return end if go to ( 20, 40, 70, 110, 140 )isave( 1 ) - ! ................ entry (isave( 1 ) = 1) + ! ................ entry (isave( 1_${ik}$ ) = 1_${ik}$) ! first iteration. x has been overwritten by a*x. 20 continue - if( n==1 ) then - v( 1 ) = x( 1 ) - est = abs( v( 1 ) ) + if( n==1_${ik}$ ) then + v( 1_${ik}$ ) = x( 1_${ik}$ ) + est = abs( v( 1_${ik}$ ) ) ! ... quit go to 150 end if - est = stdlib_sasum( n, x, 1 ) + est = stdlib${ii}$_sasum( n, x, 1_${ik}$ ) do i = 1, n if( x(i)>=zero ) then x(i) = one else x(i) = -one end if - isgn( i ) = nint( x( i ),KIND=ilp) + isgn( i ) = nint( x( i ),KIND=${ik}$) end do - kase = 2 - isave( 1 ) = 2 + kase = 2_${ik}$ + isave( 1_${ik}$ ) = 2_${ik}$ return - ! ................ entry (isave( 1 ) = 2) + ! ................ entry (isave( 1_${ik}$ ) = 2_${ik}$) ! first iteration. x has been overwritten by transpose(a)*x. 40 continue - isave( 2 ) = stdlib_isamax( n, x, 1 ) - isave( 3 ) = 2 - ! main loop - iterations 2,3,...,itmax. + isave( 2_${ik}$ ) = stdlib${ii}$_isamax( n, x, 1_${ik}$ ) + isave( 3_${ik}$ ) = 2_${ik}$ + ! main loop - iterations 2_${ik}$,3_${ik}$,...,itmax. 50 continue do i = 1, n x( i ) = zero end do - x( isave( 2 ) ) = one - kase = 1 - isave( 1 ) = 3 + x( isave( 2_${ik}$ ) ) = one + kase = 1_${ik}$ + isave( 1_${ik}$ ) = 3_${ik}$ return - ! ................ entry (isave( 1 ) = 3) + ! ................ entry (isave( 1_${ik}$ ) = 3_${ik}$) ! x has been overwritten by a*x. 70 continue - call stdlib_scopy( n, x, 1, v, 1 ) + call stdlib${ii}$_scopy( n, x, 1_${ik}$, v, 1_${ik}$ ) estold = est - est = stdlib_sasum( n, v, 1 ) + est = stdlib${ii}$_sasum( n, v, 1_${ik}$ ) do i = 1, n if( x(i)>=zero ) then xs = one else xs = -one end if - if( nint( xs,KIND=ilp)/=isgn( i ) )go to 90 + if( nint( xs,KIND=${ik}$)/=isgn( i ) )go to 90 end do ! repeated sign vector detected, hence algorithm has converged. go to 120 @@ -1560,18 +1562,18 @@ module stdlib_linalg_lapack_s else x(i) = -one end if - isgn( i ) = nint( x( i ),KIND=ilp) + isgn( i ) = nint( x( i ),KIND=${ik}$) end do - kase = 2 - isave( 1 ) = 4 + kase = 2_${ik}$ + isave( 1_${ik}$ ) = 4_${ik}$ return - ! ................ entry (isave( 1 ) = 4) + ! ................ entry (isave( 1_${ik}$ ) = 4_${ik}$) ! x has been overwritten by transpose(a)*x. 110 continue - jlast = isave( 2 ) - isave( 2 ) = stdlib_isamax( n, x, 1 ) - if( ( x( jlast )/=abs( x( isave( 2 ) ) ) ) .and.( isave( 3 )est ) then - call stdlib_scopy( n, x, 1, v, 1 ) + call stdlib${ii}$_scopy( n, x, 1_${ik}$, v, 1_${ik}$ ) est = temp end if 150 continue - kase = 0 + kase = 0_${ik}$ return - end subroutine stdlib_slacn2 + end subroutine stdlib${ii}$_slacn2 - subroutine stdlib_slacon( n, v, x, isgn, est, kase ) - !! SLACON estimates the 1-norm of a square, real matrix A. + subroutine stdlib${ii}$_slacon( n, v, x, isgn, est, kase ) + !! SLACON estimates the 1_${ik}$-norm of a square, real matrix A. !! Reverse communication is used for evaluating matrix-vector products. ! -- 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(inout) :: kase - integer(ilp), intent(in) :: n + integer(${ik}$), intent(inout) :: kase + integer(${ik}$), intent(in) :: n real(sp), intent(inout) :: est ! Array Arguments - integer(ilp), intent(out) :: isgn(*) + integer(${ik}$), intent(out) :: isgn(*) real(sp), intent(out) :: v(*) real(sp), intent(inout) :: x(*) ! ===================================================================== ! Parameters - integer(ilp), parameter :: itmax = 5 + integer(${ik}$), parameter :: itmax = 5_${ik}$ ! Local Scalars - integer(ilp) :: i, iter, j, jlast, jump + integer(${ik}$) :: i, iter, j, jlast, jump real(sp) :: altsgn, estold, temp ! Intrinsic Functions intrinsic :: abs,nint,real,sign ! Save Statement save ! Executable Statements - if( kase==0 ) then + if( kase==0_${ik}$ ) then do i = 1, n x( i ) = one / real( n,KIND=sp) end do - kase = 1 - jump = 1 + kase = 1_${ik}$ + jump = 1_${ik}$ return end if go to ( 20, 40, 70, 110, 140 )jump - ! ................ entry (jump = 1) + ! ................ entry (jump = 1_${ik}$) ! first iteration. x has been overwritten by a*x. 20 continue - if( n==1 ) then - v( 1 ) = x( 1 ) - est = abs( v( 1 ) ) + if( n==1_${ik}$ ) then + v( 1_${ik}$ ) = x( 1_${ik}$ ) + est = abs( v( 1_${ik}$ ) ) ! ... quit go to 150 end if - est = stdlib_sasum( n, x, 1 ) + est = stdlib${ii}$_sasum( n, x, 1_${ik}$ ) do i = 1, n x( i ) = sign( one, x( i ) ) - isgn( i ) = nint( x( i ),KIND=ilp) + isgn( i ) = nint( x( i ),KIND=${ik}$) end do - kase = 2 - jump = 2 + kase = 2_${ik}$ + jump = 2_${ik}$ return - ! ................ entry (jump = 2) + ! ................ entry (jump = 2_${ik}$) ! first iteration. x has been overwritten by transpose(a)*x. 40 continue - j = stdlib_isamax( n, x, 1 ) - iter = 2 - ! main loop - iterations 2,3,...,itmax. + j = stdlib${ii}$_isamax( n, x, 1_${ik}$ ) + iter = 2_${ik}$ + ! main loop - iterations 2_${ik}$,3_${ik}$,...,itmax. 50 continue do i = 1, n x( i ) = zero end do x( j ) = one - kase = 1 - jump = 3 + kase = 1_${ik}$ + jump = 3_${ik}$ return - ! ................ entry (jump = 3) + ! ................ entry (jump = 3_${ik}$) ! x has been overwritten by a*x. 70 continue - call stdlib_scopy( n, x, 1, v, 1 ) + call stdlib${ii}$_scopy( n, x, 1_${ik}$, v, 1_${ik}$ ) estold = est - est = stdlib_sasum( n, v, 1 ) + est = stdlib${ii}$_sasum( n, v, 1_${ik}$ ) do i = 1, n - if( nint( sign( one, x( i ) ),KIND=ilp)/=isgn( i ) )go to 90 + if( nint( sign( one, x( i ) ),KIND=${ik}$)/=isgn( i ) )go to 90 end do ! repeated sign vector detected, hence algorithm has converged. go to 120 @@ -1681,18 +1683,18 @@ module stdlib_linalg_lapack_s if( est<=estold )go to 120 do i = 1, n x( i ) = sign( one, x( i ) ) - isgn( i ) = nint( x( i ),KIND=ilp) + isgn( i ) = nint( x( i ),KIND=${ik}$) end do - kase = 2 - jump = 4 + kase = 2_${ik}$ + jump = 4_${ik}$ return - ! ................ entry (jump = 4) + ! ................ entry (jump = 4_${ik}$) ! x has been overwritten by transpose(a)*x. 110 continue jlast = j - j = stdlib_isamax( n, x, 1 ) + j = stdlib${ii}$_isamax( n, x, 1_${ik}$ ) if( ( x( jlast )/=abs( x( j ) ) ) .and. ( iterest ) then - call stdlib_scopy( n, x, 1, v, 1 ) + call stdlib${ii}$_scopy( n, x, 1_${ik}$, v, 1_${ik}$ ) est = temp end if 150 continue - kase = 0 + kase = 0_${ik}$ return - end subroutine stdlib_slacon + end subroutine stdlib${ii}$_slacon - pure subroutine stdlib_slacpy( uplo, m, n, a, lda, b, ldb ) + pure subroutine stdlib${ii}$_slacpy( uplo, m, n, a, lda, b, ldb ) !! SLACPY copies all or part of a two-dimensional matrix A to another !! matrix B. ! -- lapack auxiliary routine -- @@ -1727,13 +1729,13 @@ module stdlib_linalg_lapack_s ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: uplo - integer(ilp), intent(in) :: lda, ldb, m, n + integer(${ik}$), intent(in) :: lda, ldb, m, n ! Array Arguments real(sp), intent(in) :: a(lda,*) real(sp), intent(out) :: b(ldb,*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, j + integer(${ik}$) :: i, j ! Intrinsic Functions intrinsic :: min ! Executable Statements @@ -1757,10 +1759,10 @@ module stdlib_linalg_lapack_s end do end if return - end subroutine stdlib_slacpy + end subroutine stdlib${ii}$_slacpy - pure real(sp) function stdlib_sladiv2( a, b, c, d, r, t ) + pure real(sp) function stdlib${ii}$_sladiv2( 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..-- @@ -1774,19 +1776,19 @@ module stdlib_linalg_lapack_s if( r/=zero ) then br = b * r if( br/=zero ) then - stdlib_sladiv2 = (a + br) * t + stdlib${ii}$_sladiv2 = (a + br) * t else - stdlib_sladiv2 = a * t + (b * t) * r + stdlib${ii}$_sladiv2 = a * t + (b * t) * r end if else - stdlib_sladiv2 = (a + d * (b / c)) * t + stdlib${ii}$_sladiv2 = (a + d * (b / c)) * t end if return - end function stdlib_sladiv2 + end function stdlib${ii}$_sladiv2 - pure subroutine stdlib_slae2( a, b, c, rt1, rt2 ) - !! SLAE2 computes the eigenvalues of a 2-by-2 symmetric matrix + pure subroutine stdlib${ii}$_slae2( a, b, c, rt1, rt2 ) + !! SLAE2 computes the eigenvalues of a 2_${ik}$-by-2 symmetric matrix !! [ A B ] !! [ B C ]. !! On return, RT1 is the eigenvalue of larger absolute value, and RT2 @@ -1821,11 +1823,11 @@ module stdlib_linalg_lapack_s acmn = a end if if( adf>ab ) then - rt = adf*sqrt( one+( ab / adf )**2 ) + rt = adf*sqrt( one+( ab / adf )**2_${ik}$ ) else if( adf3 ) then - info = -1 + info = 0_${ik}$ + if( ijob<1_${ik}$ .or. ijob>3_${ik}$ ) then + info = -1_${ik}$ return end if ! initialize nab - if( ijob==1 ) then + if( ijob==1_${ik}$ ) then ! compute the number of eigenvalues in the initial intervals. - mout = 0 + mout = 0_${ik}$ do ji = 1, minp do jp = 1, 2 - tmp1 = d( 1 ) - ab( ji, jp ) + tmp1 = d( 1_${ik}$ ) - ab( ji, jp ) if( abs( tmp1 )=nbmin .and. nbmin>0 ) then + if( kl-kf+1>=nbmin .and. nbmin>0_${ik}$ ) then ! begin of parallel version of the loop do ji = kf, kl ! compute n(c), the number of eigenvalues less than c - work( ji ) = d( 1 ) - c( ji ) - iwork( ji ) = 0 + work( ji ) = d( 1_${ik}$ ) - c( ji ) + iwork( ji ) = 0_${ik}$ if( work( ji )<=pivmin ) then - iwork( ji ) = 1 + iwork( ji ) = 1_${ik}$ work( ji ) = min( work( ji ), -pivmin ) end if do j = 2, n work( ji ) = d( j ) - e2( j-1 ) / work( ji ) - c( ji ) if( work( ji )<=pivmin ) then - iwork( ji ) = iwork( ji ) + 1 + iwork( ji ) = iwork( ji ) + 1_${ik}$ work( ji ) = min( work( ji ), -pivmin ) end if end do end do - if( ijob<=2 ) then - ! ijob=2: choose all intervals containing eigenvalues. + if( ijob<=2_${ik}$ ) then + ! ijob=2_${ik}$: choose all intervals containing eigenvalues. klnew = kl loop_70: do ji = kf, kl ! insure that n(w) is monotone - iwork( ji ) = min( nab( ji, 2 ),max( nab( ji, 1 ), iwork( ji ) ) ) + iwork( ji ) = min( nab( ji, 2_${ik}$ ),max( nab( ji, 1_${ik}$ ), iwork( ji ) ) ) ! update the queue -- add intervals if both halves ! contain eigenvalues. - if( iwork( ji )==nab( ji, 2 ) ) then + if( iwork( ji )==nab( ji, 2_${ik}$ ) ) then ! no eigenvalue in the upper interval: ! just use the lower interval. - ab( ji, 2 ) = c( ji ) - else if( iwork( ji )==nab( ji, 1 ) ) then + ab( ji, 2_${ik}$ ) = c( ji ) + else if( iwork( ji )==nab( ji, 1_${ik}$ ) ) then ! no eigenvalue in the lower interval: ! just use the upper interval. - ab( ji, 1 ) = c( ji ) + ab( ji, 1_${ik}$ ) = c( ji ) else - klnew = klnew + 1 + klnew = klnew + 1_${ik}$ if( klnew<=mmax ) then ! eigenvalue in both intervals -- add upper to ! queue. - ab( klnew, 2 ) = ab( ji, 2 ) - nab( klnew, 2 ) = nab( ji, 2 ) - ab( klnew, 1 ) = c( ji ) - nab( klnew, 1 ) = iwork( ji ) - ab( ji, 2 ) = c( ji ) - nab( ji, 2 ) = iwork( ji ) + ab( klnew, 2_${ik}$ ) = ab( ji, 2_${ik}$ ) + nab( klnew, 2_${ik}$ ) = nab( ji, 2_${ik}$ ) + ab( klnew, 1_${ik}$ ) = c( ji ) + nab( klnew, 1_${ik}$ ) = iwork( ji ) + ab( ji, 2_${ik}$ ) = c( ji ) + nab( ji, 2_${ik}$ ) = iwork( ji ) else - info = mmax + 1 + info = mmax + 1_${ik}$ end if end if end do loop_70 if( info/=0 )return kl = klnew else - ! ijob=3: binary search. keep only the interval containing + ! ijob=3_${ik}$: binary search. keep only the interval containing ! w s.t. n(w) = nval do ji = kf, kl if( iwork( ji )<=nval( ji ) ) then - ab( ji, 1 ) = c( ji ) - nab( ji, 1 ) = iwork( ji ) + ab( ji, 1_${ik}$ ) = c( ji ) + nab( ji, 1_${ik}$ ) = iwork( ji ) end if if( iwork( ji )>=nval( ji ) ) then - ab( ji, 2 ) = c( ji ) - nab( ji, 2 ) = iwork( ji ) + ab( ji, 2_${ik}$ ) = c( ji ) + nab( ji, 2_${ik}$ ) = iwork( ji ) end if end do end if @@ -2018,56 +2020,56 @@ module stdlib_linalg_lapack_s loop_100: do ji = kf, kl ! compute n(w), the number of eigenvalues less than w tmp1 = c( ji ) - tmp2 = d( 1 ) - tmp1 - itmp1 = 0 + tmp2 = d( 1_${ik}$ ) - tmp1 + itmp1 = 0_${ik}$ if( tmp2<=pivmin ) then - itmp1 = 1 + itmp1 = 1_${ik}$ tmp2 = min( tmp2, -pivmin ) end if do j = 2, n tmp2 = d( j ) - e2( j-1 ) / tmp2 - tmp1 if( tmp2<=pivmin ) then - itmp1 = itmp1 + 1 + itmp1 = itmp1 + 1_${ik}$ tmp2 = min( tmp2, -pivmin ) end if end do - if( ijob<=2 ) then - ! ijob=2: choose all intervals containing eigenvalues. + if( ijob<=2_${ik}$ ) then + ! ijob=2_${ik}$: choose all intervals containing eigenvalues. ! insure that n(w) is monotone - itmp1 = min( nab( ji, 2 ),max( nab( ji, 1 ), itmp1 ) ) + itmp1 = min( nab( ji, 2_${ik}$ ),max( nab( ji, 1_${ik}$ ), itmp1 ) ) ! update the queue -- add intervals if both halves ! contain eigenvalues. - if( itmp1==nab( ji, 2 ) ) then + if( itmp1==nab( ji, 2_${ik}$ ) ) then ! no eigenvalue in the upper interval: ! just use the lower interval. - ab( ji, 2 ) = tmp1 - else if( itmp1==nab( ji, 1 ) ) then + ab( ji, 2_${ik}$ ) = tmp1 + else if( itmp1==nab( ji, 1_${ik}$ ) ) then ! no eigenvalue in the lower interval: ! just use the upper interval. - ab( ji, 1 ) = tmp1 + ab( ji, 1_${ik}$ ) = tmp1 else if( klnew=nval( ji ) ) then - ab( ji, 2 ) = tmp1 - nab( ji, 2 ) = itmp1 + ab( ji, 2_${ik}$ ) = tmp1 + nab( ji, 2_${ik}$ ) = itmp1 end if end if end do loop_100 @@ -2076,68 +2078,68 @@ module stdlib_linalg_lapack_s ! check for convergence kfnew = kf loop_110: do ji = kf, kl - tmp1 = abs( ab( ji, 2 )-ab( ji, 1 ) ) - tmp2 = max( abs( ab( ji, 2 ) ), abs( ab( ji, 1 ) ) ) - if( tmp1=nab( ji, 2 ) ) & + tmp1 = abs( ab( ji, 2_${ik}$ )-ab( ji, 1_${ik}$ ) ) + tmp2 = max( abs( ab( ji, 2_${ik}$ ) ), abs( ab( ji, 1_${ik}$ ) ) ) + if( tmp1=nab( ji, 2_${ik}$ ) ) & then ! converged -- swap with position kfnew, ! then increment kfnew if( ji>kfnew ) then - tmp1 = ab( ji, 1 ) - tmp2 = ab( ji, 2 ) - itmp1 = nab( ji, 1 ) - itmp2 = nab( ji, 2 ) - ab( ji, 1 ) = ab( kfnew, 1 ) - ab( ji, 2 ) = ab( kfnew, 2 ) - nab( ji, 1 ) = nab( kfnew, 1 ) - nab( ji, 2 ) = nab( kfnew, 2 ) - ab( kfnew, 1 ) = tmp1 - ab( kfnew, 2 ) = tmp2 - nab( kfnew, 1 ) = itmp1 - nab( kfnew, 2 ) = itmp2 - if( ijob==3 ) then + tmp1 = ab( ji, 1_${ik}$ ) + tmp2 = ab( ji, 2_${ik}$ ) + itmp1 = nab( ji, 1_${ik}$ ) + itmp2 = nab( ji, 2_${ik}$ ) + ab( ji, 1_${ik}$ ) = ab( kfnew, 1_${ik}$ ) + ab( ji, 2_${ik}$ ) = ab( kfnew, 2_${ik}$ ) + nab( ji, 1_${ik}$ ) = nab( kfnew, 1_${ik}$ ) + nab( ji, 2_${ik}$ ) = nab( kfnew, 2_${ik}$ ) + ab( kfnew, 1_${ik}$ ) = tmp1 + ab( kfnew, 2_${ik}$ ) = tmp2 + nab( kfnew, 1_${ik}$ ) = itmp1 + nab( kfnew, 2_${ik}$ ) = itmp2 + if( ijob==3_${ik}$ ) then itmp1 = nval( ji ) nval( ji ) = nval( kfnew ) nval( kfnew ) = itmp1 end if end if - kfnew = kfnew + 1 + kfnew = kfnew + 1_${ik}$ end if end do loop_110 kf = kfnew ! choose midpoints do ji = kf, kl - c( ji ) = half*( ab( ji, 1 )+ab( ji, 2 ) ) + c( ji ) = half*( ab( ji, 1_${ik}$ )+ab( ji, 2_${ik}$ ) ) end do ! if no more intervals to refine, quit. if( kf>kl )go to 140 end do loop_130 ! converged 140 continue - info = max( kl+1-kf, 0 ) + info = max( kl+1-kf, 0_${ik}$ ) mout = kl return - end subroutine stdlib_slaebz + end subroutine stdlib${ii}$_slaebz - pure subroutine stdlib_slaed5( i, d, z, delta, rho, dlam ) + pure subroutine stdlib${ii}$_slaed5( i, d, z, delta, rho, dlam ) !! This subroutine computes the I-th eigenvalue of a symmetric rank-one - !! modification of a 2-by-2 diagonal matrix + !! modification of a 2_${ik}$-by-2 diagonal matrix !! diag( D ) + RHO * Z * transpose(Z) . !! The diagonal elements in the array D are assumed to satisfy !! D(i) < D(j) for i < j . - !! We also assume RHO > 0 and that the Euclidean norm of the vector + !! We also assume RHO > 0_${ik}$ and that the Euclidean norm of the vector !! Z is one. ! -- 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 - integer(ilp), intent(in) :: i + integer(${ik}$), intent(in) :: i real(sp), intent(out) :: dlam real(sp), intent(in) :: rho ! Array Arguments - real(sp), intent(in) :: d(2), z(2) - real(sp), intent(out) :: delta(2) + real(sp), intent(in) :: d(2_${ik}$), z(2_${ik}$) + real(sp), intent(out) :: delta(2_${ik}$) ! ===================================================================== ! Local Scalars @@ -2145,53 +2147,53 @@ module stdlib_linalg_lapack_s ! Intrinsic Functions intrinsic :: abs,sqrt ! Executable Statements - del = d( 2 ) - d( 1 ) - if( i==1 ) then - w = one + two*rho*( z( 2 )*z( 2 )-z( 1 )*z( 1 ) ) / del + del = d( 2_${ik}$ ) - d( 1_${ik}$ ) + if( i==1_${ik}$ ) then + w = one + two*rho*( z( 2_${ik}$ )*z( 2_${ik}$ )-z( 1_${ik}$ )*z( 1_${ik}$ ) ) / del if( w>zero ) then - b = del + rho*( z( 1 )*z( 1 )+z( 2 )*z( 2 ) ) - c = rho*z( 1 )*z( 1 )*del + b = del + rho*( z( 1_${ik}$ )*z( 1_${ik}$ )+z( 2_${ik}$ )*z( 2_${ik}$ ) ) + c = rho*z( 1_${ik}$ )*z( 1_${ik}$ )*del ! b > zero, always tau = two*c / ( b+sqrt( abs( b*b-four*c ) ) ) - dlam = d( 1 ) + tau - delta( 1 ) = -z( 1 ) / tau - delta( 2 ) = z( 2 ) / ( del-tau ) + dlam = d( 1_${ik}$ ) + tau + delta( 1_${ik}$ ) = -z( 1_${ik}$ ) / tau + delta( 2_${ik}$ ) = z( 2_${ik}$ ) / ( del-tau ) else - b = -del + rho*( z( 1 )*z( 1 )+z( 2 )*z( 2 ) ) - c = rho*z( 2 )*z( 2 )*del + b = -del + rho*( z( 1_${ik}$ )*z( 1_${ik}$ )+z( 2_${ik}$ )*z( 2_${ik}$ ) ) + c = rho*z( 2_${ik}$ )*z( 2_${ik}$ )*del if( b>zero ) then tau = -two*c / ( b+sqrt( b*b+four*c ) ) else tau = ( b-sqrt( b*b+four*c ) ) / two end if - dlam = d( 2 ) + tau - delta( 1 ) = -z( 1 ) / ( del+tau ) - delta( 2 ) = -z( 2 ) / tau + dlam = d( 2_${ik}$ ) + tau + delta( 1_${ik}$ ) = -z( 1_${ik}$ ) / ( del+tau ) + delta( 2_${ik}$ ) = -z( 2_${ik}$ ) / tau end if - temp = sqrt( delta( 1 )*delta( 1 )+delta( 2 )*delta( 2 ) ) - delta( 1 ) = delta( 1 ) / temp - delta( 2 ) = delta( 2 ) / temp + temp = sqrt( delta( 1_${ik}$ )*delta( 1_${ik}$ )+delta( 2_${ik}$ )*delta( 2_${ik}$ ) ) + delta( 1_${ik}$ ) = delta( 1_${ik}$ ) / temp + delta( 2_${ik}$ ) = delta( 2_${ik}$ ) / temp else - ! now i=2 - b = -del + rho*( z( 1 )*z( 1 )+z( 2 )*z( 2 ) ) - c = rho*z( 2 )*z( 2 )*del + ! now i=2_${ik}$ + b = -del + rho*( z( 1_${ik}$ )*z( 1_${ik}$ )+z( 2_${ik}$ )*z( 2_${ik}$ ) ) + c = rho*z( 2_${ik}$ )*z( 2_${ik}$ )*del if( b>zero ) then tau = ( b+sqrt( b*b+four*c ) ) / two else tau = two*c / ( -b+sqrt( b*b+four*c ) ) end if - dlam = d( 2 ) + tau - delta( 1 ) = -z( 1 ) / ( del+tau ) - delta( 2 ) = -z( 2 ) / tau - temp = sqrt( delta( 1 )*delta( 1 )+delta( 2 )*delta( 2 ) ) - delta( 1 ) = delta( 1 ) / temp - delta( 2 ) = delta( 2 ) / temp + dlam = d( 2_${ik}$ ) + tau + delta( 1_${ik}$ ) = -z( 1_${ik}$ ) / ( del+tau ) + delta( 2_${ik}$ ) = -z( 2_${ik}$ ) / tau + temp = sqrt( delta( 1_${ik}$ )*delta( 1_${ik}$ )+delta( 2_${ik}$ )*delta( 2_${ik}$ ) ) + delta( 1_${ik}$ ) = delta( 1_${ik}$ ) / temp + delta( 2_${ik}$ ) = delta( 2_${ik}$ ) / temp end if return - end subroutine stdlib_slaed5 + end subroutine stdlib${ii}$_slaed5 - pure subroutine stdlib_slaeda( n, tlvls, curlvl, curpbm, prmptr, perm, givptr,givcol, givnum,& + pure subroutine stdlib${ii}$_slaeda( n, tlvls, curlvl, curpbm, prmptr, perm, givptr,givcol, givnum,& !! SLAEDA computes the Z vector corresponding to the merge step in the !! CURLVLth step of the merge process with TLVLS steps for the CURPBMth !! problem. @@ -2200,111 +2202,111 @@ module stdlib_linalg_lapack_s ! -- 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) :: curlvl, curpbm, n, tlvls - integer(ilp), intent(out) :: info + integer(${ik}$), intent(in) :: curlvl, curpbm, n, tlvls + integer(${ik}$), intent(out) :: info ! Array Arguments - integer(ilp), intent(in) :: givcol(2,*), givptr(*), perm(*), prmptr(*), qptr(*) - real(sp), intent(in) :: givnum(2,*), q(*) + integer(${ik}$), intent(in) :: givcol(2_${ik}$,*), givptr(*), perm(*), prmptr(*), qptr(*) + real(sp), intent(in) :: givnum(2_${ik}$,*), q(*) real(sp), intent(out) :: z(*), ztemp(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: bsiz1, bsiz2, curr, i, k, mid, psiz1, psiz2, ptr, zptr1 + integer(${ik}$) :: bsiz1, bsiz2, curr, i, k, mid, psiz1, psiz2, ptr, zptr1 ! Intrinsic Functions intrinsic :: int,real,sqrt ! Executable Statements ! test the input parameters. - info = 0 - if( n<0 ) then - info = -1 + info = 0_${ik}$ + if( n<0_${ik}$ ) then + info = -1_${ik}$ end if - if( info/=0 ) then - call stdlib_xerbla( 'SLAEDA', -info ) + if( info/=0_${ik}$ ) then + call stdlib${ii}$_xerbla( 'SLAEDA', -info ) return end if ! quick return if possible if( n==0 )return ! determine location of first number in second half. - mid = n / 2 + 1 + mid = n / 2_${ik}$ + 1_${ik}$ ! gather last/first rows of appropriate eigenblocks into center of z - ptr = 1 + ptr = 1_${ik}$ ! determine location of lowest level subproblem in the full storage ! scheme - curr = ptr + curpbm*2**curlvl + 2**( curlvl-1 ) - 1 + curr = ptr + curpbm*2_${ik}$**curlvl + 2_${ik}$**( curlvl-1 ) - 1_${ik}$ ! determine size of these matrices. we add half to the value of ! the sqrt in case the machine underestimates one of these square ! roots. - bsiz1 = int( half+sqrt( real( qptr( curr+1 )-qptr( curr ),KIND=sp) ),KIND=ilp) - bsiz2 = int( half+sqrt( real( qptr( curr+2 )-qptr( curr+1 ),KIND=sp) ),KIND=ilp) + bsiz1 = int( half+sqrt( real( qptr( curr+1 )-qptr( curr ),KIND=sp) ),KIND=${ik}$) + bsiz2 = int( half+sqrt( real( qptr( curr+2 )-qptr( curr+1 ),KIND=sp) ),KIND=${ik}$) do k = 1, mid - bsiz1 - 1 z( k ) = zero end do - call stdlib_scopy( bsiz1, q( qptr( curr )+bsiz1-1 ), bsiz1,z( mid-bsiz1 ), 1 ) - call stdlib_scopy( bsiz2, q( qptr( curr+1 ) ), bsiz2, z( mid ), 1 ) + call stdlib${ii}$_scopy( bsiz1, q( qptr( curr )+bsiz1-1 ), bsiz1,z( mid-bsiz1 ), 1_${ik}$ ) + call stdlib${ii}$_scopy( bsiz2, q( qptr( curr+1 ) ), bsiz2, z( mid ), 1_${ik}$ ) do k = mid + bsiz2, n z( k ) = zero end do - ! loop through remaining levels 1 -> curlvl applying the givens + ! loop through remaining levels 1_${ik}$ -> curlvl applying the givens ! rotations and permutation and then multiplying the center matrices ! against the current z. - ptr = 2**tlvls + 1 + ptr = 2_${ik}$**tlvls + 1_${ik}$ loop_70: do k = 1, curlvl - 1 - curr = ptr + curpbm*2**( curlvl-k ) + 2**( curlvl-k-1 ) - 1 + curr = ptr + curpbm*2_${ik}$**( curlvl-k ) + 2_${ik}$**( curlvl-k-1 ) - 1_${ik}$ psiz1 = prmptr( curr+1 ) - prmptr( curr ) psiz2 = prmptr( curr+2 ) - prmptr( curr+1 ) zptr1 = mid - psiz1 ! apply givens at curr and curr+1 do i = givptr( curr ), givptr( curr+1 ) - 1 - call stdlib_srot( 1, z( zptr1+givcol( 1, i )-1 ), 1,z( zptr1+givcol( 2, i )-1 ), & - 1, givnum( 1, i ),givnum( 2, i ) ) + call stdlib${ii}$_srot( 1_${ik}$, z( zptr1+givcol( 1_${ik}$, i )-1_${ik}$ ), 1_${ik}$,z( zptr1+givcol( 2_${ik}$, i )-1_${ik}$ ), & + 1_${ik}$, givnum( 1_${ik}$, i ),givnum( 2_${ik}$, i ) ) end do do i = givptr( curr+1 ), givptr( curr+2 ) - 1 - call stdlib_srot( 1, z( mid-1+givcol( 1, i ) ), 1,z( mid-1+givcol( 2, i ) ), 1, & - givnum( 1, i ),givnum( 2, i ) ) + call stdlib${ii}$_srot( 1_${ik}$, z( mid-1+givcol( 1_${ik}$, i ) ), 1_${ik}$,z( mid-1+givcol( 2_${ik}$, i ) ), 1_${ik}$, & + givnum( 1_${ik}$, i ),givnum( 2_${ik}$, i ) ) end do psiz1 = prmptr( curr+1 ) - prmptr( curr ) psiz2 = prmptr( curr+2 ) - prmptr( curr+1 ) do i = 0, psiz1 - 1 - ztemp( i+1 ) = z( zptr1+perm( prmptr( curr )+i )-1 ) + ztemp( i+1 ) = z( zptr1+perm( prmptr( curr )+i )-1_${ik}$ ) end do do i = 0, psiz2 - 1 - ztemp( psiz1+i+1 ) = z( mid+perm( prmptr( curr+1 )+i )-1 ) + ztemp( psiz1+i+1 ) = z( mid+perm( prmptr( curr+1 )+i )-1_${ik}$ ) end do ! multiply blocks at curr and curr+1 ! determine size of these matrices. we add half to the value of ! the sqrt in case the machine underestimates one of these ! square roots. - bsiz1 = int( half+sqrt( real( qptr( curr+1 )-qptr( curr ),KIND=sp) ),KIND=ilp) + bsiz1 = int( half+sqrt( real( qptr( curr+1 )-qptr( curr ),KIND=sp) ),KIND=${ik}$) - bsiz2 = int( half+sqrt( real( qptr( curr+2 )-qptr( curr+1 ),KIND=sp) ),KIND=ilp) + bsiz2 = int( half+sqrt( real( qptr( curr+2 )-qptr( curr+1 ),KIND=sp) ),KIND=${ik}$) - if( bsiz1>0 ) then - call stdlib_sgemv( 'T', bsiz1, bsiz1, one, q( qptr( curr ) ),bsiz1, ztemp( 1 ), & - 1, zero, z( zptr1 ), 1 ) + if( bsiz1>0_${ik}$ ) then + call stdlib${ii}$_sgemv( 'T', bsiz1, bsiz1, one, q( qptr( curr ) ),bsiz1, ztemp( 1_${ik}$ ), & + 1_${ik}$, zero, z( zptr1 ), 1_${ik}$ ) end if - call stdlib_scopy( psiz1-bsiz1, ztemp( bsiz1+1 ), 1, z( zptr1+bsiz1 ),1 ) - if( bsiz2>0 ) then - call stdlib_sgemv( 'T', bsiz2, bsiz2, one, q( qptr( curr+1 ) ),bsiz2, ztemp( & - psiz1+1 ), 1, zero, z( mid ), 1 ) + call stdlib${ii}$_scopy( psiz1-bsiz1, ztemp( bsiz1+1 ), 1_${ik}$, z( zptr1+bsiz1 ),1_${ik}$ ) + if( bsiz2>0_${ik}$ ) then + call stdlib${ii}$_sgemv( 'T', bsiz2, bsiz2, one, q( qptr( curr+1 ) ),bsiz2, ztemp( & + psiz1+1 ), 1_${ik}$, zero, z( mid ), 1_${ik}$ ) end if - call stdlib_scopy( psiz2-bsiz2, ztemp( psiz1+bsiz2+1 ), 1,z( mid+bsiz2 ), 1 ) + call stdlib${ii}$_scopy( psiz2-bsiz2, ztemp( psiz1+bsiz2+1 ), 1_${ik}$,z( mid+bsiz2 ), 1_${ik}$ ) - ptr = ptr + 2**( tlvls-k ) + ptr = ptr + 2_${ik}$**( tlvls-k ) end do loop_70 return - end subroutine stdlib_slaeda + end subroutine stdlib${ii}$_slaeda - pure subroutine stdlib_slaev2( a, b, c, rt1, rt2, cs1, sn1 ) - !! SLAEV2 computes the eigendecomposition of a 2-by-2 symmetric matrix + pure subroutine stdlib${ii}$_slaev2( a, b, c, rt1, rt2, cs1, sn1 ) + !! SLAEV2 computes the eigendecomposition of a 2_${ik}$-by-2 symmetric matrix !! [ A B ] !! [ B C ]. !! On return, RT1 is the eigenvalue of larger absolute value, RT2 is the !! eigenvalue of smaller absolute value, and (CS1,SN1) is the unit right !! eigenvector for RT1, giving the decomposition - !! [ CS1 SN1 ] [ A B ] [ CS1 -SN1 ] = [ RT1 0 ] - !! [-SN1 CS1 ] [ B C ] [ SN1 CS1 ] [ 0 RT2 ]. + !! [ CS1 SN1 ] [ A B ] [ CS1 -SN1 ] = [ RT1 0_${ik}$ ] + !! [-SN1 CS1 ] [ B C ] [ SN1 CS1 ] [ 0_${ik}$ RT2 ]. ! -- lapack auxiliary routine -- ! -- lapack is a software package provided by univ. of tennessee, -- ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- @@ -2317,7 +2319,7 @@ module stdlib_linalg_lapack_s ! Local Scalars - integer(ilp) :: sgn1, sgn2 + integer(${ik}$) :: sgn1, sgn2 real(sp) :: ab, acmn, acmx, acs, adf, cs, ct, df, rt, sm, tb, tn ! Intrinsic Functions intrinsic :: abs,sqrt @@ -2336,40 +2338,40 @@ module stdlib_linalg_lapack_s acmn = a end if if( adf>ab ) then - rt = adf*sqrt( one+( ab / adf )**2 ) + rt = adf*sqrt( one+( ab / adf )**2_${ik}$ ) else if( adfzero ) then rt1 = half*( sm+rt ) - sgn1 = 1 + sgn1 = 1_${ik}$ ! order of execution important. ! to get fully accurate smaller eigenvalue, ! next line needs to be executed in higher precision. rt2 = ( acmx / rt1 )*acmn - ( b / rt1 )*b else - ! includes case rt1 = rt2 = 0 + ! includes case rt1 = rt2 = 0_${ik}$ rt1 = half*rt rt2 = -half*rt - sgn1 = 1 + sgn1 = 1_${ik}$ end if ! compute the eigenvector if( df>=zero ) then cs = df + rt - sgn2 = 1 + sgn2 = 1_${ik}$ else cs = df - rt - sgn2 = -1 + sgn2 = -1_${ik}$ end if acs = abs( cs ) if( acs>ab ) then @@ -2392,11 +2394,11 @@ module stdlib_linalg_lapack_s sn1 = tn end if return - end subroutine stdlib_slaev2 + end subroutine stdlib${ii}$_slaev2 - pure subroutine stdlib_slag2( a, lda, b, ldb, safmin, scale1, scale2, wr1,wr2, wi ) - !! SLAG2 computes the eigenvalues of a 2 x 2 generalized eigenvalue + pure subroutine stdlib${ii}$_slag2( a, lda, b, ldb, safmin, scale1, scale2, wr1,wr2, wi ) + !! SLAG2 computes the eigenvalues of a 2_${ik}$ x 2_${ik}$ generalized eigenvalue !! problem A - w B, with scaling as necessary to avoid over-/underflow. !! The scaling factor "s" results in a modified eigenvalue equation !! s A - w B @@ -2406,7 +2408,7 @@ module stdlib_linalg_lapack_s ! -- 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) :: lda, ldb + integer(${ik}$), intent(in) :: lda, ldb real(sp), intent(in) :: safmin real(sp), intent(out) :: scale1, scale2, wi, wr1, wr2 ! Array Arguments @@ -2429,17 +2431,17 @@ module stdlib_linalg_lapack_s rtmax = one / rtmin safmax = one / safmin ! scale a - anorm = max( abs( a( 1, 1 ) )+abs( a( 2, 1 ) ),abs( a( 1, 2 ) )+abs( a( 2, 2 ) ), & + anorm = max( abs( a( 1_${ik}$, 1_${ik}$ ) )+abs( a( 2_${ik}$, 1_${ik}$ ) ),abs( a( 1_${ik}$, 2_${ik}$ ) )+abs( a( 2_${ik}$, 2_${ik}$ ) ), & safmin ) ascale = one / anorm - a11 = ascale*a( 1, 1 ) - a21 = ascale*a( 2, 1 ) - a12 = ascale*a( 1, 2 ) - a22 = ascale*a( 2, 2 ) + a11 = ascale*a( 1_${ik}$, 1_${ik}$ ) + a21 = ascale*a( 2_${ik}$, 1_${ik}$ ) + a12 = ascale*a( 1_${ik}$, 2_${ik}$ ) + a22 = ascale*a( 2_${ik}$, 2_${ik}$ ) ! perturb b if necessary to insure non-singularity - b11 = b( 1, 1 ) - b12 = b( 1, 2 ) - b22 = b( 2, 2 ) + b11 = b( 1_${ik}$, 1_${ik}$ ) + b12 = b( 1_${ik}$, 2_${ik}$ ) + b22 = b( 2_${ik}$, 2_${ik}$ ) bmin = rtmin*max( abs( b11 ), abs( b12 ), abs( b22 ), rtmin ) if( abs( b11 )=one ) then - discr = ( rtmin*pp )**2 + qq*safmin + discr = ( rtmin*pp )**2_${ik}$ + qq*safmin r = sqrt( abs( discr ) )*rtmax else - if( pp**2+abs( qq )<=safmin ) then - discr = ( rtmax*pp )**2 + qq*safmax + if( pp**2_${ik}$+abs( qq )<=safmin ) then + discr = ( rtmax*pp )**2_${ik}$ + qq*safmax r = sqrt( abs( discr ) )*rtmin else - discr = pp**2 + qq + discr = pp**2_${ik}$ + qq r = sqrt( abs( discr ) ) end if end if @@ -2499,7 +2501,7 @@ module stdlib_linalg_lapack_s wdet = ( a11*a22-a12*a21 )*( binv11*binv22 ) wsmall = wdet / wbig end if - ! choose (real) eigenvalue closest to 2,2 element of a*b**(-1) + ! choose (real) eigenvalue closest to 2_${ik}$,2_${ik}$ element of a*b**(-1_${ik}$) ! for wr1. if( pp>abi22 ) then wr1 = min( wbig, wsmall ) @@ -2576,10 +2578,10 @@ module stdlib_linalg_lapack_s end if end if return - end subroutine stdlib_slag2 + end subroutine stdlib${ii}$_slag2 - pure subroutine stdlib_slag2d( m, n, sa, ldsa, a, lda, info ) + pure subroutine stdlib${ii}$_slag2d( m, n, sa, ldsa, a, lda, info ) !! SLAG2D converts a SINGLE PRECISION matrix, SA, to a DOUBLE !! PRECISION matrix, A. !! Note that while it is possible to overflow while converting @@ -2590,26 +2592,26 @@ module stdlib_linalg_lapack_s ! -- 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 + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, ldsa, m, n ! Array Arguments real(sp), intent(in) :: sa(ldsa,*) real(dp), intent(out) :: a(lda,*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, j + integer(${ik}$) :: i, j ! Executable Statements - info = 0 + info = 0_${ik}$ do j = 1, n do i = 1, m a( i, j ) = sa( i, j ) end do end do return - end subroutine stdlib_slag2d + end subroutine stdlib${ii}$_slag2d - pure subroutine stdlib_slagtm( trans, n, nrhs, alpha, dl, d, du, x, ldx, beta,b, ldb ) + pure subroutine stdlib${ii}$_slagtm( trans, n, nrhs, alpha, dl, d, du, x, ldx, beta,b, ldb ) !! SLAGTM 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 @@ -2621,7 +2623,7 @@ module stdlib_linalg_lapack_s ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: trans - integer(ilp), intent(in) :: ldb, ldx, n, nrhs + integer(${ik}$), intent(in) :: ldb, ldx, n, nrhs real(sp), intent(in) :: alpha, beta ! Array Arguments real(sp), intent(inout) :: b(ldb,*) @@ -2629,7 +2631,7 @@ module stdlib_linalg_lapack_s ! ===================================================================== ! Local Scalars - integer(ilp) :: i, j + integer(${ik}$) :: i, j ! Executable Statements if( n==0 )return ! multiply b by beta if beta/=1. @@ -2650,10 +2652,10 @@ module stdlib_linalg_lapack_s if( stdlib_lsame( trans, 'N' ) ) then ! compute b := b + a*x do j = 1, nrhs - if( n==1 ) then - b( 1, j ) = b( 1, j ) + d( 1 )*x( 1, j ) + if( n==1_${ik}$ ) then + b( 1_${ik}$, j ) = b( 1_${ik}$, j ) + d( 1_${ik}$ )*x( 1_${ik}$, j ) else - b( 1, j ) = b( 1, j ) + d( 1 )*x( 1, j ) +du( 1 )*x( 2, j ) + b( 1_${ik}$, j ) = b( 1_${ik}$, j ) + d( 1_${ik}$ )*x( 1_${ik}$, j ) +du( 1_${ik}$ )*x( 2_${ik}$, j ) b( n, j ) = b( n, j ) + dl( n-1 )*x( n-1, j ) +d( n )*x( n, j ) do i = 2, n - 1 b( i, j ) = b( i, j ) + dl( i-1 )*x( i-1, j ) +d( i )*x( i, j ) + du( i & @@ -2664,10 +2666,10 @@ module stdlib_linalg_lapack_s else ! compute b := b + a**t*x do j = 1, nrhs - if( n==1 ) then - b( 1, j ) = b( 1, j ) + d( 1 )*x( 1, j ) + if( n==1_${ik}$ ) then + b( 1_${ik}$, j ) = b( 1_${ik}$, j ) + d( 1_${ik}$ )*x( 1_${ik}$, j ) else - b( 1, j ) = b( 1, j ) + d( 1 )*x( 1, j ) +dl( 1 )*x( 2, j ) + b( 1_${ik}$, j ) = b( 1_${ik}$, j ) + d( 1_${ik}$ )*x( 1_${ik}$, j ) +dl( 1_${ik}$ )*x( 2_${ik}$, j ) b( n, j ) = b( n, j ) + du( n-1 )*x( n-1, j ) +d( n )*x( n, j ) do i = 2, n - 1 b( i, j ) = b( i, j ) + du( i-1 )*x( i-1, j ) +d( i )*x( i, j ) + dl( i & @@ -2680,10 +2682,10 @@ module stdlib_linalg_lapack_s if( stdlib_lsame( trans, 'N' ) ) then ! compute b := b - a*x do j = 1, nrhs - if( n==1 ) then - b( 1, j ) = b( 1, j ) - d( 1 )*x( 1, j ) + if( n==1_${ik}$ ) then + b( 1_${ik}$, j ) = b( 1_${ik}$, j ) - d( 1_${ik}$ )*x( 1_${ik}$, j ) else - b( 1, j ) = b( 1, j ) - d( 1 )*x( 1, j ) -du( 1 )*x( 2, j ) + b( 1_${ik}$, j ) = b( 1_${ik}$, j ) - d( 1_${ik}$ )*x( 1_${ik}$, j ) -du( 1_${ik}$ )*x( 2_${ik}$, j ) b( n, j ) = b( n, j ) - dl( n-1 )*x( n-1, j ) -d( n )*x( n, j ) do i = 2, n - 1 b( i, j ) = b( i, j ) - dl( i-1 )*x( i-1, j ) -d( i )*x( i, j ) - du( i & @@ -2694,10 +2696,10 @@ module stdlib_linalg_lapack_s else ! compute b := b - a**t*x do j = 1, nrhs - if( n==1 ) then - b( 1, j ) = b( 1, j ) - d( 1 )*x( 1, j ) + if( n==1_${ik}$ ) then + b( 1_${ik}$, j ) = b( 1_${ik}$, j ) - d( 1_${ik}$ )*x( 1_${ik}$, j ) else - b( 1, j ) = b( 1, j ) - d( 1 )*x( 1, j ) -dl( 1 )*x( 2, j ) + b( 1_${ik}$, j ) = b( 1_${ik}$, j ) - d( 1_${ik}$ )*x( 1_${ik}$, j ) -dl( 1_${ik}$ )*x( 2_${ik}$, j ) b( n, j ) = b( n, j ) - du( n-1 )*x( n-1, j ) -d( n )*x( n, j ) do i = 2, n - 1 b( i, j ) = b( i, j ) - du( i-1 )*x( i-1, j ) -d( i )*x( i, j ) - dl( i & @@ -2708,10 +2710,10 @@ module stdlib_linalg_lapack_s end if end if return - end subroutine stdlib_slagtm + end subroutine stdlib${ii}$_slagtm - pure logical(lk) function stdlib_slaisnan( sin1, sin2 ) + pure logical(lk) function stdlib${ii}$_slaisnan( sin1, sin2 ) !! This routine is not for general use. It exists solely to avoid !! over-optimization in SISNAN. !! SLAISNAN checks for NaNs by comparing its two arguments for @@ -2722,7 +2724,7 @@ module stdlib_linalg_lapack_s !! not the same variable, and the test will not be optimized away. !! Interprocedural or whole-program optimization may delete this !! test. The ISNAN functions will be replaced by the correct - !! Fortran 03 intrinsic once the intrinsic is widely available. + !! Fortran 03_${ik}$ intrinsic once the intrinsic is widely available. ! -- lapack auxiliary routine -- ! -- lapack is a software package provided by univ. of tennessee, -- ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- @@ -2730,12 +2732,12 @@ module stdlib_linalg_lapack_s real(sp), intent(in) :: sin1, sin2 ! ===================================================================== ! Executable Statements - stdlib_slaisnan = (sin1/=sin2) + stdlib${ii}$_slaisnan = (sin1/=sin2) return - end function stdlib_slaisnan + end function stdlib${ii}$_slaisnan - pure real(sp) function stdlib_slamch( cmach ) + pure real(sp) function stdlib${ii}$_slamch( cmach ) !! SLAMCH determines single precision machine parameters. ! -- lapack auxiliary routine -- ! -- lapack is a software package provided by univ. of tennessee, -- @@ -2763,7 +2765,7 @@ module stdlib_linalg_lapack_s small = one / huge(zero) if( small>=sfmin ) then ! use small plus a bit, to avoid the possibility of rounding - ! causing overflow when computing 1/sfmin. + ! causing overflow when computing 1_${ik}$/sfmin. sfmin = small*( one+eps ) end if rmach = sfmin @@ -2786,24 +2788,24 @@ module stdlib_linalg_lapack_s else rmach = zero end if - stdlib_slamch = rmach + stdlib${ii}$_slamch = rmach return - end function stdlib_slamch + end function stdlib${ii}$_slamch - pure real(sp) function stdlib_slamc3( a, b ) + pure real(sp) function stdlib${ii}$_slamc3( a, b ) ! -- lapack auxiliary routine -- ! univ. of tennessee, univ. of california berkeley and nag ltd.. ! Scalar Arguments real(sp), intent(in) :: a, b ! ===================================================================== ! Executable Statements - stdlib_slamc3 = a + b + stdlib${ii}$_slamc3 = a + b return - end function stdlib_slamc3 + end function stdlib${ii}$_slamc3 - pure subroutine stdlib_slamrg( n1, n2, a, strd1, strd2, index ) + pure subroutine stdlib${ii}$_slamrg( n1, n2, a, strd1, strd2, index ) !! SLAMRG 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. @@ -2811,70 +2813,70 @@ module stdlib_linalg_lapack_s ! -- 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) :: n1, n2, strd1, strd2 + integer(${ik}$), intent(in) :: n1, n2, strd1, strd2 ! Array Arguments - integer(ilp), intent(out) :: index(*) + integer(${ik}$), intent(out) :: index(*) real(sp), intent(in) :: a(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, ind1, ind2, n1sv, n2sv + integer(${ik}$) :: i, ind1, ind2, n1sv, n2sv ! Executable Statements n1sv = n1 n2sv = n2 - if( strd1>0 ) then - ind1 = 1 + if( strd1>0_${ik}$ ) then + ind1 = 1_${ik}$ else ind1 = n1 end if - if( strd2>0 ) then - ind2 = 1 + n1 + if( strd2>0_${ik}$ ) then + ind2 = 1_${ik}$ + n1 else ind2 = n1 + n2 end if - i = 1 - ! while ( (n1sv > 0) + i = 1_${ik}$ + ! while ( (n1sv > 0_${ik}$) 10 continue - if( n1sv>0 .and. n2sv>0 ) then + if( n1sv>0_${ik}$ .and. n2sv>0_${ik}$ ) then if( a( ind1 )<=a( ind2 ) ) then index( i ) = ind1 - i = i + 1 + i = i + 1_${ik}$ ind1 = ind1 + strd1 - n1sv = n1sv - 1 + n1sv = n1sv - 1_${ik}$ else index( i ) = ind2 - i = i + 1 + i = i + 1_${ik}$ ind2 = ind2 + strd2 - n2sv = n2sv - 1 + n2sv = n2sv - 1_${ik}$ end if go to 10 end if ! end while - if( n1sv==0 ) then + if( n1sv==0_${ik}$ ) then do n1sv = 1, n2sv index( i ) = ind2 - i = i + 1 + i = i + 1_${ik}$ ind2 = ind2 + strd2 end do else - ! n2sv == 0 + ! n2sv == 0_${ik}$ do n2sv = 1, n1sv index( i ) = ind1 - i = i + 1 + i = i + 1_${ik}$ ind1 = ind1 + strd1 end do end if return - end subroutine stdlib_slamrg + end subroutine stdlib${ii}$_slamrg - pure recursive subroutine stdlib_slaorhr_col_getrfnp2( m, n, a, lda, d, info ) + pure recursive subroutine stdlib${ii}$_slaorhr_col_getrfnp2( m, n, a, lda, d, info ) !! SLAORHR_COL_GETRFNP2 computes the modified LU factorization without !! pivoting of a real general M-by-N matrix A. The factorization has !! the form: !! A - S = L * U, !! where: !! S is a m-by-n diagonal sign matrix with the diagonal D, so that - !! D(i) = S(i,i), 1 <= i <= min(M,N). The diagonal D is constructed + !! D(i) = S(i,i), 1_${ik}$ <= i <= min(M,N). The diagonal D is constructed !! as D(i)=-SIGN(A(i,i)), where A(i,i) is the value after performing !! i-1 steps of Gaussian elimination. This means that the diagonal !! element at each step of "modified" Gaussian elimination is at @@ -2891,9 +2893,9 @@ module stdlib_linalg_lapack_s !! the matrix S above, one can show that the diagonal element at each !! step of Gaussian elimination is the largest (in absolute value) in !! the column on or below the diagonal, so that no pivoting is required - !! for numerical stability [1]. + !! for numerical stability [1_${ik}$]. !! For more details on the Householder reconstruction algorithm, - !! including the modified LU factorization, see [1]. + !! including the modified LU factorization, see [1_${ik}$]. !! This is the recursive version of the LU factorization algorithm. !! Denote A - S by B. The algorithm divides the matrix B into four !! submatrices: @@ -2901,27 +2903,27 @@ module stdlib_linalg_lapack_s !! B = [ -----|----- ] B21 is (m-n1) by n1, !! [ B21 | B22 ] B12 is n1 by n2, !! B22 is (m-n1) by n2, - !! with n1 = min(m,n)/2, n2 = n-n1. + !! with n1 = min(m,n)/2_${ik}$, n2 = n-n1. !! The subroutine calls itself to factor B11, solves for B21, !! solves for B12, updates B22, then calls itself to factor B22. - !! For more details on the recursive LU algorithm, see [2]. + !! For more details on the recursive LU algorithm, see [2_${ik}$]. !! SLAORHR_COL_GETRFNP2 is called to factorize a block by the blocked !! routine SLAORHR_COL_GETRFNP, which uses blocked code calling - !! Level 3 BLAS to update the submatrix. However, SLAORHR_COL_GETRFNP2 + !! Level 3_${ik}$ BLAS to update the submatrix. However, SLAORHR_COL_GETRFNP2 !! is self-sufficient and can be used without SLAORHR_COL_GETRFNP. - !! [1] "Reconstructing Householder vectors from tall-skinny QR", + !! [1_${ik}$] "Reconstructing Householder vectors from tall-skinny QR", !! G. Ballard, J. Demmel, L. Grigori, M. Jacquelin, H.D. Nguyen, !! E. Solomonik, J. Parallel Distrib. Comput., - !! vol. 85, pp. 3-31, 2015. - !! [2] "Recursion leads to automatic variable blocking for dense linear + !! vol. 85_${ik}$, pp. 3_${ik}$-31, 2015. + !! [2_${ik}$] "Recursion leads to automatic variable blocking for dense linear !! algebra algorithms", F. Gustavson, IBM J. of Res. and Dev., - !! vol. 41, no. 6, pp. 737-755, 1997. + !! vol. 41_${ik}$, no. 6_${ik}$, pp. 737_${ik}$-755, 1997. ! -- 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 - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda, m, n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, m, n ! Array Arguments real(sp), intent(inout) :: a(lda,*) real(sp), intent(out) :: d(*) @@ -2929,93 +2931,93 @@ module stdlib_linalg_lapack_s ! Local Scalars real(sp) :: sfmin - integer(ilp) :: i, iinfo, n1, n2 + integer(${ik}$) :: i, iinfo, n1, n2 ! Intrinsic Functions intrinsic :: abs,sign,max,min ! Executable Statements ! test the input parameters - info = 0 - if( m<0 ) then - info = -1 - else if( n<0 ) then - info = -2 - else if( lda= sfmin ) then - call stdlib_sscal( m-1, one / a( 1, 1 ), a( 2, 1 ), 1 ) + if( abs( a( 1_${ik}$, 1_${ik}$ ) ) >= sfmin ) then + call stdlib${ii}$_sscal( m-1, one / a( 1_${ik}$, 1_${ik}$ ), a( 2_${ik}$, 1_${ik}$ ), 1_${ik}$ ) else do i = 2, m - a( i, 1 ) = a( i, 1 ) / a( 1, 1 ) + a( i, 1_${ik}$ ) = a( i, 1_${ik}$ ) / a( 1_${ik}$, 1_${ik}$ ) end do end if else ! divide the matrix b into four submatrices - n1 = min( m, n ) / 2 + n1 = min( m, n ) / 2_${ik}$ n2 = n-n1 ! factor b11, recursive call - call stdlib_slaorhr_col_getrfnp2( n1, n1, a, lda, d, iinfo ) + call stdlib${ii}$_slaorhr_col_getrfnp2( n1, n1, a, lda, d, iinfo ) ! solve for b21 - call stdlib_strsm( 'R', 'U', 'N', 'N', m-n1, n1, one, a, lda,a( n1+1, 1 ), lda ) + call stdlib${ii}$_strsm( 'R', 'U', 'N', 'N', m-n1, n1, one, a, lda,a( n1+1, 1_${ik}$ ), lda ) ! solve for b12 - call stdlib_strsm( 'L', 'L', 'N', 'U', n1, n2, one, a, lda,a( 1, n1+1 ), lda ) + call stdlib${ii}$_strsm( 'L', 'L', 'N', 'U', n1, n2, one, a, lda,a( 1_${ik}$, n1+1 ), lda ) ! update b22, i.e. compute the schur complement ! b22 := b22 - b21*b12 - call stdlib_sgemm( 'N', 'N', m-n1, n2, n1, -one, a( n1+1, 1 ), lda,a( 1, n1+1 ), & + call stdlib${ii}$_sgemm( 'N', 'N', m-n1, n2, n1, -one, a( n1+1, 1_${ik}$ ), lda,a( 1_${ik}$, n1+1 ), & lda, one, a( n1+1, n1+1 ), lda ) ! factor b22, recursive call - call stdlib_slaorhr_col_getrfnp2( m-n1, n2, a( n1+1, n1+1 ), lda,d( n1+1 ), iinfo ) + call stdlib${ii}$_slaorhr_col_getrfnp2( m-n1, n2, a( n1+1, n1+1 ), lda,d( n1+1 ), iinfo ) end if return - end subroutine stdlib_slaorhr_col_getrfnp2 + end subroutine stdlib${ii}$_slaorhr_col_getrfnp2 - pure subroutine stdlib_slapmr( forwrd, m, n, x, ldx, k ) + pure subroutine stdlib${ii}$_slapmr( forwrd, m, n, x, ldx, k ) !! SLAPMR 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. + !! by the permutation K(1_${ik}$),K(2_${ik}$),...,K(M) of the integers 1_${ik}$,...,M. !! If FORWRD = .TRUE., forward permutation: - !! X(K(I),*) is moved X(I,*) for I = 1,2,...,M. + !! X(K(I),*) is moved X(I,*) for I = 1_${ik}$,2_${ik}$,...,M. !! If FORWRD = .FALSE., backward permutation: - !! X(I,*) is moved to X(K(I),*) for I = 1,2,...,M. + !! X(I,*) is moved to X(K(I),*) for I = 1_${ik}$,2_${ik}$,...,M. ! -- 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 logical(lk), intent(in) :: forwrd - integer(ilp), intent(in) :: ldx, m, n + integer(${ik}$), intent(in) :: ldx, m, n ! Array Arguments - integer(ilp), intent(inout) :: k(*) + integer(${ik}$), intent(inout) :: k(*) real(sp), intent(inout) :: x(ldx,*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, in, j, jj + integer(${ik}$) :: i, in, j, jj real(sp) :: temp ! Executable Statements if( m<=1 )return @@ -3062,28 +3064,28 @@ module stdlib_linalg_lapack_s end do end if return - end subroutine stdlib_slapmr + end subroutine stdlib${ii}$_slapmr - pure subroutine stdlib_slapmt( forwrd, m, n, x, ldx, k ) + pure subroutine stdlib${ii}$_slapmt( forwrd, m, n, x, ldx, k ) !! SLAPMT 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. + !! by the permutation K(1_${ik}$),K(2_${ik}$),...,K(N) of the integers 1_${ik}$,...,N. !! If FORWRD = .TRUE., forward permutation: - !! X(*,K(J)) is moved X(*,J) for J = 1,2,...,N. + !! X(*,K(J)) is moved X(*,J) for J = 1_${ik}$,2_${ik}$,...,N. !! If FORWRD = .FALSE., backward permutation: - !! X(*,J) is moved to X(*,K(J)) for J = 1,2,...,N. + !! X(*,J) is moved to X(*,K(J)) for J = 1_${ik}$,2_${ik}$,...,N. ! -- 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 logical(lk), intent(in) :: forwrd - integer(ilp), intent(in) :: ldx, m, n + integer(${ik}$), intent(in) :: ldx, m, n ! Array Arguments - integer(ilp), intent(inout) :: k(*) + integer(${ik}$), intent(inout) :: k(*) real(sp), intent(inout) :: x(ldx,*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, ii, j, in + integer(${ik}$) :: i, ii, j, in real(sp) :: temp ! Executable Statements if( n<=1 )return @@ -3130,11 +3132,11 @@ module stdlib_linalg_lapack_s end do end if return - end subroutine stdlib_slapmt + end subroutine stdlib${ii}$_slapmt - pure real(sp) function stdlib_slapy3( x, y, z ) - !! SLAPY3 returns sqrt(x**2+y**2+z**2), taking care not to cause + pure real(sp) function stdlib${ii}$_slapy3( x, y, z ) + !! SLAPY3 returns sqrt(x**2_${ik}$+y**2_${ik}$+z**2_${ik}$), taking care not to cause !! unnecessary overflow and unnecessary underflow. ! -- lapack auxiliary routine -- ! -- lapack is a software package provided by univ. of tennessee, -- @@ -3148,24 +3150,24 @@ module stdlib_linalg_lapack_s ! Intrinsic Functions intrinsic :: abs,max,sqrt ! Executable Statements - hugeval = stdlib_slamch( 'OVERFLOW' ) + hugeval = stdlib${ii}$_slamch( 'OVERFLOW' ) xabs = abs( x ) yabs = abs( y ) zabs = abs( z ) w = max( xabs, yabs, zabs ) if( w==zero .or. w>hugeval ) then - ! w can be zero for max(0,nan,0) + ! w can be zero for max(0_${ik}$,nan,0_${ik}$) ! adding all three entries together will make sure ! nan will not disappear. - stdlib_slapy3 = xabs + yabs + zabs + stdlib${ii}$_slapy3 = xabs + yabs + zabs else - stdlib_slapy3 = w*sqrt( ( xabs / w )**2+( yabs / w )**2+( zabs / w )**2 ) + stdlib${ii}$_slapy3 = w*sqrt( ( xabs / w )**2_${ik}$+( yabs / w )**2_${ik}$+( zabs / w )**2_${ik}$ ) end if return - end function stdlib_slapy3 + end function stdlib${ii}$_slapy3 - pure subroutine stdlib_slaqgb( m, n, kl, ku, ab, ldab, r, c, rowcnd, colcnd,amax, equed ) + pure subroutine stdlib${ii}$_slaqgb( m, n, kl, ku, ab, ldab, r, c, rowcnd, colcnd,amax, equed ) !! SLAQGB 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. @@ -3175,7 +3177,7 @@ module stdlib_linalg_lapack_s ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(out) :: equed - integer(ilp), intent(in) :: kl, ku, ldab, m, n + integer(${ik}$), intent(in) :: kl, ku, ldab, m, n real(sp), intent(in) :: amax, colcnd, rowcnd ! Array Arguments real(sp), intent(inout) :: ab(ldab,*) @@ -3185,18 +3187,18 @@ module stdlib_linalg_lapack_s real(sp), parameter :: thresh = 0.1e+0_sp ! Local Scalars - integer(ilp) :: i, j + integer(${ik}$) :: i, j real(sp) :: cj, large, small ! Intrinsic Functions intrinsic :: max,min ! Executable Statements ! quick return if possible - if( m<=0 .or. n<=0 ) then + if( m<=0_${ik}$ .or. n<=0_${ik}$ ) then equed = 'N' return end if ! initialize large and small. - small = stdlib_slamch( 'SAFE MINIMUM' ) / stdlib_slamch( 'PRECISION' ) + small = stdlib${ii}$_slamch( 'SAFE MINIMUM' ) / stdlib${ii}$_slamch( 'PRECISION' ) large = one / small if( rowcnd>=thresh .and. amax>=small .and. amax<=large )then ! no row scaling @@ -3232,10 +3234,10 @@ module stdlib_linalg_lapack_s equed = 'B' end if return - end subroutine stdlib_slaqgb + end subroutine stdlib${ii}$_slaqgb - pure subroutine stdlib_slaqge( m, n, a, lda, r, c, rowcnd, colcnd, amax,equed ) + pure subroutine stdlib${ii}$_slaqge( m, n, a, lda, r, c, rowcnd, colcnd, amax,equed ) !! SLAQGE equilibrates a general M by N matrix A using the row and !! column scaling factors in the vectors R and C. ! -- lapack auxiliary routine -- @@ -3243,7 +3245,7 @@ module stdlib_linalg_lapack_s ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(out) :: equed - integer(ilp), intent(in) :: lda, m, n + integer(${ik}$), intent(in) :: lda, m, n real(sp), intent(in) :: amax, colcnd, rowcnd ! Array Arguments real(sp), intent(inout) :: a(lda,*) @@ -3253,16 +3255,16 @@ module stdlib_linalg_lapack_s real(sp), parameter :: thresh = 0.1e+0_sp ! Local Scalars - integer(ilp) :: i, j + integer(${ik}$) :: i, j real(sp) :: cj, large, small ! Executable Statements ! quick return if possible - if( m<=0 .or. n<=0 ) then + if( m<=0_${ik}$ .or. n<=0_${ik}$ ) then equed = 'N' return end if ! initialize large and small. - small = stdlib_slamch( 'SAFE MINIMUM' ) / stdlib_slamch( 'PRECISION' ) + small = stdlib${ii}$_slamch( 'SAFE MINIMUM' ) / stdlib${ii}$_slamch( 'PRECISION' ) large = one / small if( rowcnd>=thresh .and. amax>=small .and. amax<=large )then ! no row scaling @@ -3298,18 +3300,18 @@ module stdlib_linalg_lapack_s equed = 'B' end if return - end subroutine stdlib_slaqge + end subroutine stdlib${ii}$_slaqge - pure subroutine stdlib_slaqr1( n, h, ldh, sr1, si1, sr2, si2, v ) - !! Given a 2-by-2 or 3-by-3 matrix H, SLAQR1: sets v to a + pure subroutine stdlib${ii}$_slaqr1( n, h, ldh, sr1, si1, sr2, si2, v ) + !! Given a 2_${ik}$-by-2 or 3_${ik}$-by-3 matrix H, SLAQR1: sets v to a !! scalar multiple of the first column of the product !! (*) K = (H - (sr1 + i*si1)*I)*(H - (sr2 + i*si2)*I) !! scaling to avoid overflows and most underflows. It !! is assumed that either - !! 1) sr1 = sr2 and si1 = -si2 + !! 1_${ik}$) sr1 = sr2 and si1 = -si2 !! or - !! 2) si1 = si2 = 0. + !! 2_${ik}$) si1 = si2 = 0. !! This is useful for starting double implicit shift bulges !! in the QR algorithm. ! -- lapack auxiliary routine -- @@ -3317,7 +3319,7 @@ module stdlib_linalg_lapack_s ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments real(sp), intent(in) :: si1, si2, sr1, sr2 - integer(ilp), intent(in) :: ldh, n + integer(${ik}$), intent(in) :: ldh, n ! Array Arguments real(sp), intent(in) :: h(ldh,*) real(sp), intent(out) :: v(*) @@ -3329,39 +3331,39 @@ module stdlib_linalg_lapack_s intrinsic :: abs ! Executable Statements ! quick return if possible - if( n/=2 .and. n/=3 ) then + if( n/=2_${ik}$ .and. n/=3_${ik}$ ) then return end if - if( n==2 ) then - s = abs( h( 1, 1 )-sr2 ) + abs( si2 ) + abs( h( 2, 1 ) ) + if( n==2_${ik}$ ) then + s = abs( h( 1_${ik}$, 1_${ik}$ )-sr2 ) + abs( si2 ) + abs( h( 2_${ik}$, 1_${ik}$ ) ) if( s==zero ) then - v( 1 ) = zero - v( 2 ) = zero + v( 1_${ik}$ ) = zero + v( 2_${ik}$ ) = zero else - h21s = h( 2, 1 ) / s - v( 1 ) = h21s*h( 1, 2 ) + ( h( 1, 1 )-sr1 )*( ( h( 1, 1 )-sr2 ) / s ) - si1*( & + h21s = h( 2_${ik}$, 1_${ik}$ ) / s + v( 1_${ik}$ ) = h21s*h( 1_${ik}$, 2_${ik}$ ) + ( h( 1_${ik}$, 1_${ik}$ )-sr1 )*( ( h( 1_${ik}$, 1_${ik}$ )-sr2 ) / s ) - si1*( & si2 / s ) - v( 2 ) = h21s*( h( 1, 1 )+h( 2, 2 )-sr1-sr2 ) + v( 2_${ik}$ ) = h21s*( h( 1_${ik}$, 1_${ik}$ )+h( 2_${ik}$, 2_${ik}$ )-sr1-sr2 ) end if else - s = abs( h( 1, 1 )-sr2 ) + abs( si2 ) + abs( h( 2, 1 ) ) +abs( h( 3, 1 ) ) + s = abs( h( 1_${ik}$, 1_${ik}$ )-sr2 ) + abs( si2 ) + abs( h( 2_${ik}$, 1_${ik}$ ) ) +abs( h( 3_${ik}$, 1_${ik}$ ) ) if( s==zero ) then - v( 1 ) = zero - v( 2 ) = zero - v( 3 ) = zero + v( 1_${ik}$ ) = zero + v( 2_${ik}$ ) = zero + v( 3_${ik}$ ) = zero else - h21s = h( 2, 1 ) / s - h31s = h( 3, 1 ) / s - v( 1 ) = ( h( 1, 1 )-sr1 )*( ( h( 1, 1 )-sr2 ) / s ) -si1*( si2 / s ) + h( 1, 2 )& - *h21s + h( 1, 3 )*h31s - v( 2 ) = h21s*( h( 1, 1 )+h( 2, 2 )-sr1-sr2 ) +h( 2, 3 )*h31s - v( 3 ) = h31s*( h( 1, 1 )+h( 3, 3 )-sr1-sr2 ) +h21s*h( 3, 2 ) + h21s = h( 2_${ik}$, 1_${ik}$ ) / s + h31s = h( 3_${ik}$, 1_${ik}$ ) / s + v( 1_${ik}$ ) = ( h( 1_${ik}$, 1_${ik}$ )-sr1 )*( ( h( 1_${ik}$, 1_${ik}$ )-sr2 ) / s ) -si1*( si2 / s ) + h( 1_${ik}$, 2_${ik}$ )& + *h21s + h( 1_${ik}$, 3_${ik}$ )*h31s + v( 2_${ik}$ ) = h21s*( h( 1_${ik}$, 1_${ik}$ )+h( 2_${ik}$, 2_${ik}$ )-sr1-sr2 ) +h( 2_${ik}$, 3_${ik}$ )*h31s + v( 3_${ik}$ ) = h31s*( h( 1_${ik}$, 1_${ik}$ )+h( 3_${ik}$, 3_${ik}$ )-sr1-sr2 ) +h21s*h( 3_${ik}$, 2_${ik}$ ) end if end if - end subroutine stdlib_slaqr1 + end subroutine stdlib${ii}$_slaqr1 - pure subroutine stdlib_slaqsb( uplo, n, kd, ab, ldab, s, scond, amax, equed ) + pure subroutine stdlib${ii}$_slaqsb( uplo, n, kd, ab, ldab, s, scond, amax, equed ) !! SLAQSB equilibrates a symmetric band matrix A using the scaling !! factors in the vector S. ! -- lapack auxiliary routine -- @@ -3370,7 +3372,7 @@ module stdlib_linalg_lapack_s ! Scalar Arguments character, intent(out) :: equed character, intent(in) :: uplo - integer(ilp), intent(in) :: kd, ldab, n + integer(${ik}$), intent(in) :: kd, ldab, n real(sp), intent(in) :: amax, scond ! Array Arguments real(sp), intent(inout) :: ab(ldab,*) @@ -3380,18 +3382,18 @@ module stdlib_linalg_lapack_s real(sp), parameter :: thresh = 0.1e+0_sp ! Local Scalars - integer(ilp) :: i, j + integer(${ik}$) :: i, j real(sp) :: cj, large, small ! Intrinsic Functions intrinsic :: max,min ! Executable Statements ! quick return if possible - if( n<=0 ) then + if( n<=0_${ik}$ ) then equed = 'N' return end if ! initialize large and small. - small = stdlib_slamch( 'SAFE MINIMUM' ) / stdlib_slamch( 'PRECISION' ) + small = stdlib${ii}$_slamch( 'SAFE MINIMUM' ) / stdlib${ii}$_slamch( 'PRECISION' ) large = one / small if( scond>=thresh .and. amax>=small .and. amax<=large ) then ! no equilibration @@ -3411,17 +3413,17 @@ module stdlib_linalg_lapack_s do j = 1, n cj = s( j ) do i = j, min( n, j+kd ) - ab( 1+i-j, j ) = cj*s( i )*ab( 1+i-j, j ) + ab( 1_${ik}$+i-j, j ) = cj*s( i )*ab( 1_${ik}$+i-j, j ) end do end do end if equed = 'Y' end if return - end subroutine stdlib_slaqsb + end subroutine stdlib${ii}$_slaqsb - pure subroutine stdlib_slaqsp( uplo, n, ap, s, scond, amax, equed ) + pure subroutine stdlib${ii}$_slaqsp( uplo, n, ap, s, scond, amax, equed ) !! SLAQSP equilibrates a symmetric matrix A using the scaling factors !! in the vector S. ! -- lapack auxiliary routine -- @@ -3430,7 +3432,7 @@ module stdlib_linalg_lapack_s ! Scalar Arguments character, intent(out) :: equed character, intent(in) :: uplo - integer(ilp), intent(in) :: n + integer(${ik}$), intent(in) :: n real(sp), intent(in) :: amax, scond ! Array Arguments real(sp), intent(inout) :: ap(*) @@ -3440,16 +3442,16 @@ module stdlib_linalg_lapack_s real(sp), parameter :: thresh = 0.1e+0_sp ! Local Scalars - integer(ilp) :: i, j, jc + integer(${ik}$) :: i, j, jc real(sp) :: cj, large, small ! Executable Statements ! quick return if possible - if( n<=0 ) then + if( n<=0_${ik}$ ) then equed = 'N' return end if ! initialize large and small. - small = stdlib_slamch( 'SAFE MINIMUM' ) / stdlib_slamch( 'PRECISION' ) + small = stdlib${ii}$_slamch( 'SAFE MINIMUM' ) / stdlib${ii}$_slamch( 'PRECISION' ) large = one / small if( scond>=thresh .and. amax>=small .and. amax<=large ) then ! no equilibration @@ -3458,7 +3460,7 @@ module stdlib_linalg_lapack_s ! replace a by diag(s) * a * diag(s). if( stdlib_lsame( uplo, 'U' ) ) then ! upper triangle of a is stored. - jc = 1 + jc = 1_${ik}$ do j = 1, n cj = s( j ) do i = 1, j @@ -3468,22 +3470,22 @@ module stdlib_linalg_lapack_s end do else ! lower triangle of a is stored. - jc = 1 + jc = 1_${ik}$ do j = 1, n cj = s( j ) do i = j, n ap( jc+i-j ) = cj*s( i )*ap( jc+i-j ) end do - jc = jc + n - j + 1 + jc = jc + n - j + 1_${ik}$ end do end if equed = 'Y' end if return - end subroutine stdlib_slaqsp + end subroutine stdlib${ii}$_slaqsp - pure subroutine stdlib_slaqsy( uplo, n, a, lda, s, scond, amax, equed ) + pure subroutine stdlib${ii}$_slaqsy( uplo, n, a, lda, s, scond, amax, equed ) !! SLAQSY equilibrates a symmetric matrix A using the scaling factors !! in the vector S. ! -- lapack auxiliary routine -- @@ -3492,7 +3494,7 @@ module stdlib_linalg_lapack_s ! Scalar Arguments character, intent(out) :: equed character, intent(in) :: uplo - integer(ilp), intent(in) :: lda, n + integer(${ik}$), intent(in) :: lda, n real(sp), intent(in) :: amax, scond ! Array Arguments real(sp), intent(inout) :: a(lda,*) @@ -3502,16 +3504,16 @@ module stdlib_linalg_lapack_s real(sp), parameter :: thresh = 0.1e+0_sp ! Local Scalars - integer(ilp) :: i, j + integer(${ik}$) :: i, j real(sp) :: cj, large, small ! Executable Statements ! quick return if possible - if( n<=0 ) then + if( n<=0_${ik}$ ) then equed = 'N' return end if ! initialize large and small. - small = stdlib_slamch( 'SAFE MINIMUM' ) / stdlib_slamch( 'PRECISION' ) + small = stdlib${ii}$_slamch( 'SAFE MINIMUM' ) / stdlib${ii}$_slamch( 'PRECISION' ) large = one / small if( scond>=thresh .and. amax>=small .and. amax<=large ) then ! no equilibration @@ -3538,30 +3540,30 @@ module stdlib_linalg_lapack_s equed = 'Y' end if return - end subroutine stdlib_slaqsy + end subroutine stdlib${ii}$_slaqsy - pure subroutine stdlib_slar2v( n, x, y, z, incx, c, s, incc ) + pure subroutine stdlib${ii}$_slar2v( n, x, y, z, incx, c, s, incc ) !! SLAR2V 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 + !! a sequence of 2_${ik}$-by-2 real symmetric matrices, defined by the elements + !! of the vectors x, y and z. For i = 1_${ik}$,2_${ik}$,...,n !! ( x(i) z(i) ) := ( c(i) s(i) ) ( x(i) z(i) ) ( c(i) -s(i) ) !! ( z(i) y(i) ) ( -s(i) c(i) ) ( z(i) y(i) ) ( s(i) c(i) ) ! -- 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) :: incc, incx, n + integer(${ik}$), intent(in) :: incc, incx, n ! Array Arguments real(sp), intent(in) :: c(*), s(*) real(sp), intent(inout) :: x(*), y(*), z(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, ic, ix + integer(${ik}$) :: i, ic, ix real(sp) :: ci, si, t1, t2, t3, t4, t5, t6, xi, yi, zi ! Executable Statements - ix = 1 - ic = 1 + ix = 1_${ik}$ + ic = 1_${ik}$ do i = 1, n xi = x( ix ) yi = y( ix ) @@ -3581,21 +3583,21 @@ module stdlib_linalg_lapack_s ic = ic + incc end do return - end subroutine stdlib_slar2v + end subroutine stdlib${ii}$_slar2v - pure subroutine stdlib_slarf( side, m, n, v, incv, tau, c, ldc, work ) + pure subroutine stdlib${ii}$_slarf( side, m, n, v, incv, tau, c, ldc, work ) !! SLARF 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 !! where tau is a real scalar and v is a real vector. - !! If tau = 0, then H is taken to be the unit matrix. + !! If tau = 0_${ik}$, then H is taken to be the unit matrix. ! -- 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 character, intent(in) :: side - integer(ilp), intent(in) :: incv, ldc, m, n + integer(${ik}$), intent(in) :: incv, ldc, m, n real(sp), intent(in) :: tau ! Array Arguments real(sp), intent(inout) :: c(ldc,*) @@ -3605,11 +3607,11 @@ module stdlib_linalg_lapack_s ! Local Scalars logical(lk) :: applyleft - integer(ilp) :: i, lastv, lastc + integer(${ik}$) :: i, lastv, lastc ! Executable Statements applyleft = stdlib_lsame( side, 'L' ) - lastv = 0 - lastc = 0 + lastv = 0_${ik}$ + lastc = 0_${ik}$ if( tau/=zero ) then ! set up variables for scanning v. lastv begins pointing to the end ! of v. @@ -3618,50 +3620,50 @@ module stdlib_linalg_lapack_s else lastv = n end if - if( incv>0 ) then - i = 1 + (lastv-1) * incv + if( incv>0_${ik}$ ) then + i = 1_${ik}$ + (lastv-1) * incv else - i = 1 + i = 1_${ik}$ end if ! look for the last non-zero row in v. do while( lastv>0 .and. v( i )==zero ) - lastv = lastv - 1 + lastv = lastv - 1_${ik}$ i = i - incv end do if( applyleft ) then - ! scan for the last non-zero column in c(1:lastv,:). - lastc = stdlib_ilaslc(lastv, n, c, ldc) + ! scan for the last non-zero column in c(1_${ik}$:lastv,:). + lastc = stdlib${ii}$_ilaslc(lastv, n, c, ldc) else - ! scan for the last non-zero row in c(:,1:lastv). - lastc = stdlib_ilaslr(m, lastv, c, ldc) + ! scan for the last non-zero row in c(:,1_${ik}$:lastv). + lastc = stdlib${ii}$_ilaslr(m, lastv, c, ldc) end if end if ! note that lastc.eq.0_sp 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_sgemv( 'TRANSPOSE', lastv, lastc, one, c, ldc, v, incv,zero, work, 1 & + if( lastv>0_${ik}$ ) then + ! w(1_${ik}$:lastc,1_${ik}$) := c(1_${ik}$:lastv,1_${ik}$:lastc)**t * v(1_${ik}$:lastv,1_${ik}$) + call stdlib${ii}$_sgemv( 'TRANSPOSE', lastv, lastc, one, c, ldc, v, incv,zero, work, 1_${ik}$ & ) - ! c(1:lastv,1:lastc) := c(...) - v(1:lastv,1) * w(1:lastc,1)**t - call stdlib_sger( lastv, lastc, -tau, v, incv, work, 1, c, ldc ) + ! c(1_${ik}$:lastv,1_${ik}$:lastc) := c(...) - v(1_${ik}$:lastv,1_${ik}$) * w(1_${ik}$:lastc,1_${ik}$)**t + call stdlib${ii}$_sger( lastv, lastc, -tau, v, incv, work, 1_${ik}$, 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_sgemv( '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_sger( lastc, lastv, -tau, work, 1, v, incv, c, ldc ) + if( lastv>0_${ik}$ ) then + ! w(1_${ik}$:lastc,1_${ik}$) := c(1_${ik}$:lastc,1_${ik}$:lastv) * v(1_${ik}$:lastv,1_${ik}$) + call stdlib${ii}$_sgemv( 'NO TRANSPOSE', lastc, lastv, one, c, ldc,v, incv, zero, work,& + 1_${ik}$ ) + ! c(1_${ik}$:lastc,1_${ik}$:lastv) := c(...) - w(1_${ik}$:lastc,1_${ik}$) * v(1_${ik}$:lastv,1_${ik}$)**t + call stdlib${ii}$_sger( lastc, lastv, -tau, work, 1_${ik}$, v, incv, c, ldc ) end if end if return - end subroutine stdlib_slarf + end subroutine stdlib${ii}$_slarf - pure subroutine stdlib_slarfb( side, trans, direct, storev, m, n, k, v, ldv,t, ldt, c, ldc, & + pure subroutine stdlib${ii}$_slarfb( side, trans, direct, storev, m, n, k, v, ldv,t, ldt, c, ldc, & !! SLARFB 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 ) @@ -3670,7 +3672,7 @@ module stdlib_linalg_lapack_s ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: direct, side, storev, trans - integer(ilp), intent(in) :: k, ldc, ldt, ldv, ldwork, m, n + integer(${ik}$), intent(in) :: k, ldc, ldt, ldv, ldwork, m, n ! Array Arguments real(sp), intent(inout) :: c(ldc,*) real(sp), intent(in) :: t(ldt,*), v(ldv,*) @@ -3679,7 +3681,7 @@ module stdlib_linalg_lapack_s ! Local Scalars character :: transt - integer(ilp) :: i, j + integer(${ik}$) :: i, j ! Executable Statements ! quick return if possible if( m<=0 .or. n<=0 )return @@ -3699,27 +3701,27 @@ module stdlib_linalg_lapack_s ! w := c**t * v = (c1**t * v1 + c2**t * v2) (stored in work) ! w := c1**t do j = 1, k - call stdlib_scopy( n, c( j, 1 ), ldc, work( 1, j ), 1 ) + call stdlib${ii}$_scopy( n, c( j, 1_${ik}$ ), ldc, work( 1_${ik}$, j ), 1_${ik}$ ) end do ! w := w * v1 - call stdlib_strmm( 'RIGHT', 'LOWER', 'NO TRANSPOSE', 'UNIT', n,k, one, v, ldv,& + call stdlib${ii}$_strmm( 'RIGHT', 'LOWER', 'NO TRANSPOSE', 'UNIT', n,k, one, v, ldv,& work, ldwork ) if( m>k ) then ! w := w + c2**t * v2 - call stdlib_sgemm( 'TRANSPOSE', 'NO TRANSPOSE', n, k, m-k,one, c( k+1, 1 ),& - ldc, v( k+1, 1 ), ldv,one, work, ldwork ) + call stdlib${ii}$_sgemm( 'TRANSPOSE', 'NO TRANSPOSE', n, k, m-k,one, c( k+1, 1_${ik}$ ),& + ldc, v( k+1, 1_${ik}$ ), ldv,one, work, ldwork ) end if ! w := w * t**t or w * t - call stdlib_strmm( 'RIGHT', 'UPPER', transt, 'NON-UNIT', n, k,one, t, ldt, & + call stdlib${ii}$_strmm( '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_sgemm( 'NO TRANSPOSE', 'TRANSPOSE', m-k, n, k,-one, v( k+1, 1 )& - , ldv, work, ldwork, one,c( k+1, 1 ), ldc ) + call stdlib${ii}$_sgemm( 'NO TRANSPOSE', 'TRANSPOSE', m-k, n, k,-one, v( k+1, 1_${ik}$ )& + , ldv, work, ldwork, one,c( k+1, 1_${ik}$ ), ldc ) end if ! w := w * v1**t - call stdlib_strmm( 'RIGHT', 'LOWER', 'TRANSPOSE', 'UNIT', n, k,one, v, ldv, & + call stdlib${ii}$_strmm( 'RIGHT', 'LOWER', 'TRANSPOSE', 'UNIT', n, k,one, v, ldv, & work, ldwork ) ! c1 := c1 - w**t do j = 1, k @@ -3732,27 +3734,27 @@ module stdlib_linalg_lapack_s ! w := c * v = (c1*v1 + c2*v2) (stored in work) ! w := c1 do j = 1, k - call stdlib_scopy( m, c( 1, j ), 1, work( 1, j ), 1 ) + call stdlib${ii}$_scopy( m, c( 1_${ik}$, j ), 1_${ik}$, work( 1_${ik}$, j ), 1_${ik}$ ) end do ! w := w * v1 - call stdlib_strmm( 'RIGHT', 'LOWER', 'NO TRANSPOSE', 'UNIT', m,k, one, v, ldv,& + call stdlib${ii}$_strmm( 'RIGHT', 'LOWER', 'NO TRANSPOSE', 'UNIT', m,k, one, v, ldv,& work, ldwork ) if( n>k ) then ! w := w + c2 * v2 - call stdlib_sgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', m, k, n-k,one, c( 1, k+& - 1 ), ldc, v( k+1, 1 ), ldv,one, work, ldwork ) + call stdlib${ii}$_sgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', m, k, n-k,one, c( 1_${ik}$, k+& + 1_${ik}$ ), ldc, v( k+1, 1_${ik}$ ), ldv,one, work, ldwork ) end if ! w := w * t or w * t**t - call stdlib_strmm( 'RIGHT', 'UPPER', trans, 'NON-UNIT', m, k,one, t, ldt, & + call stdlib${ii}$_strmm( '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_sgemm( 'NO TRANSPOSE', 'TRANSPOSE', m, n-k, k,-one, work, & - ldwork, v( k+1, 1 ), ldv, one,c( 1, k+1 ), ldc ) + call stdlib${ii}$_sgemm( 'NO TRANSPOSE', 'TRANSPOSE', m, n-k, k,-one, work, & + ldwork, v( k+1, 1_${ik}$ ), ldv, one,c( 1_${ik}$, k+1 ), ldc ) end if ! w := w * v1**t - call stdlib_strmm( 'RIGHT', 'LOWER', 'TRANSPOSE', 'UNIT', m, k,one, v, ldv, & + call stdlib${ii}$_strmm( 'RIGHT', 'LOWER', 'TRANSPOSE', 'UNIT', m, k,one, v, ldv, & work, ldwork ) ! c1 := c1 - w do j = 1, k @@ -3771,28 +3773,28 @@ module stdlib_linalg_lapack_s ! w := c**t * v = (c1**t * v1 + c2**t * v2) (stored in work) ! w := c2**t do j = 1, k - call stdlib_scopy( n, c( m-k+j, 1 ), ldc, work( 1, j ), 1 ) + call stdlib${ii}$_scopy( n, c( m-k+j, 1_${ik}$ ), ldc, work( 1_${ik}$, j ), 1_${ik}$ ) end do ! w := w * v2 - call stdlib_strmm( 'RIGHT', 'UPPER', 'NO TRANSPOSE', 'UNIT', n,k, one, v( m-k+& - 1, 1 ), ldv, work, ldwork ) + call stdlib${ii}$_strmm( 'RIGHT', 'UPPER', 'NO TRANSPOSE', 'UNIT', n,k, one, v( m-k+& + 1_${ik}$, 1_${ik}$ ), ldv, work, ldwork ) if( m>k ) then ! w := w + c1**t * v1 - call stdlib_sgemm( 'TRANSPOSE', 'NO TRANSPOSE', n, k, m-k,one, c, ldc, v, & + call stdlib${ii}$_sgemm( '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_strmm( 'RIGHT', 'LOWER', transt, 'NON-UNIT', n, k,one, t, ldt, & + call stdlib${ii}$_strmm( '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_sgemm( 'NO TRANSPOSE', 'TRANSPOSE', m-k, n, k,-one, v, ldv, & + call stdlib${ii}$_sgemm( 'NO TRANSPOSE', 'TRANSPOSE', m-k, n, k,-one, v, ldv, & work, ldwork, one, c, ldc ) end if ! w := w * v2**t - call stdlib_strmm( 'RIGHT', 'UPPER', 'TRANSPOSE', 'UNIT', n, k,one, v( m-k+1, & - 1 ), ldv, work, ldwork ) + call stdlib${ii}$_strmm( 'RIGHT', 'UPPER', 'TRANSPOSE', 'UNIT', n, k,one, v( m-k+1, & + 1_${ik}$ ), ldv, work, ldwork ) ! c2 := c2 - w**t do j = 1, k do i = 1, n @@ -3804,28 +3806,28 @@ module stdlib_linalg_lapack_s ! w := c * v = (c1*v1 + c2*v2) (stored in work) ! w := c2 do j = 1, k - call stdlib_scopy( m, c( 1, n-k+j ), 1, work( 1, j ), 1 ) + call stdlib${ii}$_scopy( m, c( 1_${ik}$, n-k+j ), 1_${ik}$, work( 1_${ik}$, j ), 1_${ik}$ ) end do ! w := w * v2 - call stdlib_strmm( 'RIGHT', 'UPPER', 'NO TRANSPOSE', 'UNIT', m,k, one, v( n-k+& - 1, 1 ), ldv, work, ldwork ) + call stdlib${ii}$_strmm( 'RIGHT', 'UPPER', 'NO TRANSPOSE', 'UNIT', m,k, one, v( n-k+& + 1_${ik}$, 1_${ik}$ ), ldv, work, ldwork ) if( n>k ) then ! w := w + c1 * v1 - call stdlib_sgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', m, k, n-k,one, c, ldc, & + call stdlib${ii}$_sgemm( '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_strmm( 'RIGHT', 'LOWER', trans, 'NON-UNIT', m, k,one, t, ldt, & + call stdlib${ii}$_strmm( '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_sgemm( 'NO TRANSPOSE', 'TRANSPOSE', m, n-k, k,-one, work, & + call stdlib${ii}$_sgemm( 'NO TRANSPOSE', 'TRANSPOSE', m, n-k, k,-one, work, & ldwork, v, ldv, one, c, ldc ) end if ! w := w * v2**t - call stdlib_strmm( 'RIGHT', 'UPPER', 'TRANSPOSE', 'UNIT', m, k,one, v( n-k+1, & - 1 ), ldv, work, ldwork ) + call stdlib${ii}$_strmm( 'RIGHT', 'UPPER', 'TRANSPOSE', 'UNIT', m, k,one, v( n-k+1, & + 1_${ik}$ ), ldv, work, ldwork ) ! c2 := c2 - w do j = 1, k do i = 1, m @@ -3844,27 +3846,27 @@ module stdlib_linalg_lapack_s ! 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_scopy( n, c( j, 1 ), ldc, work( 1, j ), 1 ) + call stdlib${ii}$_scopy( n, c( j, 1_${ik}$ ), ldc, work( 1_${ik}$, j ), 1_${ik}$ ) end do ! w := w * v1**t - call stdlib_strmm( 'RIGHT', 'UPPER', 'TRANSPOSE', 'UNIT', n, k,one, v, ldv, & + call stdlib${ii}$_strmm( 'RIGHT', 'UPPER', 'TRANSPOSE', 'UNIT', n, k,one, v, ldv, & work, ldwork ) if( m>k ) then ! w := w + c2**t * v2**t - call stdlib_sgemm( 'TRANSPOSE', 'TRANSPOSE', n, k, m-k, one,c( k+1, 1 ), & - ldc, v( 1, k+1 ), ldv, one,work, ldwork ) + call stdlib${ii}$_sgemm( 'TRANSPOSE', 'TRANSPOSE', n, k, m-k, one,c( k+1, 1_${ik}$ ), & + ldc, v( 1_${ik}$, k+1 ), ldv, one,work, ldwork ) end if ! w := w * t**t or w * t - call stdlib_strmm( 'RIGHT', 'UPPER', transt, 'NON-UNIT', n, k,one, t, ldt, & + call stdlib${ii}$_strmm( '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_sgemm( 'TRANSPOSE', 'TRANSPOSE', m-k, n, k, -one,v( 1, k+1 ), & - ldv, work, ldwork, one,c( k+1, 1 ), ldc ) + call stdlib${ii}$_sgemm( 'TRANSPOSE', 'TRANSPOSE', m-k, n, k, -one,v( 1_${ik}$, k+1 ), & + ldv, work, ldwork, one,c( k+1, 1_${ik}$ ), ldc ) end if ! w := w * v1 - call stdlib_strmm( 'RIGHT', 'UPPER', 'NO TRANSPOSE', 'UNIT', n,k, one, v, ldv,& + call stdlib${ii}$_strmm( 'RIGHT', 'UPPER', 'NO TRANSPOSE', 'UNIT', n,k, one, v, ldv,& work, ldwork ) ! c1 := c1 - w**t do j = 1, k @@ -3877,27 +3879,27 @@ module stdlib_linalg_lapack_s ! w := c * v**t = (c1*v1**t + c2*v2**t) (stored in work) ! w := c1 do j = 1, k - call stdlib_scopy( m, c( 1, j ), 1, work( 1, j ), 1 ) + call stdlib${ii}$_scopy( m, c( 1_${ik}$, j ), 1_${ik}$, work( 1_${ik}$, j ), 1_${ik}$ ) end do ! w := w * v1**t - call stdlib_strmm( 'RIGHT', 'UPPER', 'TRANSPOSE', 'UNIT', m, k,one, v, ldv, & + call stdlib${ii}$_strmm( 'RIGHT', 'UPPER', 'TRANSPOSE', 'UNIT', m, k,one, v, ldv, & work, ldwork ) if( n>k ) then ! w := w + c2 * v2**t - call stdlib_sgemm( 'NO TRANSPOSE', 'TRANSPOSE', m, k, n-k,one, c( 1, k+1 ),& - ldc, v( 1, k+1 ), ldv,one, work, ldwork ) + call stdlib${ii}$_sgemm( 'NO TRANSPOSE', 'TRANSPOSE', m, k, n-k,one, c( 1_${ik}$, k+1 ),& + ldc, v( 1_${ik}$, k+1 ), ldv,one, work, ldwork ) end if ! w := w * t or w * t**t - call stdlib_strmm( 'RIGHT', 'UPPER', trans, 'NON-UNIT', m, k,one, t, ldt, & + call stdlib${ii}$_strmm( '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_sgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', m, n-k, k,-one, work, & - ldwork, v( 1, k+1 ), ldv, one,c( 1, k+1 ), ldc ) + call stdlib${ii}$_sgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', m, n-k, k,-one, work, & + ldwork, v( 1_${ik}$, k+1 ), ldv, one,c( 1_${ik}$, k+1 ), ldc ) end if ! w := w * v1 - call stdlib_strmm( 'RIGHT', 'UPPER', 'NO TRANSPOSE', 'UNIT', m,k, one, v, ldv,& + call stdlib${ii}$_strmm( 'RIGHT', 'UPPER', 'NO TRANSPOSE', 'UNIT', m,k, one, v, ldv,& work, ldwork ) ! c1 := c1 - w do j = 1, k @@ -3915,27 +3917,27 @@ module stdlib_linalg_lapack_s ! 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_scopy( n, c( m-k+j, 1 ), ldc, work( 1, j ), 1 ) + call stdlib${ii}$_scopy( n, c( m-k+j, 1_${ik}$ ), ldc, work( 1_${ik}$, j ), 1_${ik}$ ) end do ! w := w * v2**t - call stdlib_strmm( 'RIGHT', 'LOWER', 'TRANSPOSE', 'UNIT', n, k,one, v( 1, m-k+& - 1 ), ldv, work, ldwork ) + call stdlib${ii}$_strmm( 'RIGHT', 'LOWER', 'TRANSPOSE', 'UNIT', n, k,one, v( 1_${ik}$, m-k+& + 1_${ik}$ ), ldv, work, ldwork ) if( m>k ) then ! w := w + c1**t * v1**t - call stdlib_sgemm( 'TRANSPOSE', 'TRANSPOSE', n, k, m-k, one,c, ldc, v, ldv,& + call stdlib${ii}$_sgemm( '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_strmm( 'RIGHT', 'LOWER', transt, 'NON-UNIT', n, k,one, t, ldt, & + call stdlib${ii}$_strmm( '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_sgemm( 'TRANSPOSE', 'TRANSPOSE', m-k, n, k, -one,v, ldv, work, & + call stdlib${ii}$_sgemm( 'TRANSPOSE', 'TRANSPOSE', m-k, n, k, -one,v, ldv, work, & ldwork, one, c, ldc ) end if ! w := w * v2 - call stdlib_strmm( 'RIGHT', 'LOWER', 'NO TRANSPOSE', 'UNIT', n,k, one, v( 1, & + call stdlib${ii}$_strmm( 'RIGHT', 'LOWER', 'NO TRANSPOSE', 'UNIT', n,k, one, v( 1_${ik}$, & m-k+1 ), ldv, work, ldwork ) ! c2 := c2 - w**t do j = 1, k @@ -3948,27 +3950,27 @@ module stdlib_linalg_lapack_s ! w := c * v**t = (c1*v1**t + c2*v2**t) (stored in work) ! w := c2 do j = 1, k - call stdlib_scopy( m, c( 1, n-k+j ), 1, work( 1, j ), 1 ) + call stdlib${ii}$_scopy( m, c( 1_${ik}$, n-k+j ), 1_${ik}$, work( 1_${ik}$, j ), 1_${ik}$ ) end do ! w := w * v2**t - call stdlib_strmm( 'RIGHT', 'LOWER', 'TRANSPOSE', 'UNIT', m, k,one, v( 1, n-k+& - 1 ), ldv, work, ldwork ) + call stdlib${ii}$_strmm( 'RIGHT', 'LOWER', 'TRANSPOSE', 'UNIT', m, k,one, v( 1_${ik}$, n-k+& + 1_${ik}$ ), ldv, work, ldwork ) if( n>k ) then ! w := w + c1 * v1**t - call stdlib_sgemm( 'NO TRANSPOSE', 'TRANSPOSE', m, k, n-k,one, c, ldc, v, & + call stdlib${ii}$_sgemm( '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_strmm( 'RIGHT', 'LOWER', trans, 'NON-UNIT', m, k,one, t, ldt, & + call stdlib${ii}$_strmm( '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_sgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', m, n-k, k,-one, work, & + call stdlib${ii}$_sgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', m, n-k, k,-one, work, & ldwork, v, ldv, one, c, ldc ) end if ! w := w * v2 - call stdlib_strmm( 'RIGHT', 'LOWER', 'NO TRANSPOSE', 'UNIT', m,k, one, v( 1, & + call stdlib${ii}$_strmm( 'RIGHT', 'LOWER', 'NO TRANSPOSE', 'UNIT', m,k, one, v( 1_${ik}$, & n-k+1 ), ldv, work, ldwork ) ! c1 := c1 - w do j = 1, k @@ -3980,10 +3982,10 @@ module stdlib_linalg_lapack_s end if end if return - end subroutine stdlib_slarfb + end subroutine stdlib${ii}$_slarfb - pure subroutine stdlib_slarfb_gett( ident, m, n, k, t, ldt, a, lda, b, ldb,work, ldwork ) + pure subroutine stdlib${ii}$_slarfb_gett( ident, m, n, k, t, ldt, a, lda, b, ldb,work, ldwork ) !! SLARFB_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 @@ -3997,7 +3999,7 @@ module stdlib_linalg_lapack_s ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: ident - integer(ilp), intent(in) :: k, lda, ldb, ldt, ldwork, m, n + integer(${ik}$), intent(in) :: k, lda, ldb, ldt, ldwork, m, n ! Array Arguments real(sp), intent(inout) :: a(lda,*), b(ldb,*) real(sp), intent(in) :: t(ldt,*) @@ -4006,51 +4008,51 @@ module stdlib_linalg_lapack_s ! Local Scalars logical(lk) :: lnotident - integer(ilp) :: i, j + integer(${ik}$) :: i, j ! Executable Statements ! quick return if possible if( m<0 .or. n<=0 .or. k==0 .or. k>n )return lnotident = .not.stdlib_lsame( ident, 'I' ) ! ------------------------------------------------------------------ - ! first step. computation of the column block 2: + ! first step. computation of the column block 2_${ik}$: ! ( a2 ) := h * ( a2 ) ! ( b2 ) ( b2 ) ! ------------------------------------------------------------------ if( n>k ) then - ! 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. + ! col2_(1_${ik}$) compute w2: = a2. therefore, copy a2 = a(1_${ik}$:k, k+1:n) + ! into w2=work(1_${ik}$:k, 1_${ik}$:n-k) column-by-column. do j = 1, n-k - call stdlib_scopy( k, a( 1, k+j ), 1, work( 1, j ), 1 ) + call stdlib${ii}$_scopy( k, a( 1_${ik}$, k+j ), 1_${ik}$, work( 1_${ik}$, j ), 1_${ik}$ ) end do if( lnotident ) then - ! col2_(2) compute w2: = (v1**t) * w2 = (a1**t) * w2, + ! col2_(2_${ik}$) 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_strmm( 'L', 'L', 'T', 'U', k, n-k, one, a, lda,work, ldwork ) + call stdlib${ii}$_strmm( '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 + ! col2_(3_${ik}$) compute w2: = w2 + (v2**t) * b2 = w2 + (b1**t) * b2 ! v2 stored in b1. - if( m>0 ) then - call stdlib_sgemm( 'T', 'N', k, n-k, m, one, b, ldb,b( 1, k+1 ), ldb, one, work, & + if( m>0_${ik}$ ) then + call stdlib${ii}$_sgemm( 'T', 'N', k, n-k, m, one, b, ldb,b( 1_${ik}$, k+1 ), ldb, one, work, & ldwork ) end if - ! col2_(4) compute w2: = t * w2, + ! col2_(4_${ik}$) compute w2: = t * w2, ! t is upper-triangular. - call stdlib_strmm( 'L', 'U', 'N', 'N', k, n-k, one, t, ldt,work, ldwork ) - ! col2_(5) compute b2: = b2 - v2 * w2 = b2 - b1 * w2, + call stdlib${ii}$_strmm( 'L', 'U', 'N', 'N', k, n-k, one, t, ldt,work, ldwork ) + ! col2_(5_${ik}$) compute b2: = b2 - v2 * w2 = b2 - b1 * w2, ! v2 stored in b1. - if( m>0 ) then - call stdlib_sgemm( 'N', 'N', m, n-k, k, -one, b, ldb,work, ldwork, one, b( 1, k+& - 1 ), ldb ) + if( m>0_${ik}$ ) then + call stdlib${ii}$_sgemm( 'N', 'N', m, n-k, k, -one, b, ldb,work, ldwork, one, b( 1_${ik}$, k+& + 1_${ik}$ ), ldb ) end if if( lnotident ) then - ! col2_(6) compute w2: = v1 * w2 = a1 * w2, + ! col2_(6_${ik}$) 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_strmm( 'L', 'L', 'N', 'U', k, n-k, one, a, lda,work, ldwork ) + call stdlib${ii}$_strmm( '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), + ! col2_(7_${ik}$) compute a2: = a2 - w2 = + ! = a(1_${ik}$:k, k+1:n-k) - work(1_${ik}$:k, 1_${ik}$:n-k), ! column-by-column. do j = 1, n-k do i = 1, k @@ -4059,15 +4061,15 @@ module stdlib_linalg_lapack_s end do end if ! ------------------------------------------------------------------ - ! second step. computation of the column block 1: + ! second step. computation of the column block 1_${ik}$: ! ( a1 ) := h * ( a1 ) - ! ( b1 ) ( 0 ) + ! ( b1 ) ( 0_${ik}$ ) ! ------------------------------------------------------------------ - ! col1_(1) compute w1: = a1. copy the upper-triangular - ! a1 = a(1:k, 1:k) into the upper-triangular - ! w1 = work(1:k, 1:k) column-by-column. + ! col1_(1_${ik}$) compute w1: = a1. copy the upper-triangular + ! a1 = a(1_${ik}$:k, 1_${ik}$:k) into the upper-triangular + ! w1 = work(1_${ik}$:k, 1_${ik}$:k) column-by-column. do j = 1, k - call stdlib_scopy( j, a( 1, j ), 1, work( 1, j ), 1 ) + call stdlib${ii}$_scopy( j, a( 1_${ik}$, j ), 1_${ik}$, work( 1_${ik}$, j ), 1_${ik}$ ) end do ! set the subdiagonal elements of w1 to zero column-by-column. do j = 1, k - 1 @@ -4076,55 +4078,55 @@ module stdlib_linalg_lapack_s end do end do if( lnotident ) then - ! col1_(2) compute w1: = (v1**t) * w1 = (a1**t) * w1, + ! col1_(2_${ik}$) compute w1: = (v1**t) * w1 = (a1**t) * w1, ! 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_strmm( 'L', 'L', 'T', 'U', k, k, one, a, lda,work, ldwork ) + call stdlib${ii}$_strmm( 'L', 'L', 'T', 'U', k, k, one, a, lda,work, ldwork ) end if - ! col1_(3) compute w1: = t * w1, + ! col1_(3_${ik}$) compute w1: = t * w1, ! t is upper-triangular, ! w1 is upper-triangular with zeroes below the diagonal. - call stdlib_strmm( 'L', 'U', 'N', 'N', k, k, one, t, ldt,work, ldwork ) - ! col1_(4) compute b1: = - v2 * w1 = - b1 * w1, + call stdlib${ii}$_strmm( 'L', 'U', 'N', 'N', k, k, one, t, ldt,work, ldwork ) + ! col1_(4_${ik}$) compute b1: = - v2 * w1 = - b1 * w1, ! v2 = b1, w1 is upper-triangular with zeroes below the diagonal. - if( m>0 ) then - call stdlib_strmm( 'R', 'U', 'N', 'N', m, k, -one, work, ldwork,b, ldb ) + if( m>0_${ik}$ ) then + call stdlib${ii}$_strmm( 'R', 'U', 'N', 'N', m, k, -one, work, ldwork,b, ldb ) end if if( lnotident ) then - ! col1_(5) compute w1: = v1 * w1 = a1 * w1, + ! col1_(5_${ik}$) compute w1: = v1 * w1 = a1 * w1, ! v1 is not an identity matrix, but unit lower-triangular ! 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_strmm( '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) + call stdlib${ii}$_strmm( 'L', 'L', 'N', 'U', k, k, one, a, lda,work, ldwork ) + ! col1_(6_${ik}$) compute a1: = a1 - w1 = a(1_${ik}$:k, 1_${ik}$:k) - work(1_${ik}$:k, 1_${ik}$:k) ! column-by-column. a1 is upper-triangular on input. ! if ident, a1 is square on output, and w1 is square, ! if not ident, a1 is upper-triangular on output, ! w1 is upper-triangular. - ! col1_(6)_a compute elements of a1 below the diagonal. + ! col1_(6_${ik}$)_a compute elements of a1 below the diagonal. do j = 1, k - 1 do i = j + 1, k a( i, j ) = - work( i, j ) end do end do end if - ! col1_(6)_b compute elements of a1 on and above the diagonal. + ! col1_(6_${ik}$)_b compute elements of a1 on and above the diagonal. do j = 1, k do i = 1, j a( i, j ) = a( i, j ) - work( i, j ) end do end do return - end subroutine stdlib_slarfb_gett + end subroutine stdlib${ii}$_slarfb_gett - pure subroutine stdlib_slarft( direct, storev, n, k, v, ldv, tau, t, ldt ) + pure subroutine stdlib${ii}$_slarft( direct, storev, n, k, v, ldv, tau, t, ldt ) !! SLARFT forms the triangular factor T of a real 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; - !! If DIRECT = 'B', H = H(k) . . . H(2) H(1) and T is lower triangular. + !! If DIRECT = 'F', H = H(1_${ik}$) H(2_${ik}$) . . . H(k) and T is upper triangular; + !! If DIRECT = 'B', H = H(k) . . . H(2_${ik}$) H(1_${ik}$) and T is lower triangular. !! If STOREV = 'C', the vector which defines the elementary reflector !! H(i) is stored in the i-th column of the array V, and !! H = I - V * T * V**T @@ -4136,14 +4138,14 @@ module stdlib_linalg_lapack_s ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: direct, storev - integer(ilp), intent(in) :: k, ldt, ldv, n + integer(${ik}$), intent(in) :: k, ldt, ldv, n ! Array Arguments real(sp), intent(out) :: t(ldt,*) real(sp), intent(in) :: tau(*), v(ldv,*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, j, prevlastv, lastv + integer(${ik}$) :: i, j, prevlastv, lastv ! Executable Statements ! quick return if possible if( n==0 )return @@ -4167,9 +4169,9 @@ module stdlib_linalg_lapack_s t( j, i ) = -tau( i ) * v( i , j ) end do j = min( lastv, prevlastv ) - ! t(1:i-1,i) := - tau(i) * v(i:j,1:i-1)**t * v(i:j,i) - call stdlib_sgemv( 'TRANSPOSE', j-i, i-1, -tau( i ),v( i+1, 1 ), ldv, v( i+& - 1, i ), 1, one,t( 1, i ), 1 ) + ! t(1_${ik}$:i-1,i) := - tau(i) * v(i:j,1_${ik}$:i-1)**t * v(i:j,i) + call stdlib${ii}$_sgemv( 'TRANSPOSE', j-i, i-1, -tau( i ),v( i+1, 1_${ik}$ ), ldv, v( i+& + 1_${ik}$, i ), 1_${ik}$, one,t( 1_${ik}$, i ), 1_${ik}$ ) else ! skip any trailing zeros. do lastv = n, i+1, -1 @@ -4179,15 +4181,15 @@ module stdlib_linalg_lapack_s t( j, i ) = -tau( i ) * v( j , i ) end do j = min( lastv, prevlastv ) - ! t(1:i-1,i) := - tau(i) * v(1:i-1,i:j) * v(i,i:j)**t - call stdlib_sgemv( 'NO TRANSPOSE', i-1, j-i, -tau( i ),v( 1, i+1 ), ldv, v(& - i, i+1 ), ldv,one, t( 1, i ), 1 ) + ! t(1_${ik}$:i-1,i) := - tau(i) * v(1_${ik}$:i-1,i:j) * v(i,i:j)**t + call stdlib${ii}$_sgemv( 'NO TRANSPOSE', i-1, j-i, -tau( i ),v( 1_${ik}$, i+1 ), ldv, v(& + i, i+1 ), ldv,one, t( 1_${ik}$, i ), 1_${ik}$ ) end if - ! t(1:i-1,i) := t(1:i-1,1:i-1) * t(1:i-1,i) - call stdlib_strmv( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', i-1, t,ldt, t( 1, i ),& - 1 ) + ! t(1_${ik}$:i-1,i) := t(1_${ik}$:i-1,1_${ik}$:i-1) * t(1_${ik}$:i-1,i) + call stdlib${ii}$_strmv( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', i-1, t,ldt, t( 1_${ik}$, i ),& + 1_${ik}$ ) t( i, i ) = tau( i ) - if( i>1 ) then + if( i>1_${ik}$ ) then prevlastv = max( prevlastv, lastv ) else prevlastv = lastv @@ -4195,7 +4197,7 @@ module stdlib_linalg_lapack_s end if end do else - prevlastv = 1 + prevlastv = 1_${ik}$ do i = k, 1, -1 if( tau( i )==zero ) then ! h(i) = i @@ -4215,8 +4217,8 @@ module stdlib_linalg_lapack_s 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_sgemv( 'TRANSPOSE', n-k+i-j, k-i, -tau( i ),v( j, i+1 ), & - ldv, v( j, i ), 1, one,t( i+1, i ), 1 ) + call stdlib${ii}$_sgemv( 'TRANSPOSE', n-k+i-j, k-i, -tau( i ),v( j, i+1 ), & + ldv, v( j, i ), 1_${ik}$, one,t( i+1, i ), 1_${ik}$ ) else ! skip any leading zeros. do lastv = 1, i-1 @@ -4227,13 +4229,13 @@ module stdlib_linalg_lapack_s 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_sgemv( '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 ) + call stdlib${ii}$_sgemv( '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_${ik}$ ) end if ! t(i+1:k,i) := t(i+1:k,i+1:k) * t(i+1:k,i) - call stdlib_strmv( 'LOWER', 'NO TRANSPOSE', 'NON-UNIT', k-i,t( i+1, i+1 ), & - ldt, t( i+1, i ), 1 ) - if( i>1 ) then + call stdlib${ii}$_strmv( 'LOWER', 'NO TRANSPOSE', 'NON-UNIT', k-i,t( i+1, i+1 ), & + ldt, t( i+1, i ), 1_${ik}$ ) + if( i>1_${ik}$ ) then prevlastv = min( prevlastv, lastv ) else prevlastv = lastv @@ -4244,23 +4246,23 @@ module stdlib_linalg_lapack_s end do end if return - end subroutine stdlib_slarft + end subroutine stdlib${ii}$_slarft - pure subroutine stdlib_slarfx( side, m, n, v, tau, c, ldc, work ) + pure subroutine stdlib${ii}$_slarfx( side, m, n, v, tau, c, ldc, work ) !! SLARFX 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 !! where tau is a real scalar and v is a real vector. - !! If tau = 0, then H is taken to be the unit matrix + !! If tau = 0_${ik}$, then H is taken to be the unit matrix !! This version uses inline code if H has order < 11. ! -- 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 character, intent(in) :: side - integer(ilp), intent(in) :: ldc, m, n + integer(${ik}$), intent(in) :: ldc, m, n real(sp), intent(in) :: tau ! Array Arguments real(sp), intent(inout) :: c(ldc,*) @@ -4269,7 +4271,7 @@ module stdlib_linalg_lapack_s ! ===================================================================== ! Local Scalars - integer(ilp) :: j + integer(${ik}$) :: j real(sp) :: sum, t1, t10, t2, t3, t4, t5, t6, t7, t8, t9, v1, v10, v2, v3, v4, v5, v6, & v7, v8, v9 ! Executable Statements @@ -4278,478 +4280,478 @@ module stdlib_linalg_lapack_s ! 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_slarf( side, m, n, v, 1, tau, c, ldc, work ) + call stdlib${ii}$_slarf( side, m, n, v, 1_${ik}$, tau, c, ldc, work ) go to 410 10 continue - ! special code for 1 x 1 householder - t1 = one - tau*v( 1 )*v( 1 ) + ! special code for 1_${ik}$ x 1_${ik}$ householder + t1 = one - tau*v( 1_${ik}$ )*v( 1_${ik}$ ) do j = 1, n - c( 1, j ) = t1*c( 1, j ) + c( 1_${ik}$, j ) = t1*c( 1_${ik}$, j ) end do go to 410 30 continue - ! special code for 2 x 2 householder - v1 = v( 1 ) + ! special code for 2_${ik}$ x 2_${ik}$ householder + v1 = v( 1_${ik}$ ) t1 = tau*v1 - v2 = v( 2 ) + v2 = v( 2_${ik}$ ) t2 = tau*v2 do j = 1, n - sum = v1*c( 1, j ) + v2*c( 2, j ) - c( 1, j ) = c( 1, j ) - sum*t1 - c( 2, j ) = c( 2, j ) - sum*t2 + sum = v1*c( 1_${ik}$, j ) + v2*c( 2_${ik}$, j ) + c( 1_${ik}$, j ) = c( 1_${ik}$, j ) - sum*t1 + c( 2_${ik}$, j ) = c( 2_${ik}$, j ) - sum*t2 end do go to 410 50 continue - ! special code for 3 x 3 householder - v1 = v( 1 ) + ! special code for 3_${ik}$ x 3_${ik}$ householder + v1 = v( 1_${ik}$ ) t1 = tau*v1 - v2 = v( 2 ) + v2 = v( 2_${ik}$ ) t2 = tau*v2 - v3 = v( 3 ) + v3 = v( 3_${ik}$ ) t3 = tau*v3 do j = 1, n - sum = v1*c( 1, j ) + v2*c( 2, j ) + v3*c( 3, j ) - c( 1, j ) = c( 1, j ) - sum*t1 - c( 2, j ) = c( 2, j ) - sum*t2 - c( 3, j ) = c( 3, j ) - sum*t3 + sum = v1*c( 1_${ik}$, j ) + v2*c( 2_${ik}$, j ) + v3*c( 3_${ik}$, j ) + c( 1_${ik}$, j ) = c( 1_${ik}$, j ) - sum*t1 + c( 2_${ik}$, j ) = c( 2_${ik}$, j ) - sum*t2 + c( 3_${ik}$, j ) = c( 3_${ik}$, j ) - sum*t3 end do go to 410 70 continue - ! special code for 4 x 4 householder - v1 = v( 1 ) + ! special code for 4_${ik}$ x 4_${ik}$ householder + v1 = v( 1_${ik}$ ) t1 = tau*v1 - v2 = v( 2 ) + v2 = v( 2_${ik}$ ) t2 = tau*v2 - v3 = v( 3 ) + v3 = v( 3_${ik}$ ) t3 = tau*v3 - v4 = v( 4 ) + v4 = v( 4_${ik}$ ) t4 = tau*v4 do j = 1, n - sum = v1*c( 1, j ) + v2*c( 2, j ) + v3*c( 3, j ) +v4*c( 4, j ) - c( 1, j ) = c( 1, j ) - sum*t1 - c( 2, j ) = c( 2, j ) - sum*t2 - c( 3, j ) = c( 3, j ) - sum*t3 - c( 4, j ) = c( 4, j ) - sum*t4 + sum = v1*c( 1_${ik}$, j ) + v2*c( 2_${ik}$, j ) + v3*c( 3_${ik}$, j ) +v4*c( 4_${ik}$, j ) + c( 1_${ik}$, j ) = c( 1_${ik}$, j ) - sum*t1 + c( 2_${ik}$, j ) = c( 2_${ik}$, j ) - sum*t2 + c( 3_${ik}$, j ) = c( 3_${ik}$, j ) - sum*t3 + c( 4_${ik}$, j ) = c( 4_${ik}$, j ) - sum*t4 end do go to 410 90 continue - ! special code for 5 x 5 householder - v1 = v( 1 ) + ! special code for 5_${ik}$ x 5_${ik}$ householder + v1 = v( 1_${ik}$ ) t1 = tau*v1 - v2 = v( 2 ) + v2 = v( 2_${ik}$ ) t2 = tau*v2 - v3 = v( 3 ) + v3 = v( 3_${ik}$ ) t3 = tau*v3 - v4 = v( 4 ) + v4 = v( 4_${ik}$ ) t4 = tau*v4 - v5 = v( 5 ) + v5 = v( 5_${ik}$ ) t5 = tau*v5 do j = 1, n - sum = v1*c( 1, j ) + v2*c( 2, j ) + v3*c( 3, j ) +v4*c( 4, j ) + v5*c( 5, j ) + sum = v1*c( 1_${ik}$, j ) + v2*c( 2_${ik}$, j ) + v3*c( 3_${ik}$, j ) +v4*c( 4_${ik}$, j ) + v5*c( 5_${ik}$, j ) - c( 1, j ) = c( 1, j ) - sum*t1 - c( 2, j ) = c( 2, j ) - sum*t2 - c( 3, j ) = c( 3, j ) - sum*t3 - c( 4, j ) = c( 4, j ) - sum*t4 - c( 5, j ) = c( 5, j ) - sum*t5 + c( 1_${ik}$, j ) = c( 1_${ik}$, j ) - sum*t1 + c( 2_${ik}$, j ) = c( 2_${ik}$, j ) - sum*t2 + c( 3_${ik}$, j ) = c( 3_${ik}$, j ) - sum*t3 + c( 4_${ik}$, j ) = c( 4_${ik}$, j ) - sum*t4 + c( 5_${ik}$, j ) = c( 5_${ik}$, j ) - sum*t5 end do go to 410 110 continue - ! special code for 6 x 6 householder - v1 = v( 1 ) + ! special code for 6_${ik}$ x 6_${ik}$ householder + v1 = v( 1_${ik}$ ) t1 = tau*v1 - v2 = v( 2 ) + v2 = v( 2_${ik}$ ) t2 = tau*v2 - v3 = v( 3 ) + v3 = v( 3_${ik}$ ) t3 = tau*v3 - v4 = v( 4 ) + v4 = v( 4_${ik}$ ) t4 = tau*v4 - v5 = v( 5 ) + v5 = v( 5_${ik}$ ) t5 = tau*v5 - v6 = v( 6 ) + v6 = v( 6_${ik}$ ) t6 = tau*v6 do j = 1, n - sum = v1*c( 1, j ) + v2*c( 2, j ) + v3*c( 3, j ) +v4*c( 4, j ) + v5*c( 5, j ) + & - v6*c( 6, j ) - c( 1, j ) = c( 1, j ) - sum*t1 - c( 2, j ) = c( 2, j ) - sum*t2 - c( 3, j ) = c( 3, j ) - sum*t3 - c( 4, j ) = c( 4, j ) - sum*t4 - c( 5, j ) = c( 5, j ) - sum*t5 - c( 6, j ) = c( 6, j ) - sum*t6 + sum = v1*c( 1_${ik}$, j ) + v2*c( 2_${ik}$, j ) + v3*c( 3_${ik}$, j ) +v4*c( 4_${ik}$, j ) + v5*c( 5_${ik}$, j ) + & + v6*c( 6_${ik}$, j ) + c( 1_${ik}$, j ) = c( 1_${ik}$, j ) - sum*t1 + c( 2_${ik}$, j ) = c( 2_${ik}$, j ) - sum*t2 + c( 3_${ik}$, j ) = c( 3_${ik}$, j ) - sum*t3 + c( 4_${ik}$, j ) = c( 4_${ik}$, j ) - sum*t4 + c( 5_${ik}$, j ) = c( 5_${ik}$, j ) - sum*t5 + c( 6_${ik}$, j ) = c( 6_${ik}$, j ) - sum*t6 end do go to 410 130 continue - ! special code for 7 x 7 householder - v1 = v( 1 ) + ! special code for 7_${ik}$ x 7_${ik}$ householder + v1 = v( 1_${ik}$ ) t1 = tau*v1 - v2 = v( 2 ) + v2 = v( 2_${ik}$ ) t2 = tau*v2 - v3 = v( 3 ) + v3 = v( 3_${ik}$ ) t3 = tau*v3 - v4 = v( 4 ) + v4 = v( 4_${ik}$ ) t4 = tau*v4 - v5 = v( 5 ) + v5 = v( 5_${ik}$ ) t5 = tau*v5 - v6 = v( 6 ) + v6 = v( 6_${ik}$ ) t6 = tau*v6 - v7 = v( 7 ) + v7 = v( 7_${ik}$ ) t7 = tau*v7 do j = 1, n - sum = v1*c( 1, j ) + v2*c( 2, j ) + v3*c( 3, j ) +v4*c( 4, j ) + v5*c( 5, j ) + & - v6*c( 6, j ) +v7*c( 7, j ) - c( 1, j ) = c( 1, j ) - sum*t1 - c( 2, j ) = c( 2, j ) - sum*t2 - c( 3, j ) = c( 3, j ) - sum*t3 - c( 4, j ) = c( 4, j ) - sum*t4 - c( 5, j ) = c( 5, j ) - sum*t5 - c( 6, j ) = c( 6, j ) - sum*t6 - c( 7, j ) = c( 7, j ) - sum*t7 + sum = v1*c( 1_${ik}$, j ) + v2*c( 2_${ik}$, j ) + v3*c( 3_${ik}$, j ) +v4*c( 4_${ik}$, j ) + v5*c( 5_${ik}$, j ) + & + v6*c( 6_${ik}$, j ) +v7*c( 7_${ik}$, j ) + c( 1_${ik}$, j ) = c( 1_${ik}$, j ) - sum*t1 + c( 2_${ik}$, j ) = c( 2_${ik}$, j ) - sum*t2 + c( 3_${ik}$, j ) = c( 3_${ik}$, j ) - sum*t3 + c( 4_${ik}$, j ) = c( 4_${ik}$, j ) - sum*t4 + c( 5_${ik}$, j ) = c( 5_${ik}$, j ) - sum*t5 + c( 6_${ik}$, j ) = c( 6_${ik}$, j ) - sum*t6 + c( 7_${ik}$, j ) = c( 7_${ik}$, j ) - sum*t7 end do go to 410 150 continue - ! special code for 8 x 8 householder - v1 = v( 1 ) + ! special code for 8_${ik}$ x 8_${ik}$ householder + v1 = v( 1_${ik}$ ) t1 = tau*v1 - v2 = v( 2 ) + v2 = v( 2_${ik}$ ) t2 = tau*v2 - v3 = v( 3 ) + v3 = v( 3_${ik}$ ) t3 = tau*v3 - v4 = v( 4 ) + v4 = v( 4_${ik}$ ) t4 = tau*v4 - v5 = v( 5 ) + v5 = v( 5_${ik}$ ) t5 = tau*v5 - v6 = v( 6 ) + v6 = v( 6_${ik}$ ) t6 = tau*v6 - v7 = v( 7 ) + v7 = v( 7_${ik}$ ) t7 = tau*v7 - v8 = v( 8 ) + v8 = v( 8_${ik}$ ) t8 = tau*v8 do j = 1, n - sum = v1*c( 1, j ) + v2*c( 2, j ) + v3*c( 3, j ) +v4*c( 4, j ) + v5*c( 5, j ) + & - v6*c( 6, j ) +v7*c( 7, j ) + v8*c( 8, j ) - c( 1, j ) = c( 1, j ) - sum*t1 - c( 2, j ) = c( 2, j ) - sum*t2 - c( 3, j ) = c( 3, j ) - sum*t3 - c( 4, j ) = c( 4, j ) - sum*t4 - c( 5, j ) = c( 5, j ) - sum*t5 - c( 6, j ) = c( 6, j ) - sum*t6 - c( 7, j ) = c( 7, j ) - sum*t7 - c( 8, j ) = c( 8, j ) - sum*t8 + sum = v1*c( 1_${ik}$, j ) + v2*c( 2_${ik}$, j ) + v3*c( 3_${ik}$, j ) +v4*c( 4_${ik}$, j ) + v5*c( 5_${ik}$, j ) + & + v6*c( 6_${ik}$, j ) +v7*c( 7_${ik}$, j ) + v8*c( 8_${ik}$, j ) + c( 1_${ik}$, j ) = c( 1_${ik}$, j ) - sum*t1 + c( 2_${ik}$, j ) = c( 2_${ik}$, j ) - sum*t2 + c( 3_${ik}$, j ) = c( 3_${ik}$, j ) - sum*t3 + c( 4_${ik}$, j ) = c( 4_${ik}$, j ) - sum*t4 + c( 5_${ik}$, j ) = c( 5_${ik}$, j ) - sum*t5 + c( 6_${ik}$, j ) = c( 6_${ik}$, j ) - sum*t6 + c( 7_${ik}$, j ) = c( 7_${ik}$, j ) - sum*t7 + c( 8_${ik}$, j ) = c( 8_${ik}$, j ) - sum*t8 end do go to 410 170 continue - ! special code for 9 x 9 householder - v1 = v( 1 ) + ! special code for 9_${ik}$ x 9_${ik}$ householder + v1 = v( 1_${ik}$ ) t1 = tau*v1 - v2 = v( 2 ) + v2 = v( 2_${ik}$ ) t2 = tau*v2 - v3 = v( 3 ) + v3 = v( 3_${ik}$ ) t3 = tau*v3 - v4 = v( 4 ) + v4 = v( 4_${ik}$ ) t4 = tau*v4 - v5 = v( 5 ) + v5 = v( 5_${ik}$ ) t5 = tau*v5 - v6 = v( 6 ) + v6 = v( 6_${ik}$ ) t6 = tau*v6 - v7 = v( 7 ) + v7 = v( 7_${ik}$ ) t7 = tau*v7 - v8 = v( 8 ) + v8 = v( 8_${ik}$ ) t8 = tau*v8 - v9 = v( 9 ) + v9 = v( 9_${ik}$ ) t9 = tau*v9 do j = 1, n - sum = v1*c( 1, j ) + v2*c( 2, j ) + v3*c( 3, j ) +v4*c( 4, j ) + v5*c( 5, j ) + & - v6*c( 6, j ) +v7*c( 7, j ) + v8*c( 8, j ) + v9*c( 9, j ) - c( 1, j ) = c( 1, j ) - sum*t1 - c( 2, j ) = c( 2, j ) - sum*t2 - c( 3, j ) = c( 3, j ) - sum*t3 - c( 4, j ) = c( 4, j ) - sum*t4 - c( 5, j ) = c( 5, j ) - sum*t5 - c( 6, j ) = c( 6, j ) - sum*t6 - c( 7, j ) = c( 7, j ) - sum*t7 - c( 8, j ) = c( 8, j ) - sum*t8 - c( 9, j ) = c( 9, j ) - sum*t9 + sum = v1*c( 1_${ik}$, j ) + v2*c( 2_${ik}$, j ) + v3*c( 3_${ik}$, j ) +v4*c( 4_${ik}$, j ) + v5*c( 5_${ik}$, j ) + & + v6*c( 6_${ik}$, j ) +v7*c( 7_${ik}$, j ) + v8*c( 8_${ik}$, j ) + v9*c( 9_${ik}$, j ) + c( 1_${ik}$, j ) = c( 1_${ik}$, j ) - sum*t1 + c( 2_${ik}$, j ) = c( 2_${ik}$, j ) - sum*t2 + c( 3_${ik}$, j ) = c( 3_${ik}$, j ) - sum*t3 + c( 4_${ik}$, j ) = c( 4_${ik}$, j ) - sum*t4 + c( 5_${ik}$, j ) = c( 5_${ik}$, j ) - sum*t5 + c( 6_${ik}$, j ) = c( 6_${ik}$, j ) - sum*t6 + c( 7_${ik}$, j ) = c( 7_${ik}$, j ) - sum*t7 + c( 8_${ik}$, j ) = c( 8_${ik}$, j ) - sum*t8 + c( 9_${ik}$, j ) = c( 9_${ik}$, j ) - sum*t9 end do go to 410 190 continue - ! special code for 10 x 10 householder - v1 = v( 1 ) + ! special code for 10_${ik}$ x 10_${ik}$ householder + v1 = v( 1_${ik}$ ) t1 = tau*v1 - v2 = v( 2 ) + v2 = v( 2_${ik}$ ) t2 = tau*v2 - v3 = v( 3 ) + v3 = v( 3_${ik}$ ) t3 = tau*v3 - v4 = v( 4 ) + v4 = v( 4_${ik}$ ) t4 = tau*v4 - v5 = v( 5 ) + v5 = v( 5_${ik}$ ) t5 = tau*v5 - v6 = v( 6 ) + v6 = v( 6_${ik}$ ) t6 = tau*v6 - v7 = v( 7 ) + v7 = v( 7_${ik}$ ) t7 = tau*v7 - v8 = v( 8 ) + v8 = v( 8_${ik}$ ) t8 = tau*v8 - v9 = v( 9 ) + v9 = v( 9_${ik}$ ) t9 = tau*v9 - v10 = v( 10 ) + v10 = v( 10_${ik}$ ) t10 = tau*v10 do j = 1, n - sum = v1*c( 1, j ) + v2*c( 2, j ) + v3*c( 3, j ) +v4*c( 4, j ) + v5*c( 5, j ) + & - v6*c( 6, j ) +v7*c( 7, j ) + v8*c( 8, j ) + v9*c( 9, j ) +v10*c( 10, j ) - c( 1, j ) = c( 1, j ) - sum*t1 - c( 2, j ) = c( 2, j ) - sum*t2 - c( 3, j ) = c( 3, j ) - sum*t3 - c( 4, j ) = c( 4, j ) - sum*t4 - c( 5, j ) = c( 5, j ) - sum*t5 - c( 6, j ) = c( 6, j ) - sum*t6 - c( 7, j ) = c( 7, j ) - sum*t7 - c( 8, j ) = c( 8, j ) - sum*t8 - c( 9, j ) = c( 9, j ) - sum*t9 - c( 10, j ) = c( 10, j ) - sum*t10 + sum = v1*c( 1_${ik}$, j ) + v2*c( 2_${ik}$, j ) + v3*c( 3_${ik}$, j ) +v4*c( 4_${ik}$, j ) + v5*c( 5_${ik}$, j ) + & + v6*c( 6_${ik}$, j ) +v7*c( 7_${ik}$, j ) + v8*c( 8_${ik}$, j ) + v9*c( 9_${ik}$, j ) +v10*c( 10_${ik}$, j ) + c( 1_${ik}$, j ) = c( 1_${ik}$, j ) - sum*t1 + c( 2_${ik}$, j ) = c( 2_${ik}$, j ) - sum*t2 + c( 3_${ik}$, j ) = c( 3_${ik}$, j ) - sum*t3 + c( 4_${ik}$, j ) = c( 4_${ik}$, j ) - sum*t4 + c( 5_${ik}$, j ) = c( 5_${ik}$, j ) - sum*t5 + c( 6_${ik}$, j ) = c( 6_${ik}$, j ) - sum*t6 + c( 7_${ik}$, j ) = c( 7_${ik}$, j ) - sum*t7 + c( 8_${ik}$, j ) = c( 8_${ik}$, j ) - sum*t8 + c( 9_${ik}$, j ) = c( 9_${ik}$, j ) - sum*t9 + c( 10_${ik}$, j ) = c( 10_${ik}$, j ) - sum*t10 end do go to 410 else ! 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_slarf( side, m, n, v, 1, tau, c, ldc, work ) + call stdlib${ii}$_slarf( side, m, n, v, 1_${ik}$, tau, c, ldc, work ) go to 410 210 continue - ! special code for 1 x 1 householder - t1 = one - tau*v( 1 )*v( 1 ) + ! special code for 1_${ik}$ x 1_${ik}$ householder + t1 = one - tau*v( 1_${ik}$ )*v( 1_${ik}$ ) do j = 1, m - c( j, 1 ) = t1*c( j, 1 ) + c( j, 1_${ik}$ ) = t1*c( j, 1_${ik}$ ) end do go to 410 230 continue - ! special code for 2 x 2 householder - v1 = v( 1 ) + ! special code for 2_${ik}$ x 2_${ik}$ householder + v1 = v( 1_${ik}$ ) t1 = tau*v1 - v2 = v( 2 ) + v2 = v( 2_${ik}$ ) t2 = tau*v2 do j = 1, m - sum = v1*c( j, 1 ) + v2*c( j, 2 ) - c( j, 1 ) = c( j, 1 ) - sum*t1 - c( j, 2 ) = c( j, 2 ) - sum*t2 + sum = v1*c( j, 1_${ik}$ ) + v2*c( j, 2_${ik}$ ) + c( j, 1_${ik}$ ) = c( j, 1_${ik}$ ) - sum*t1 + c( j, 2_${ik}$ ) = c( j, 2_${ik}$ ) - sum*t2 end do go to 410 250 continue - ! special code for 3 x 3 householder - v1 = v( 1 ) + ! special code for 3_${ik}$ x 3_${ik}$ householder + v1 = v( 1_${ik}$ ) t1 = tau*v1 - v2 = v( 2 ) + v2 = v( 2_${ik}$ ) t2 = tau*v2 - v3 = v( 3 ) + v3 = v( 3_${ik}$ ) t3 = tau*v3 do j = 1, m - sum = v1*c( j, 1 ) + v2*c( j, 2 ) + v3*c( j, 3 ) - c( j, 1 ) = c( j, 1 ) - sum*t1 - c( j, 2 ) = c( j, 2 ) - sum*t2 - c( j, 3 ) = c( j, 3 ) - sum*t3 + sum = v1*c( j, 1_${ik}$ ) + v2*c( j, 2_${ik}$ ) + v3*c( j, 3_${ik}$ ) + c( j, 1_${ik}$ ) = c( j, 1_${ik}$ ) - sum*t1 + c( j, 2_${ik}$ ) = c( j, 2_${ik}$ ) - sum*t2 + c( j, 3_${ik}$ ) = c( j, 3_${ik}$ ) - sum*t3 end do go to 410 270 continue - ! special code for 4 x 4 householder - v1 = v( 1 ) + ! special code for 4_${ik}$ x 4_${ik}$ householder + v1 = v( 1_${ik}$ ) t1 = tau*v1 - v2 = v( 2 ) + v2 = v( 2_${ik}$ ) t2 = tau*v2 - v3 = v( 3 ) + v3 = v( 3_${ik}$ ) t3 = tau*v3 - v4 = v( 4 ) + v4 = v( 4_${ik}$ ) t4 = tau*v4 do j = 1, m - sum = v1*c( j, 1 ) + v2*c( j, 2 ) + v3*c( j, 3 ) +v4*c( j, 4 ) - c( j, 1 ) = c( j, 1 ) - sum*t1 - c( j, 2 ) = c( j, 2 ) - sum*t2 - c( j, 3 ) = c( j, 3 ) - sum*t3 - c( j, 4 ) = c( j, 4 ) - sum*t4 + sum = v1*c( j, 1_${ik}$ ) + v2*c( j, 2_${ik}$ ) + v3*c( j, 3_${ik}$ ) +v4*c( j, 4_${ik}$ ) + c( j, 1_${ik}$ ) = c( j, 1_${ik}$ ) - sum*t1 + c( j, 2_${ik}$ ) = c( j, 2_${ik}$ ) - sum*t2 + c( j, 3_${ik}$ ) = c( j, 3_${ik}$ ) - sum*t3 + c( j, 4_${ik}$ ) = c( j, 4_${ik}$ ) - sum*t4 end do go to 410 290 continue - ! special code for 5 x 5 householder - v1 = v( 1 ) + ! special code for 5_${ik}$ x 5_${ik}$ householder + v1 = v( 1_${ik}$ ) t1 = tau*v1 - v2 = v( 2 ) + v2 = v( 2_${ik}$ ) t2 = tau*v2 - v3 = v( 3 ) + v3 = v( 3_${ik}$ ) t3 = tau*v3 - v4 = v( 4 ) + v4 = v( 4_${ik}$ ) t4 = tau*v4 - v5 = v( 5 ) + v5 = v( 5_${ik}$ ) t5 = tau*v5 do j = 1, m - sum = v1*c( j, 1 ) + v2*c( j, 2 ) + v3*c( j, 3 ) +v4*c( j, 4 ) + v5*c( j, 5 ) + sum = v1*c( j, 1_${ik}$ ) + v2*c( j, 2_${ik}$ ) + v3*c( j, 3_${ik}$ ) +v4*c( j, 4_${ik}$ ) + v5*c( j, 5_${ik}$ ) - c( j, 1 ) = c( j, 1 ) - sum*t1 - c( j, 2 ) = c( j, 2 ) - sum*t2 - c( j, 3 ) = c( j, 3 ) - sum*t3 - c( j, 4 ) = c( j, 4 ) - sum*t4 - c( j, 5 ) = c( j, 5 ) - sum*t5 + c( j, 1_${ik}$ ) = c( j, 1_${ik}$ ) - sum*t1 + c( j, 2_${ik}$ ) = c( j, 2_${ik}$ ) - sum*t2 + c( j, 3_${ik}$ ) = c( j, 3_${ik}$ ) - sum*t3 + c( j, 4_${ik}$ ) = c( j, 4_${ik}$ ) - sum*t4 + c( j, 5_${ik}$ ) = c( j, 5_${ik}$ ) - sum*t5 end do go to 410 310 continue - ! special code for 6 x 6 householder - v1 = v( 1 ) + ! special code for 6_${ik}$ x 6_${ik}$ householder + v1 = v( 1_${ik}$ ) t1 = tau*v1 - v2 = v( 2 ) + v2 = v( 2_${ik}$ ) t2 = tau*v2 - v3 = v( 3 ) + v3 = v( 3_${ik}$ ) t3 = tau*v3 - v4 = v( 4 ) + v4 = v( 4_${ik}$ ) t4 = tau*v4 - v5 = v( 5 ) + v5 = v( 5_${ik}$ ) t5 = tau*v5 - v6 = v( 6 ) + v6 = v( 6_${ik}$ ) t6 = tau*v6 do j = 1, m - sum = v1*c( j, 1 ) + v2*c( j, 2 ) + v3*c( j, 3 ) +v4*c( j, 4 ) + v5*c( j, 5 ) + & - v6*c( j, 6 ) - c( j, 1 ) = c( j, 1 ) - sum*t1 - c( j, 2 ) = c( j, 2 ) - sum*t2 - c( j, 3 ) = c( j, 3 ) - sum*t3 - c( j, 4 ) = c( j, 4 ) - sum*t4 - c( j, 5 ) = c( j, 5 ) - sum*t5 - c( j, 6 ) = c( j, 6 ) - sum*t6 + sum = v1*c( j, 1_${ik}$ ) + v2*c( j, 2_${ik}$ ) + v3*c( j, 3_${ik}$ ) +v4*c( j, 4_${ik}$ ) + v5*c( j, 5_${ik}$ ) + & + v6*c( j, 6_${ik}$ ) + c( j, 1_${ik}$ ) = c( j, 1_${ik}$ ) - sum*t1 + c( j, 2_${ik}$ ) = c( j, 2_${ik}$ ) - sum*t2 + c( j, 3_${ik}$ ) = c( j, 3_${ik}$ ) - sum*t3 + c( j, 4_${ik}$ ) = c( j, 4_${ik}$ ) - sum*t4 + c( j, 5_${ik}$ ) = c( j, 5_${ik}$ ) - sum*t5 + c( j, 6_${ik}$ ) = c( j, 6_${ik}$ ) - sum*t6 end do go to 410 330 continue - ! special code for 7 x 7 householder - v1 = v( 1 ) + ! special code for 7_${ik}$ x 7_${ik}$ householder + v1 = v( 1_${ik}$ ) t1 = tau*v1 - v2 = v( 2 ) + v2 = v( 2_${ik}$ ) t2 = tau*v2 - v3 = v( 3 ) + v3 = v( 3_${ik}$ ) t3 = tau*v3 - v4 = v( 4 ) + v4 = v( 4_${ik}$ ) t4 = tau*v4 - v5 = v( 5 ) + v5 = v( 5_${ik}$ ) t5 = tau*v5 - v6 = v( 6 ) + v6 = v( 6_${ik}$ ) t6 = tau*v6 - v7 = v( 7 ) + v7 = v( 7_${ik}$ ) t7 = tau*v7 do j = 1, m - sum = v1*c( j, 1 ) + v2*c( j, 2 ) + v3*c( j, 3 ) +v4*c( j, 4 ) + v5*c( j, 5 ) + & - v6*c( j, 6 ) +v7*c( j, 7 ) - c( j, 1 ) = c( j, 1 ) - sum*t1 - c( j, 2 ) = c( j, 2 ) - sum*t2 - c( j, 3 ) = c( j, 3 ) - sum*t3 - c( j, 4 ) = c( j, 4 ) - sum*t4 - c( j, 5 ) = c( j, 5 ) - sum*t5 - c( j, 6 ) = c( j, 6 ) - sum*t6 - c( j, 7 ) = c( j, 7 ) - sum*t7 + sum = v1*c( j, 1_${ik}$ ) + v2*c( j, 2_${ik}$ ) + v3*c( j, 3_${ik}$ ) +v4*c( j, 4_${ik}$ ) + v5*c( j, 5_${ik}$ ) + & + v6*c( j, 6_${ik}$ ) +v7*c( j, 7_${ik}$ ) + c( j, 1_${ik}$ ) = c( j, 1_${ik}$ ) - sum*t1 + c( j, 2_${ik}$ ) = c( j, 2_${ik}$ ) - sum*t2 + c( j, 3_${ik}$ ) = c( j, 3_${ik}$ ) - sum*t3 + c( j, 4_${ik}$ ) = c( j, 4_${ik}$ ) - sum*t4 + c( j, 5_${ik}$ ) = c( j, 5_${ik}$ ) - sum*t5 + c( j, 6_${ik}$ ) = c( j, 6_${ik}$ ) - sum*t6 + c( j, 7_${ik}$ ) = c( j, 7_${ik}$ ) - sum*t7 end do go to 410 350 continue - ! special code for 8 x 8 householder - v1 = v( 1 ) + ! special code for 8_${ik}$ x 8_${ik}$ householder + v1 = v( 1_${ik}$ ) t1 = tau*v1 - v2 = v( 2 ) + v2 = v( 2_${ik}$ ) t2 = tau*v2 - v3 = v( 3 ) + v3 = v( 3_${ik}$ ) t3 = tau*v3 - v4 = v( 4 ) + v4 = v( 4_${ik}$ ) t4 = tau*v4 - v5 = v( 5 ) + v5 = v( 5_${ik}$ ) t5 = tau*v5 - v6 = v( 6 ) + v6 = v( 6_${ik}$ ) t6 = tau*v6 - v7 = v( 7 ) + v7 = v( 7_${ik}$ ) t7 = tau*v7 - v8 = v( 8 ) + v8 = v( 8_${ik}$ ) t8 = tau*v8 do j = 1, m - sum = v1*c( j, 1 ) + v2*c( j, 2 ) + v3*c( j, 3 ) +v4*c( j, 4 ) + v5*c( j, 5 ) + & - v6*c( j, 6 ) +v7*c( j, 7 ) + v8*c( j, 8 ) - c( j, 1 ) = c( j, 1 ) - sum*t1 - c( j, 2 ) = c( j, 2 ) - sum*t2 - c( j, 3 ) = c( j, 3 ) - sum*t3 - c( j, 4 ) = c( j, 4 ) - sum*t4 - c( j, 5 ) = c( j, 5 ) - sum*t5 - c( j, 6 ) = c( j, 6 ) - sum*t6 - c( j, 7 ) = c( j, 7 ) - sum*t7 - c( j, 8 ) = c( j, 8 ) - sum*t8 + sum = v1*c( j, 1_${ik}$ ) + v2*c( j, 2_${ik}$ ) + v3*c( j, 3_${ik}$ ) +v4*c( j, 4_${ik}$ ) + v5*c( j, 5_${ik}$ ) + & + v6*c( j, 6_${ik}$ ) +v7*c( j, 7_${ik}$ ) + v8*c( j, 8_${ik}$ ) + c( j, 1_${ik}$ ) = c( j, 1_${ik}$ ) - sum*t1 + c( j, 2_${ik}$ ) = c( j, 2_${ik}$ ) - sum*t2 + c( j, 3_${ik}$ ) = c( j, 3_${ik}$ ) - sum*t3 + c( j, 4_${ik}$ ) = c( j, 4_${ik}$ ) - sum*t4 + c( j, 5_${ik}$ ) = c( j, 5_${ik}$ ) - sum*t5 + c( j, 6_${ik}$ ) = c( j, 6_${ik}$ ) - sum*t6 + c( j, 7_${ik}$ ) = c( j, 7_${ik}$ ) - sum*t7 + c( j, 8_${ik}$ ) = c( j, 8_${ik}$ ) - sum*t8 end do go to 410 370 continue - ! special code for 9 x 9 householder - v1 = v( 1 ) + ! special code for 9_${ik}$ x 9_${ik}$ householder + v1 = v( 1_${ik}$ ) t1 = tau*v1 - v2 = v( 2 ) + v2 = v( 2_${ik}$ ) t2 = tau*v2 - v3 = v( 3 ) + v3 = v( 3_${ik}$ ) t3 = tau*v3 - v4 = v( 4 ) + v4 = v( 4_${ik}$ ) t4 = tau*v4 - v5 = v( 5 ) + v5 = v( 5_${ik}$ ) t5 = tau*v5 - v6 = v( 6 ) + v6 = v( 6_${ik}$ ) t6 = tau*v6 - v7 = v( 7 ) + v7 = v( 7_${ik}$ ) t7 = tau*v7 - v8 = v( 8 ) + v8 = v( 8_${ik}$ ) t8 = tau*v8 - v9 = v( 9 ) + v9 = v( 9_${ik}$ ) t9 = tau*v9 do j = 1, m - sum = v1*c( j, 1 ) + v2*c( j, 2 ) + v3*c( j, 3 ) +v4*c( j, 4 ) + v5*c( j, 5 ) + & - v6*c( j, 6 ) +v7*c( j, 7 ) + v8*c( j, 8 ) + v9*c( j, 9 ) - c( j, 1 ) = c( j, 1 ) - sum*t1 - c( j, 2 ) = c( j, 2 ) - sum*t2 - c( j, 3 ) = c( j, 3 ) - sum*t3 - c( j, 4 ) = c( j, 4 ) - sum*t4 - c( j, 5 ) = c( j, 5 ) - sum*t5 - c( j, 6 ) = c( j, 6 ) - sum*t6 - c( j, 7 ) = c( j, 7 ) - sum*t7 - c( j, 8 ) = c( j, 8 ) - sum*t8 - c( j, 9 ) = c( j, 9 ) - sum*t9 + sum = v1*c( j, 1_${ik}$ ) + v2*c( j, 2_${ik}$ ) + v3*c( j, 3_${ik}$ ) +v4*c( j, 4_${ik}$ ) + v5*c( j, 5_${ik}$ ) + & + v6*c( j, 6_${ik}$ ) +v7*c( j, 7_${ik}$ ) + v8*c( j, 8_${ik}$ ) + v9*c( j, 9_${ik}$ ) + c( j, 1_${ik}$ ) = c( j, 1_${ik}$ ) - sum*t1 + c( j, 2_${ik}$ ) = c( j, 2_${ik}$ ) - sum*t2 + c( j, 3_${ik}$ ) = c( j, 3_${ik}$ ) - sum*t3 + c( j, 4_${ik}$ ) = c( j, 4_${ik}$ ) - sum*t4 + c( j, 5_${ik}$ ) = c( j, 5_${ik}$ ) - sum*t5 + c( j, 6_${ik}$ ) = c( j, 6_${ik}$ ) - sum*t6 + c( j, 7_${ik}$ ) = c( j, 7_${ik}$ ) - sum*t7 + c( j, 8_${ik}$ ) = c( j, 8_${ik}$ ) - sum*t8 + c( j, 9_${ik}$ ) = c( j, 9_${ik}$ ) - sum*t9 end do go to 410 390 continue - ! special code for 10 x 10 householder - v1 = v( 1 ) + ! special code for 10_${ik}$ x 10_${ik}$ householder + v1 = v( 1_${ik}$ ) t1 = tau*v1 - v2 = v( 2 ) + v2 = v( 2_${ik}$ ) t2 = tau*v2 - v3 = v( 3 ) + v3 = v( 3_${ik}$ ) t3 = tau*v3 - v4 = v( 4 ) + v4 = v( 4_${ik}$ ) t4 = tau*v4 - v5 = v( 5 ) + v5 = v( 5_${ik}$ ) t5 = tau*v5 - v6 = v( 6 ) + v6 = v( 6_${ik}$ ) t6 = tau*v6 - v7 = v( 7 ) + v7 = v( 7_${ik}$ ) t7 = tau*v7 - v8 = v( 8 ) + v8 = v( 8_${ik}$ ) t8 = tau*v8 - v9 = v( 9 ) + v9 = v( 9_${ik}$ ) t9 = tau*v9 - v10 = v( 10 ) + v10 = v( 10_${ik}$ ) t10 = tau*v10 do j = 1, m - sum = v1*c( j, 1 ) + v2*c( j, 2 ) + v3*c( j, 3 ) +v4*c( j, 4 ) + v5*c( j, 5 ) + & - v6*c( j, 6 ) +v7*c( j, 7 ) + v8*c( j, 8 ) + v9*c( j, 9 ) +v10*c( j, 10 ) - c( j, 1 ) = c( j, 1 ) - sum*t1 - c( j, 2 ) = c( j, 2 ) - sum*t2 - c( j, 3 ) = c( j, 3 ) - sum*t3 - c( j, 4 ) = c( j, 4 ) - sum*t4 - c( j, 5 ) = c( j, 5 ) - sum*t5 - c( j, 6 ) = c( j, 6 ) - sum*t6 - c( j, 7 ) = c( j, 7 ) - sum*t7 - c( j, 8 ) = c( j, 8 ) - sum*t8 - c( j, 9 ) = c( j, 9 ) - sum*t9 - c( j, 10 ) = c( j, 10 ) - sum*t10 + sum = v1*c( j, 1_${ik}$ ) + v2*c( j, 2_${ik}$ ) + v3*c( j, 3_${ik}$ ) +v4*c( j, 4_${ik}$ ) + v5*c( j, 5_${ik}$ ) + & + v6*c( j, 6_${ik}$ ) +v7*c( j, 7_${ik}$ ) + v8*c( j, 8_${ik}$ ) + v9*c( j, 9_${ik}$ ) +v10*c( j, 10_${ik}$ ) + c( j, 1_${ik}$ ) = c( j, 1_${ik}$ ) - sum*t1 + c( j, 2_${ik}$ ) = c( j, 2_${ik}$ ) - sum*t2 + c( j, 3_${ik}$ ) = c( j, 3_${ik}$ ) - sum*t3 + c( j, 4_${ik}$ ) = c( j, 4_${ik}$ ) - sum*t4 + c( j, 5_${ik}$ ) = c( j, 5_${ik}$ ) - sum*t5 + c( j, 6_${ik}$ ) = c( j, 6_${ik}$ ) - sum*t6 + c( j, 7_${ik}$ ) = c( j, 7_${ik}$ ) - sum*t7 + c( j, 8_${ik}$ ) = c( j, 8_${ik}$ ) - sum*t8 + c( j, 9_${ik}$ ) = c( j, 9_${ik}$ ) - sum*t9 + c( j, 10_${ik}$ ) = c( j, 10_${ik}$ ) - sum*t10 end do go to 410 end if 410 return - end subroutine stdlib_slarfx + end subroutine stdlib${ii}$_slarfx - pure subroutine stdlib_slarfy( uplo, n, v, incv, tau, c, ldc, work ) + pure subroutine stdlib${ii}$_slarfy( uplo, n, v, incv, tau, c, ldc, work ) !! SLARFY 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 @@ -4761,7 +4763,7 @@ module stdlib_linalg_lapack_s ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: uplo - integer(ilp), intent(in) :: incv, ldc, n + integer(${ik}$), intent(in) :: incv, ldc, n real(sp), intent(in) :: tau ! Array Arguments real(sp), intent(inout) :: c(ldc,*) @@ -4774,39 +4776,39 @@ module stdlib_linalg_lapack_s ! Executable Statements if( tau==zero )return ! form w:= c * v - call stdlib_ssymv( uplo, n, one, c, ldc, v, incv, zero, work, 1 ) - alpha = -half*tau*stdlib_sdot( n, work, 1, v, incv ) - call stdlib_saxpy( n, alpha, v, incv, work, 1 ) + call stdlib${ii}$_ssymv( uplo, n, one, c, ldc, v, incv, zero, work, 1_${ik}$ ) + alpha = -half*tau*stdlib${ii}$_sdot( n, work, 1_${ik}$, v, incv ) + call stdlib${ii}$_saxpy( n, alpha, v, incv, work, 1_${ik}$ ) ! c := c - v * w' - w * v' - call stdlib_ssyr2( uplo, n, -tau, v, incv, work, 1, c, ldc ) + call stdlib${ii}$_ssyr2( uplo, n, -tau, v, incv, work, 1_${ik}$, c, ldc ) return - end subroutine stdlib_slarfy + end subroutine stdlib${ii}$_slarfy - pure subroutine stdlib_slargv( n, x, incx, y, incy, c, incc ) + pure subroutine stdlib${ii}$_slargv( n, x, incx, y, incy, c, incc ) !! SLARGV generates a vector of real plane rotations, determined by - !! elements of the real vectors x and y. For i = 1,2,...,n + !! elements of the real vectors x and y. For i = 1_${ik}$,2_${ik}$,...,n !! ( c(i) s(i) ) ( x(i) ) = ( a(i) ) - !! ( -s(i) c(i) ) ( y(i) ) = ( 0 ) + !! ( -s(i) c(i) ) ( y(i) ) = ( 0_${ik}$ ) ! -- 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) :: incc, incx, incy, n + integer(${ik}$), intent(in) :: incc, incx, incy, n ! Array Arguments real(sp), intent(out) :: c(*) real(sp), intent(inout) :: x(*), y(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, ic, ix, iy + integer(${ik}$) :: i, ic, ix, iy real(sp) :: f, g, t, tt ! Intrinsic Functions intrinsic :: abs,sqrt ! Executable Statements - ix = 1 - iy = 1 - ic = 1 + ix = 1_${ik}$ + iy = 1_${ik}$ + ic = 1_${ik}$ loop_10: do i = 1, n f = x( ix ) g = y( iy ) @@ -4834,38 +4836,38 @@ module stdlib_linalg_lapack_s ix = ix + incx end do loop_10 return - end subroutine stdlib_slargv + end subroutine stdlib${ii}$_slargv - pure subroutine stdlib_slarra( n, d, e, e2, spltol, tnrm,nsplit, isplit, info ) + pure subroutine stdlib${ii}$_slarra( n, d, e, e2, spltol, tnrm,nsplit, isplit, info ) !! Compute the splitting points with threshold SPLTOL. !! SLARRA sets any "small" off-diagonal elements to zero. ! -- 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, nsplit - integer(ilp), intent(in) :: n + integer(${ik}$), intent(out) :: info, nsplit + integer(${ik}$), intent(in) :: n real(sp), intent(in) :: spltol, tnrm ! Array Arguments - integer(ilp), intent(out) :: isplit(*) + integer(${ik}$), intent(out) :: isplit(*) real(sp), intent(in) :: d(*) real(sp), intent(inout) :: e(*), e2(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i + integer(${ik}$) :: i real(sp) :: eabs, tmp1 ! Intrinsic Functions intrinsic :: abs ! Executable Statements - info = 0 + info = 0_${ik}$ ! quick return if possible - if( n<=0 ) then + if( n<=0_${ik}$ ) then return end if ! compute splitting points - nsplit = 1 + nsplit = 1_${ik}$ if(spltol=vu )info = -5 - else if( irange==indrng .and.( il<1 .or. il>max( 1, n ) ) ) then - info = -6 + if( vl>=vu )info = -5_${ik}$ + else if( irange==indrng .and.( il<1_${ik}$ .or. il>max( 1_${ik}$, n ) ) ) then + info = -6_${ik}$ else if( irange==indrng .and.( iun ) ) then - info = -7 + info = -7_${ik}$ end if - if( info/=0 ) then + if( info/=0_${ik}$ ) then return end if ! initialize error flags - info = 0 + info = 0_${ik}$ ncnvrg = .false. toofew = .false. ! quick return if possible - m = 0 + m = 0_${ik}$ if( n==0 ) return ! simplification: - if( irange==indrng .and. il==1 .and. iu==n ) irange = 1 + if( irange==indrng .and. il==1_${ik}$ .and. iu==n ) irange = 1_${ik}$ ! get machine constants - eps = stdlib_slamch( 'P' ) - uflow = stdlib_slamch( 'U' ) - ! special case when n=1 + eps = stdlib${ii}$_slamch( 'P' ) + uflow = stdlib${ii}$_slamch( 'U' ) + ! special case when n=1_${ik}$ ! treat case of 1x1 matrix for quick return - if( n==1 ) then - if( (irange==allrng).or.((irange==valrng).and.(d(1)>vl).and.(d(1)<=vu)).or.((& - irange==indrng).and.(il==1).and.(iu==1)) ) then - m = 1 - w(1) = d(1) + if( n==1_${ik}$ ) then + if( (irange==allrng).or.((irange==valrng).and.(d(1_${ik}$)>vl).and.(d(1_${ik}$)<=vu)).or.((& + irange==indrng).and.(il==1_${ik}$).and.(iu==1_${ik}$)) ) then + m = 1_${ik}$ + w(1_${ik}$) = d(1_${ik}$) ! the computation error of the eigenvalue is zero - werr(1) = zero - iblock( 1 ) = 1 - indexw( 1 ) = 1 + werr(1_${ik}$) = zero + iblock( 1_${ik}$ ) = 1_${ik}$ + indexw( 1_${ik}$ ) = 1_${ik}$ endif return end if - ! nb is the minimum vector length for vector bisection, or 0 + ! nb is the minimum vector length for vector bisection, or 0_${ik}$ ! if only scalar is to be done. - nb = stdlib_ilaenv( 1, 'SSTEBZ', ' ', n, -1, -1, -1 ) - if( nb<=1 ) nb = 0 + nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'SSTEBZ', ' ', n, -1_${ik}$, -1_${ik}$, -1_${ik}$ ) + if( nb<=1_${ik}$ ) nb = 0_${ik}$ ! find global spectral radius - gl = d(1) - gu = d(1) + gl = d(1_${ik}$) + gu = d(1_${ik}$) do i = 1,n - gl = min( gl, gers( 2*i - 1)) - gu = max( gu, gers(2*i) ) + gl = min( gl, gers( 2_${ik}$*i - 1_${ik}$)) + gu = max( gu, gers(2_${ik}$*i) ) end do ! compute global gerschgorin bounds and spectral diameter tnorm = max( abs( gl ), abs( gu ) ) gl = gl - fudge*tnorm*eps*n - fudge*two*pivmin gu = gu + fudge*tnorm*eps*n + fudge*two*pivmin - ! [jan/28/2009] remove the line below since spdiam variable not use + ! [jan/28_${ik}$/2009_${ik}$] remove the line below since spdiam variable not use ! spdiam = gu - gl - ! input arguments for stdlib_slaebz: + ! input arguments for stdlib${ii}$_slaebz: ! the relative tolerance. an interval (a,b] lies within ! "relative tolerance" if b-a < reltol*max(|a|,|b|), rtoli = reltol @@ -5124,46 +5126,46 @@ module stdlib_linalg_lapack_s if( irange==indrng ) then ! range='i': compute an interval containing eigenvalues ! il through iu. the initial interval [gl,gu] from the global - ! gerschgorin bounds gl and gu is refined by stdlib_slaebz. - itmax = int( ( log( tnorm+pivmin )-log( pivmin ) ) /log( two ),KIND=ilp) + 2 + ! gerschgorin bounds gl and gu is refined by stdlib${ii}$_slaebz. + itmax = int( ( log( tnorm+pivmin )-log( pivmin ) ) /log( two ),KIND=${ik}$) + 2_${ik}$ work( n+1 ) = gl work( n+2 ) = gl work( n+3 ) = gu work( n+4 ) = gu work( n+5 ) = gl work( n+6 ) = gu - iwork( 1 ) = -1 - iwork( 2 ) = -1 - iwork( 3 ) = n + 1 - iwork( 4 ) = n + 1 - iwork( 5 ) = il - 1 - iwork( 6 ) = iu - call stdlib_slaebz( 3, itmax, n, 2, 2, nb, atoli, rtoli, pivmin,d, e, e2, iwork( 5 )& + iwork( 1_${ik}$ ) = -1_${ik}$ + iwork( 2_${ik}$ ) = -1_${ik}$ + iwork( 3_${ik}$ ) = n + 1_${ik}$ + iwork( 4_${ik}$ ) = n + 1_${ik}$ + iwork( 5_${ik}$ ) = il - 1_${ik}$ + iwork( 6_${ik}$ ) = iu + call stdlib${ii}$_slaebz( 3_${ik}$, itmax, n, 2_${ik}$, 2_${ik}$, nb, atoli, rtoli, pivmin,d, e, e2, iwork( 5_${ik}$ )& , work( n+1 ), work( n+5 ), iout,iwork, w, iblock, iinfo ) - if( iinfo /= 0 ) then + if( iinfo /= 0_${ik}$ ) then info = iinfo return end if ! on exit, output intervals may not be ordered by ascending negcount - if( iwork( 6 )==iu ) then + if( iwork( 6_${ik}$ )==iu ) then wl = work( n+1 ) wlu = work( n+3 ) - nwl = iwork( 1 ) + nwl = iwork( 1_${ik}$ ) wu = work( n+4 ) wul = work( n+2 ) - nwu = iwork( 4 ) + nwu = iwork( 4_${ik}$ ) else wl = work( n+2 ) wlu = work( n+4 ) - nwl = iwork( 2 ) + nwl = iwork( 2_${ik}$ ) wu = work( n+3 ) wul = work( n+1 ) - nwu = iwork( 3 ) + nwu = iwork( 3_${ik}$ ) end if ! on exit, the interval [wl, wlu] contains a value with negcount nwl, ! and [wul, wu] contains a value with negcount nwu. - if( nwl<0 .or. nwl>=n .or. nwu<1 .or. nwu>n ) then - info = 4 + if( nwl<0_${ik}$ .or. nwl>=n .or. nwu<1_${ik}$ .or. nwu>n ) then + info = 4_${ik}$ return end if elseif( irange==valrng ) then @@ -5176,32 +5178,32 @@ module stdlib_linalg_lapack_s ! find eigenvalues -- loop over blocks and recompute nwl and nwu. ! nwl accumulates the number of eigenvalues .le. wl, ! nwu accumulates the number of eigenvalues .le. wu - m = 0 - iend = 0 - info = 0 - nwl = 0 - nwu = 0 + m = 0_${ik}$ + iend = 0_${ik}$ + info = 0_${ik}$ + nwl = 0_${ik}$ + nwu = 0_${ik}$ loop_70: do jblk = 1, nsplit ioff = iend - ibegin = ioff + 1 + ibegin = ioff + 1_${ik}$ iend = isplit( jblk ) in = iend - ioff - if( in==1 ) then - ! 1x1 block - if( wl>=d( ibegin )-pivmin )nwl = nwl + 1 - if( wu>=d( ibegin )-pivmin )nwu = nwu + 1 + if( in==1_${ik}$ ) then + ! 1_${ik}$x1 block + if( wl>=d( ibegin )-pivmin )nwl = nwl + 1_${ik}$ + if( wu>=d( ibegin )-pivmin )nwu = nwu + 1_${ik}$ if( irange==allrng .or.( wl= d( ibegin )-pivmin ) ) & then - m = m + 1 + m = m + 1_${ik}$ w( m ) = d( ibegin ) werr(m) = zero ! the gap for a single block doesn't matter for the later ! algorithm and is assigned an arbitrary large value iblock( m ) = jblk - indexw( m ) = 1 + indexw( m ) = 1_${ik}$ end if - ! disabled 2x2 case because of a failure on the following matrix - ! range = 'i', il = iu = 4 + ! disabled 2_${ik}$x2 case because of a failure on the following matrix + ! range = 'i', il = iu = 4_${ik}$ ! original tridiagonal, d = [ ! -0.150102010615740e+00_sp ! -0.849897989384260e+00_sp @@ -5213,58 +5215,58 @@ module stdlib_linalg_lapack_s ! -0.180411241501588e-15_sp ! -0.175152352710251e-15_sp ! ]; - ! else if( in==2 ) then - ! * 2x2 block - ! disc = sqrt( (half*(d(ibegin)-d(iend)))**2 + e(ibegin)**2 ) + ! else if( in==2_${ik}$ ) then + ! * 2_${ik}$x2 block + ! disc = sqrt( (half*(d(ibegin)-d(iend)))**2_${ik}$ + e(ibegin)**2_${ik}$ ) ! tmp1 = half*(d(ibegin)+d(iend)) ! l1 = tmp1 - disc ! if( wl>= l1-pivmin ) - ! $ nwl = nwl + 1 + ! $ nwl = nwl + 1_${ik}$ ! if( wu>= l1-pivmin ) - ! $ nwu = nwu + 1 + ! $ nwu = nwu + 1_${ik}$ ! if( irange==allrng .or. ( wl= ! $ l1-pivmin ) ) then - ! m = m + 1 + ! m = m + 1_${ik}$ ! w( m ) = l1 - ! * the uncertainty of eigenvalues of a 2x2 matrix is very small + ! * the uncertainty of eigenvalues of a 2_${ik}$x2 matrix is very small ! werr( m ) = eps * abs( w( m ) ) * two ! iblock( m ) = jblk - ! indexw( m ) = 1 + ! indexw( m ) = 1_${ik}$ ! endif ! l2 = tmp1 + disc ! if( wl>= l2-pivmin ) - ! $ nwl = nwl + 1 + ! $ nwl = nwl + 1_${ik}$ ! if( wu>= l2-pivmin ) - ! $ nwu = nwu + 1 + ! $ nwu = nwu + 1_${ik}$ ! if( irange==allrng .or. ( wl= ! $ l2-pivmin ) ) then - ! m = m + 1 + ! m = m + 1_${ik}$ ! w( m ) = l2 - ! * the uncertainty of eigenvalues of a 2x2 matrix is very small + ! * the uncertainty of eigenvalues of a 2_${ik}$x2 matrix is very small ! werr( m ) = eps * abs( w( m ) ) * two ! iblock( m ) = jblk - ! indexw( m ) = 2 + ! indexw( m ) = 2_${ik}$ ! endif else - ! general case - block of size in >= 2 + ! general case - block of size in >= 2_${ik}$ ! compute local gerschgorin interval and use it as the initial - ! interval for stdlib_slaebz + ! interval for stdlib${ii}$_slaebz gu = d( ibegin ) gl = d( ibegin ) tmp1 = zero do j = ibegin, iend - gl = min( gl, gers( 2*j - 1)) - gu = max( gu, gers(2*j) ) + gl = min( gl, gers( 2_${ik}$*j - 1_${ik}$)) + gu = max( gu, gers(2_${ik}$*j) ) end do - ! [jan/28/2009] - ! change spdiam by tnorm in lines 2 and 3 thereafter - ! line 1: remove computation of spdiam (not useful anymore) + ! [jan/28_${ik}$/2009_${ik}$] + ! change spdiam by tnorm in lines 2_${ik}$ and 3_${ik}$ thereafter + ! line 1_${ik}$: remove computation of spdiam (not useful anymore) ! spdiam = gu - gl ! gl = gl - fudge*spdiam*eps*in - fudge*pivmin ! gu = gu + fudge*spdiam*eps*in + fudge*pivmin gl = gl - fudge*tnorm*eps*in - fudge*pivmin gu = gu + fudge*tnorm*eps*in + fudge*pivmin - if( irange>1 ) then + if( irange>1_${ik}$ ) then if( gu iu, discard extra eigenvalues. if( irange==indrng ) then - idiscl = il - 1 - nwl + idiscl = il - 1_${ik}$ - nwl idiscu = nwu - iu - if( idiscl>0 ) then - im = 0 + if( idiscl>0_${ik}$ ) then + im = 0_${ik}$ do je = 1, m ! remove some of the smallest eigenvalues from the left so that ! at the end idiscl =0. move all eigenvalues up to the left. - if( w( je )<=wlu .and. idiscl>0 ) then - idiscl = idiscl - 1 + if( w( je )<=wlu .and. idiscl>0_${ik}$ ) then + idiscl = idiscl - 1_${ik}$ else - im = im + 1 + im = im + 1_${ik}$ w( im ) = w( je ) werr( im ) = werr( je ) indexw( im ) = indexw( je ) @@ -5346,24 +5348,24 @@ module stdlib_linalg_lapack_s end do m = im end if - if( idiscu>0 ) then + if( idiscu>0_${ik}$ ) then ! remove some of the largest eigenvalues from the right so that ! at the end idiscu =0. move all eigenvalues up to the left. im=m+1 do je = m, 1, -1 - if( w( je )>=wul .and. idiscu>0 ) then - idiscu = idiscu - 1 + if( w( je )>=wul .and. idiscu>0_${ik}$ ) then + idiscu = idiscu - 1_${ik}$ else - im = im - 1 + im = im - 1_${ik}$ w( im ) = w( je ) werr( im ) = werr( je ) indexw( im ) = indexw( je ) iblock( im ) = iblock( je ) end if end do - jee = 0 + jee = 0_${ik}$ do je = im, m - jee = jee + 1 + jee = jee + 1_${ik}$ w( jee ) = w( je ) werr( jee ) = werr( je ) indexw( jee ) = indexw( je ) @@ -5371,44 +5373,44 @@ module stdlib_linalg_lapack_s end do m = m-im+1 end if - if( idiscl>0 .or. idiscu>0 ) then + if( idiscl>0_${ik}$ .or. idiscu>0_${ik}$ ) then ! code to deal with effects of bad arithmetic. (if n(w) is ! monotone non-decreasing, this should never happen.) ! some low eigenvalues to be discarded are not in (wl,wlu], ! or high eigenvalues to be discarded are not in (wul,wu] ! so just kill off the smallest idiscl/largest idiscu - ! eigenvalues, by marking the corresponding iblock = 0 - if( idiscl>0 ) then + ! eigenvalues, by marking the corresponding iblock = 0_${ik}$ + if( idiscl>0_${ik}$ ) then wkill = wu do jdisc = 1, idiscl - iw = 0 + iw = 0_${ik}$ do je = 1, m - if( iblock( je )/=0 .and.( w( je )0 ) then + if( idiscu>0_${ik}$ ) then wkill = wl do jdisc = 1, idiscu - iw = 0 + iw = 0_${ik}$ do je = 1, m - if( iblock( je )/=0 .and.( w( je )>=wkill .or. iw==0 ) ) then + if( iblock( je )/=0_${ik}$ .and.( w( je )>=wkill .or. iw==0_${ik}$ ) ) then iw = je wkill = w( je ) end if end do - iblock( iw ) = 0 + iblock( iw ) = 0_${ik}$ end do end if ! now erase all eigenvalues with iblock set to zero - im = 0 + im = 0_${ik}$ do je = 1, m - if( iblock( je )/=0 ) then - im = im + 1 + if( iblock( je )/=0_${ik}$ ) then + im = im + 1_${ik}$ w( im ) = w( je ) werr( im ) = werr( je ) indexw( im ) = indexw( je ) @@ -5417,7 +5419,7 @@ module stdlib_linalg_lapack_s end do m = im end if - if( idiscl<0 .or. idiscu<0 ) then + if( idiscl<0_${ik}$ .or. idiscu<0_${ik}$ ) then toofew = .true. end if end if @@ -5427,9 +5429,9 @@ module stdlib_linalg_lapack_s ! if order='b', do nothing the eigenvalues are already sorted by ! block. ! if order='e', sort the eigenvalues from smallest to largest - if( stdlib_lsame(order,'E') .and. nsplit>1 ) then + if( stdlib_lsame(order,'E') .and. nsplit>1_${ik}$ ) then do je = 1, m - 1 - ie = 0 + ie = 0_${ik}$ tmp1 = w( je ) do j = je + 1, m if( w( j )=i1).and.(i<=i2)) iwork( 2*prev-1 ) = i + 1 + if((i==i1).and.(i=i1).and.(i<=i2)) iwork( 2_${ik}$*prev-1 ) = i + 1_${ik}$ else ! unconverged interval found prev = i @@ -5533,13 +5535,13 @@ module stdlib_linalg_lapack_s ! do while( cnt(left)>i-1 ) fac = one 20 continue - cnt = 0 + cnt = 0_${ik}$ s = left - dplus = d( 1 ) - s - if( dplusi-1 ) then left = left - werr( ii )*fac @@ -5549,21 +5551,21 @@ module stdlib_linalg_lapack_s ! do while( cnt(right)0 ), i.e. there are still unconverged intervals ! and while (iter=i1) iwork( 2*prev-1 ) = next + if(prev>=i1) iwork( 2_${ik}$*prev-1 ) = next end if i = next cycle loop_100 end if prev = i ! perform one bisection step - cnt = 0 + cnt = 0_${ik}$ s = mid - dplus = d( 1 ) - s - if( dplus0 ).and.(iter<=maxitr) ) go to 80 ! at this point, all the intervals have converged do i = savi1, ilast - k = 2*i + k = 2_${ik}$*i ii = i - offset - ! all intervals marked by '0' have been refined. - if( iwork( k-1 )==0 ) then + ! all intervals marked by '0_${ik}$' have been refined. + if( iwork( k-1 )==0_${ik}$ ) then w( ii ) = half*( work( k-1 )+work( k ) ) werr( ii ) = work( k ) - w( ii ) end if end do return - end subroutine stdlib_slarrj + end subroutine stdlib${ii}$_slarrj - pure subroutine stdlib_slarrk( n, iw, gl, gu,d, e2, pivmin, reltol, w, werr, info) + pure subroutine stdlib${ii}$_slarrk( n, iw, gl, gu,d, e2, pivmin, reltol, w, werr, info) !! SLARRK computes one eigenvalue of a symmetric tridiagonal !! matrix T to suitable accuracy. This is an auxiliary code to be !! called from SSTEMR. !! To avoid overflow, the matrix must be scaled so that its - !! largest element is no greater than overflow**(1/2) * underflow**(1/4) in absolute value, and for greatest + !! largest element is no greater than overflow**(1_${ik}$/2_${ik}$) * underflow**(1_${ik}$/4_${ik}$) in absolute value, and for greatest !! accuracy, it should not be much smaller than that. !! See W. Kahan "Accurate Eigenvalues of a Symmetric Tridiagonal !! Matrix", Report CS41, Computer Science Dept., Stanford - !! University, July 21, 1966. + !! University, July 21_${ik}$, 1966. ! -- 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) :: iw, n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: iw, n real(sp), intent(in) :: pivmin, reltol, gl, gu real(sp), intent(out) :: w, werr ! Array Arguments @@ -5662,46 +5664,46 @@ module stdlib_linalg_lapack_s real(sp), parameter :: fudge = two ! Local Scalars - integer(ilp) :: i, it, itmax, negcnt + integer(${ik}$) :: i, it, itmax, negcnt real(sp) :: atoli, eps, left, mid, right, rtoli, tmp1, tmp2, tnorm ! Intrinsic Functions intrinsic :: abs,int,log,max ! Executable Statements ! quick return if possible - if( n<=0 ) then - info = 0 + if( n<=0_${ik}$ ) then + info = 0_${ik}$ return end if ! get machine constants - eps = stdlib_slamch( 'P' ) + eps = stdlib${ii}$_slamch( 'P' ) tnorm = max( abs( gl ), abs( gu ) ) rtoli = reltol atoli = fudge*two*pivmin - itmax = int( ( log( tnorm+pivmin )-log( pivmin ) ) /log( two ),KIND=ilp) + 2 - info = -1 + itmax = int( ( log( tnorm+pivmin )-log( pivmin ) ) /log( two ),KIND=${ik}$) + 2_${ik}$ + info = -1_${ik}$ left = gl - fudge*tnorm*eps*n - fudge*two*pivmin right = gu + fudge*tnorm*eps*n + fudge*two*pivmin - it = 0 + it = 0_${ik}$ 10 continue ! check if interval converged or maximum number of iterations reached tmp1 = abs( right - left ) tmp2 = max( abs(right), abs(left) ) if( tmp1itmax)goto 30 ! count number of negative pivots for mid-point - it = it + 1 + it = it + 1_${ik}$ mid = half * (left + right) - negcnt = 0 - tmp1 = d( 1 ) - mid + negcnt = 0_${ik}$ + tmp1 = d( 1_${ik}$ ) - mid if( abs( tmp1 )=iw) then right = mid @@ -5714,10 +5716,10 @@ module stdlib_linalg_lapack_s w = half * (left + right) werr = half * abs( right - left ) return - end subroutine stdlib_slarrk + end subroutine stdlib${ii}$_slarrk - pure subroutine stdlib_slarrr( n, d, e, info ) + pure subroutine stdlib${ii}$_slarrr( n, d, e, info ) !! Perform tests to decide whether the symmetric tridiagonal matrix T !! warrants expensive computations which guarantee high relative accuracy !! in the eigenvalues. @@ -5725,8 +5727,8 @@ module stdlib_linalg_lapack_s ! -- 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) :: n - integer(ilp), intent(out) :: info + integer(${ik}$), intent(in) :: n + integer(${ik}$), intent(out) :: info ! Array Arguments real(sp), intent(in) :: d(*) real(sp), intent(inout) :: e(*) @@ -5735,40 +5737,40 @@ module stdlib_linalg_lapack_s real(sp), parameter :: relcond = 0.999_sp ! Local Scalars - integer(ilp) :: i + integer(${ik}$) :: i logical(lk) :: yesrel real(sp) :: eps, safmin, smlnum, rmin, tmp, tmp2, offdig, offdig2 ! Intrinsic Functions intrinsic :: abs ! Executable Statements ! quick return if possible - if( n<=0 ) then - info = 0 + if( n<=0_${ik}$ ) then + info = 0_${ik}$ return end if ! as a default, do not go for relative-accuracy preserving computations. - info = 1 - safmin = stdlib_slamch( 'SAFE MINIMUM' ) - eps = stdlib_slamch( 'PRECISION' ) + info = 1_${ik}$ + safmin = stdlib${ii}$_slamch( 'SAFE MINIMUM' ) + eps = stdlib${ii}$_slamch( 'PRECISION' ) smlnum = safmin / eps rmin = sqrt( smlnum ) ! tests for relative accuracy ! test for scaled diagonal dominance ! scale the diagonal entries to one and check whether the sum of the ! off-diagonals is less than one - ! the sdd relative error bounds have a 1/(1- 2*x) factor in them, - ! x = max(offdig + offdig2), so when x is close to 1/2, no relative + ! the sdd relative error bounds have a 1_${ik}$/(1_${ik}$- 2_${ik}$*x) factor in them, + ! x = max(offdig + offdig2), so when x is close to 1_${ik}$/2_${ik}$, no relative ! accuracy is promised. in the notation of the code fragment below, - ! 1/(1 - (offdig + offdig2)) is the condition number. + ! 1_${ik}$/(1_${ik}$ - (offdig + offdig2)) is the condition number. ! we don't think it is worth going into "sdd mode" unless the relative - ! condition number is reasonable, not 1/macheps. + ! condition number is reasonable, not 1_${ik}$/macheps. ! the threshold should be compatible with other thresholds used in the ! code. we set offdig + offdig2 <= .999_sp =: relcond, it corresponds - ! to losing at most 3 decimal digits: 1 / (1 - (offdig + offdig2)) <= 1000 - ! instead of the current offdig + offdig2 < 1 + ! to losing at most 3_${ik}$ decimal digits: 1_${ik}$ / (1_${ik}$ - (offdig + offdig2)) <= 1000_${ik}$ + ! instead of the current offdig + offdig2 < 1_${ik}$ yesrel = .true. offdig = zero - tmp = sqrt(abs(d(1))) + tmp = sqrt(abs(d(1_${ik}$))) if (tmp= 0. The algorithm used to compute these quantities !! incorporates scaling to avoid overflow or underflow in computing the !! square root of the sum of squares. - !! This version is discontinuous in R at F = 0 but it returns the same - !! C and S as SLARTG for complex inputs (F,0) and (G,0). + !! This version is discontinuous in R at F = 0_${ik}$ but it returns the same + !! C and S as SLARTG for complex inputs (F,0_${ik}$) and (G,0_${ik}$). !! This is a more accurate version of the BLAS1 routine SROTG, !! with the following other differences: !! F and G are unchanged on return. - !! If G=0, then C=1 and S=0. - !! If F=0 and (G .ne. 0), then C=0 and S=sign(1,G) without doing any + !! If G=0_${ik}$, then C=1_${ik}$ and S=0. + !! If F=0_${ik}$ and (G .ne. 0_${ik}$), then C=0_${ik}$ and S=sign(1_${ik}$,G) without doing any !! floating point operations (saves work in SBDSQR when !! there are zeros on the diagonal). !! If F exceeds G in magnitude, C will be positive. @@ -5825,7 +5827,7 @@ module stdlib_linalg_lapack_s ! -- lapack auxiliary routine -- ! -- lapack is a software package provided by univ. of tennessee, -- ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- - ! february 2021 + ! february 2021_${ik}$ ! Scalar Arguments real(sp), intent(out) :: c, r, s real(sp), intent(in) :: f, g @@ -5863,18 +5865,18 @@ module stdlib_linalg_lapack_s r = sign( d, f )*u end if return - end subroutine stdlib_slartg + end subroutine stdlib${ii}$_slartg - pure subroutine stdlib_slartgp( f, g, cs, sn, r ) + pure subroutine stdlib${ii}$_slartgp( f, g, cs, sn, r ) !! SLARTGP generates a plane rotation so that - !! [ CS SN ] . [ F ] = [ R ] where CS**2 + SN**2 = 1. - !! [ -SN CS ] [ G ] [ 0 ] - !! This is a slower, more accurate version of the Level 1 BLAS routine SROTG, + !! [ CS SN ] . [ F ] = [ R ] where CS**2_${ik}$ + SN**2_${ik}$ = 1. + !! [ -SN CS ] [ G ] [ 0_${ik}$ ] + !! This is a slower, more accurate version of the Level 1_${ik}$ BLAS routine SROTG, !! with the following other differences: !! F and G are unchanged on return. - !! If G=0, then CS=(+/-)1 and SN=0. - !! If F=0 and (G .ne. 0), then CS=0 and SN=(+/-)1. + !! If G=0_${ik}$, then CS=(+/-)1_${ik}$ and SN=0. + !! If F=0_${ik}$ and (G .ne. 0_${ik}$), then CS=0_${ik}$ and SN=(+/-)1. !! The sign is chosen so that R >= 0. ! -- lapack auxiliary routine -- ! -- lapack is a software package provided by univ. of tennessee, -- @@ -5888,7 +5890,7 @@ module stdlib_linalg_lapack_s ! Local Scalars ! logical first - integer(ilp) :: count, i + integer(${ik}$) :: count, i real(sp) :: eps, f1, g1, safmin, safmn2, safmx2, scale ! Intrinsic Functions intrinsic :: abs,int,log,max,sign,sqrt @@ -5898,10 +5900,10 @@ module stdlib_linalg_lapack_s ! data first / .true. / ! Executable Statements ! if( first ) then - safmin = stdlib_slamch( 'S' ) - eps = stdlib_slamch( 'E' ) - safmn2 = stdlib_slamch( 'B' )**int( log( safmin / eps ) /log( stdlib_slamch( 'B' ) )& - / two,KIND=ilp) + safmin = stdlib${ii}$_slamch( 'S' ) + eps = stdlib${ii}$_slamch( 'E' ) + safmn2 = stdlib${ii}$_slamch( 'B' )**int( log( safmin / eps ) /log( stdlib${ii}$_slamch( 'B' ) )& + / two,KIND=${ik}$) safmx2 = one / safmn2 ! first = .false. ! end if @@ -5918,35 +5920,35 @@ module stdlib_linalg_lapack_s g1 = g scale = max( abs( f1 ), abs( g1 ) ) if( scale>=safmx2 ) then - count = 0 + count = 0_${ik}$ 10 continue - count = count + 1 + count = count + 1_${ik}$ f1 = f1*safmn2 g1 = g1*safmn2 scale = max( abs( f1 ), abs( g1 ) ) if( scale>=safmx2 .and. count < 20)go to 10 - r = sqrt( f1**2+g1**2 ) + r = sqrt( f1**2_${ik}$+g1**2_${ik}$ ) cs = f1 / r sn = g1 / r do i = 1, count r = r*safmx2 end do else if( scale<=safmn2 ) then - count = 0 + count = 0_${ik}$ 30 continue - count = count + 1 + count = count + 1_${ik}$ f1 = f1*safmx2 g1 = g1*safmx2 scale = max( abs( f1 ), abs( g1 ) ) if( scale<=safmn2 )go to 30 - r = sqrt( f1**2+g1**2 ) + r = sqrt( f1**2_${ik}$+g1**2_${ik}$ ) cs = f1 / r sn = g1 / r do i = 1, count r = r*safmn2 end do else - r = sqrt( f1**2+g1**2 ) + r = sqrt( f1**2_${ik}$+g1**2_${ik}$ ) cs = f1 / r sn = g1 / r end if @@ -5957,17 +5959,17 @@ module stdlib_linalg_lapack_s end if end if return - end subroutine stdlib_slartgp + end subroutine stdlib${ii}$_slartgp - pure subroutine stdlib_slartgs( x, y, sigma, cs, sn ) + pure subroutine stdlib${ii}$_slartgs( x, y, sigma, cs, sn ) !! SLARTGS 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. !! The computed CS and SN define a plane rotation satisfying - !! [ CS SN ] . [ X^2 - SIGMA ] = [ R ], - !! [ -SN CS ] [ X * Y ] [ 0 ] - !! with R nonnegative. If X^2 - SIGMA and X * Y are 0, then the + !! [ CS SN ] . [ X^2_${ik}$ - SIGMA ] = [ R ], + !! [ -SN CS ] [ X * Y ] [ 0_${ik}$ ] + !! with R nonnegative. If X^2_${ik}$ - SIGMA and X * Y are 0_${ik}$, then the !! rotation is by PI/2. ! -- lapack computational routine -- ! -- lapack is a software package provided by univ. of tennessee, -- @@ -5979,8 +5981,8 @@ module stdlib_linalg_lapack_s ! Local Scalars real(sp) :: r, s, thresh, w, z - thresh = stdlib_slamch('E') - ! compute the first column of b**t*b - sigma^2*i, up to a scale + thresh = stdlib${ii}$_slamch('E') + ! compute the first column of b**t*b - sigma^2_${ik}$*i, up to a scale ! factor. if( (sigma == zero .and. abs(x) < thresh) .or.(abs(x) == sigma .and. y == zero) ) & then @@ -6007,36 +6009,36 @@ module stdlib_linalg_lapack_s w = s * y end if ! generate the rotation. - ! call stdlib_slartgp( z, w, cs, sn, r ) might seem more natural; - ! reordering the arguments ensures that if z = 0 then the rotation + ! call stdlib${ii}$_slartgp( z, w, cs, sn, r ) might seem more natural; + ! reordering the arguments ensures that if z = 0_${ik}$ then the rotation ! is by pi/2. - call stdlib_slartgp( w, z, sn, cs, r ) + call stdlib${ii}$_slartgp( w, z, sn, cs, r ) return - ! end stdlib_slartgs - end subroutine stdlib_slartgs + ! end stdlib${ii}$_slartgs + end subroutine stdlib${ii}$_slartgs - pure subroutine stdlib_slartv( n, x, incx, y, incy, c, s, incc ) + pure subroutine stdlib${ii}$_slartv( n, x, incx, y, incy, c, s, incc ) !! SLARTV applies a vector of real plane rotations to elements of the - !! real vectors x and y. For i = 1,2,...,n + !! real vectors x and y. For i = 1_${ik}$,2_${ik}$,...,n !! ( x(i) ) := ( c(i) s(i) ) ( x(i) ) !! ( y(i) ) ( -s(i) c(i) ) ( y(i) ) ! -- 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) :: incc, incx, incy, n + integer(${ik}$), intent(in) :: incc, incx, incy, n ! Array Arguments real(sp), intent(in) :: c(*), s(*) real(sp), intent(inout) :: x(*), y(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, ic, ix, iy + integer(${ik}$) :: i, ic, ix, iy real(sp) :: xi, yi ! Executable Statements - ix = 1 - iy = 1 - ic = 1 + ix = 1_${ik}$ + iy = 1_${ik}$ + ic = 1_${ik}$ do i = 1, n xi = x( ix ) yi = y( iy ) @@ -6047,226 +6049,226 @@ module stdlib_linalg_lapack_s ic = ic + incc end do return - end subroutine stdlib_slartv + end subroutine stdlib${ii}$_slartv - pure subroutine stdlib_slaruv( iseed, n, x ) - !! SLARUV returns a vector of n random real numbers from a uniform (0,1) - !! distribution (n <= 128). + pure subroutine stdlib${ii}$_slaruv( iseed, n, x ) + !! SLARUV returns a vector of n random real numbers from a uniform (0_${ik}$,1_${ik}$) + !! distribution (n <= 128_${ik}$). !! This is an auxiliary routine called by SLARNV and CLARNV. ! -- 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) :: n + integer(${ik}$), intent(in) :: n ! Array Arguments - integer(ilp), intent(inout) :: iseed(4) + integer(${ik}$), intent(inout) :: iseed(4_${ik}$) real(sp), intent(out) :: x(n) ! ===================================================================== ! Parameters - integer(ilp), parameter :: lv = 128 - integer(ilp), parameter :: ipw2 = 4096 + integer(${ik}$), parameter :: lv = 128_${ik}$ + integer(${ik}$), parameter :: ipw2 = 4096_${ik}$ real(sp), parameter :: r = one/ipw2 ! Local Scalars - integer(ilp) :: i, i1, i2, i3, i4, it1, it2, it3, it4 + integer(${ik}$) :: i, i1, i2, i3, i4, it1, it2, it3, it4 ! Local Arrays - integer(ilp) :: mm(lv,4) + integer(${ik}$) :: mm(lv,4_${ik}$) ! Intrinsic Functions intrinsic :: min,mod,real ! Data Statements - mm(1,1:4)=[494,322,2508,2549] - mm(2,1:4)=[2637,789,3754,1145] - mm(3,1:4)=[255,1440,1766,2253] - mm(4,1:4)=[2008,752,3572,305] - mm(5,1:4)=[1253,2859,2893,3301] - mm(6,1:4)=[3344,123,307,1065] - mm(7,1:4)=[4084,1848,1297,3133] - mm(8,1:4)=[1739,643,3966,2913] - mm(9,1:4)=[3143,2405,758,3285] - mm(10,1:4)=[3468,2638,2598,1241] - mm(11,1:4)=[688,2344,3406,1197] - mm(12,1:4)=[1657,46,2922,3729] - mm(13,1:4)=[1238,3814,1038,2501] - mm(14,1:4)=[3166,913,2934,1673] - mm(15,1:4)=[1292,3649,2091,541] - mm(16,1:4)=[3422,339,2451,2753] - mm(17,1:4)=[1270,3808,1580,949] - mm(18,1:4)=[2016,822,1958,2361] - mm(19,1:4)=[154,2832,2055,1165] - mm(20,1:4)=[2862,3078,1507,4081] - mm(21,1:4)=[697,3633,1078,2725] - mm(22,1:4)=[1706,2970,3273,3305] - mm(23,1:4)=[491,637,17,3069] - mm(24,1:4)=[931,2249,854,3617] - mm(25,1:4)=[1444,2081,2916,3733] - mm(26,1:4)=[444,4019,3971,409] - mm(27,1:4)=[3577,1478,2889,2157] - mm(28,1:4)=[3944,242,3831,1361] - mm(29,1:4)=[2184,481,2621,3973] - mm(30,1:4)=[1661,2075,1541,1865] - mm(31,1:4)=[3482,4058,893,2525] - mm(32,1:4)=[657,622,736,1409] - mm(33,1:4)=[3023,3376,3992,3445] - mm(34,1:4)=[3618,812,787,3577] - mm(35,1:4)=[1267,234,2125,77] - mm(36,1:4)=[1828,641,2364,3761] - mm(37,1:4)=[164,4005,2460,2149] - mm(38,1:4)=[3798,1122,257,1449] - mm(39,1:4)=[3087,3135,1574,3005] - mm(40,1:4)=[2400,2640,3912,225] - mm(41,1:4)=[2870,2302,1216,85] - mm(42,1:4)=[3876,40,3248,3673] - mm(43,1:4)=[1905,1832,3401,3117] - mm(44,1:4)=[1593,2247,2124,3089] - mm(45,1:4)=[1797,2034,2762,1349] - mm(46,1:4)=[1234,2637,149,2057] - mm(47,1:4)=[3460,1287,2245,413] - mm(48,1:4)=[328,1691,166,65] - mm(49,1:4)=[2861,496,466,1845] - mm(50,1:4)=[1950,1597,4018,697] - mm(51,1:4)=[617,2394,1399,3085] - mm(52,1:4)=[2070,2584,190,3441] - mm(53,1:4)=[3331,1843,2879,1573] - mm(54,1:4)=[769,336,153,3689] - mm(55,1:4)=[1558,1472,2320,2941] - mm(56,1:4)=[2412,2407,18,929] - mm(57,1:4)=[2800,433,712,533] - mm(58,1:4)=[189,2096,2159,2841] - mm(59,1:4)=[287,1761,2318,4077] - mm(60,1:4)=[2045,2810,2091,721] - mm(61,1:4)=[1227,566,3443,2821] - mm(62,1:4)=[2838,442,1510,2249] - mm(63,1:4)=[209,41,449,2397] - mm(64,1:4)=[2770,1238,1956,2817] - mm(65,1:4)=[3654,1086,2201,245] - mm(66,1:4)=[3993,603,3137,1913] - mm(67,1:4)=[192,840,3399,1997] - mm(68,1:4)=[2253,3168,1321,3121] - mm(69,1:4)=[3491,1499,2271,997] - mm(70,1:4)=[2889,1084,3667,1833] - mm(71,1:4)=[2857,3438,2703,2877] - mm(72,1:4)=[2094,2408,629,1633] - mm(73,1:4)=[1818,1589,2365,981] - mm(74,1:4)=[688,2391,2431,2009] - mm(75,1:4)=[1407,288,1113,941] - mm(76,1:4)=[634,26,3922,2449] - mm(77,1:4)=[3231,512,2554,197] - mm(78,1:4)=[815,1456,184,2441] - mm(79,1:4)=[3524,171,2099,285] - mm(80,1:4)=[1914,1677,3228,1473] - mm(81,1:4)=[516,2657,4012,2741] - mm(82,1:4)=[164,2270,1921,3129] - mm(83,1:4)=[303,2587,3452,909] - mm(84,1:4)=[2144,2961,3901,2801] - mm(85,1:4)=[3480,1970,572,421] - mm(86,1:4)=[119,1817,3309,4073] - mm(87,1:4)=[3357,676,3171,2813] - mm(88,1:4)=[837,1410,817,2337] - mm(89,1:4)=[2826,3723,3039,1429] - mm(90,1:4)=[2332,2803,1696,1177] - mm(91,1:4)=[2089,3185,1256,1901] - mm(92,1:4)=[3780,184,3715,81] - mm(93,1:4)=[1700,663,2077,1669] - mm(94,1:4)=[3712,499,3019,2633] - mm(95,1:4)=[150,3784,1497,2269] - mm(96,1:4)=[2000,1631,1101,129] - mm(97,1:4)=[3375,1925,717,1141] - mm(98,1:4)=[1621,3912,51,249] - mm(99,1:4)=[3090,1398,981,3917] - mm(100,1:4)=[3765,1349,1978,2481] - mm(101,1:4)=[1149,1441,1813,3941] - mm(102,1:4)=[3146,2224,3881,2217] - mm(103,1:4)=[33,2411,76,2749] - mm(104,1:4)=[3082,1907,3846,3041] - mm(105,1:4)=[2741,3192,3694,1877] - mm(106,1:4)=[359,2786,1682,345] - mm(107,1:4)=[3316,382,124,2861] - mm(108,1:4)=[1749,37,1660,1809] - mm(109,1:4)=[185,759,3997,3141] - mm(110,1:4)=[2784,2948,479,2825] - mm(111,1:4)=[2202,1862,1141,157] - mm(112,1:4)=[2199,3802,886,2881] - mm(113,1:4)=[1364,2423,3514,3637] - mm(114,1:4)=[1244,2051,1301,1465] - mm(115,1:4)=[2020,2295,3604,2829] - mm(116,1:4)=[3160,1332,1888,2161] - mm(117,1:4)=[2785,1832,1836,3365] - mm(118,1:4)=[2772,2405,1990,361] - mm(119,1:4)=[1217,3638,2058,2685] - mm(120,1:4)=[1822,3661,692,3745] - mm(121,1:4)=[1245,327,1194,2325] - mm(122,1:4)=[2252,3660,20,3609] - mm(123,1:4)=[3904,716,3285,3821] - mm(124,1:4)=[2774,1842,2046,3537] - mm(125,1:4)=[997,3987,2107,517] - mm(126,1:4)=[2573,1368,3508,3017] - mm(127,1:4)=[1148,1848,3525,2141] - mm(128,1:4)=[545,2366,3801,1537] + mm(1_${ik}$,1_${ik}$:4_${ik}$)=[494_${ik}$,322_${ik}$,2508_${ik}$,2549_${ik}$] + mm(2_${ik}$,1_${ik}$:4_${ik}$)=[2637_${ik}$,789_${ik}$,3754_${ik}$,1145_${ik}$] + mm(3_${ik}$,1_${ik}$:4_${ik}$)=[255_${ik}$,1440_${ik}$,1766_${ik}$,2253_${ik}$] + mm(4_${ik}$,1_${ik}$:4_${ik}$)=[2008_${ik}$,752_${ik}$,3572_${ik}$,305_${ik}$] + mm(5_${ik}$,1_${ik}$:4_${ik}$)=[1253_${ik}$,2859_${ik}$,2893_${ik}$,3301_${ik}$] + mm(6_${ik}$,1_${ik}$:4_${ik}$)=[3344_${ik}$,123_${ik}$,307_${ik}$,1065_${ik}$] + mm(7_${ik}$,1_${ik}$:4_${ik}$)=[4084_${ik}$,1848_${ik}$,1297_${ik}$,3133_${ik}$] + mm(8_${ik}$,1_${ik}$:4_${ik}$)=[1739_${ik}$,643_${ik}$,3966_${ik}$,2913_${ik}$] + mm(9_${ik}$,1_${ik}$:4_${ik}$)=[3143_${ik}$,2405_${ik}$,758_${ik}$,3285_${ik}$] + mm(10_${ik}$,1_${ik}$:4_${ik}$)=[3468_${ik}$,2638_${ik}$,2598_${ik}$,1241_${ik}$] + mm(11_${ik}$,1_${ik}$:4_${ik}$)=[688_${ik}$,2344_${ik}$,3406_${ik}$,1197_${ik}$] + mm(12_${ik}$,1_${ik}$:4_${ik}$)=[1657_${ik}$,46_${ik}$,2922_${ik}$,3729_${ik}$] + mm(13_${ik}$,1_${ik}$:4_${ik}$)=[1238_${ik}$,3814_${ik}$,1038_${ik}$,2501_${ik}$] + mm(14_${ik}$,1_${ik}$:4_${ik}$)=[3166_${ik}$,913_${ik}$,2934_${ik}$,1673_${ik}$] + mm(15_${ik}$,1_${ik}$:4_${ik}$)=[1292_${ik}$,3649_${ik}$,2091_${ik}$,541_${ik}$] + mm(16_${ik}$,1_${ik}$:4_${ik}$)=[3422_${ik}$,339_${ik}$,2451_${ik}$,2753_${ik}$] + mm(17_${ik}$,1_${ik}$:4_${ik}$)=[1270_${ik}$,3808_${ik}$,1580_${ik}$,949_${ik}$] + mm(18_${ik}$,1_${ik}$:4_${ik}$)=[2016_${ik}$,822_${ik}$,1958_${ik}$,2361_${ik}$] + mm(19_${ik}$,1_${ik}$:4_${ik}$)=[154_${ik}$,2832_${ik}$,2055_${ik}$,1165_${ik}$] + mm(20_${ik}$,1_${ik}$:4_${ik}$)=[2862_${ik}$,3078_${ik}$,1507_${ik}$,4081_${ik}$] + mm(21_${ik}$,1_${ik}$:4_${ik}$)=[697_${ik}$,3633_${ik}$,1078_${ik}$,2725_${ik}$] + mm(22_${ik}$,1_${ik}$:4_${ik}$)=[1706_${ik}$,2970_${ik}$,3273_${ik}$,3305_${ik}$] + mm(23_${ik}$,1_${ik}$:4_${ik}$)=[491_${ik}$,637_${ik}$,17_${ik}$,3069_${ik}$] + mm(24_${ik}$,1_${ik}$:4_${ik}$)=[931_${ik}$,2249_${ik}$,854_${ik}$,3617_${ik}$] + mm(25_${ik}$,1_${ik}$:4_${ik}$)=[1444_${ik}$,2081_${ik}$,2916_${ik}$,3733_${ik}$] + mm(26_${ik}$,1_${ik}$:4_${ik}$)=[444_${ik}$,4019_${ik}$,3971_${ik}$,409_${ik}$] + mm(27_${ik}$,1_${ik}$:4_${ik}$)=[3577_${ik}$,1478_${ik}$,2889_${ik}$,2157_${ik}$] + mm(28_${ik}$,1_${ik}$:4_${ik}$)=[3944_${ik}$,242_${ik}$,3831_${ik}$,1361_${ik}$] + mm(29_${ik}$,1_${ik}$:4_${ik}$)=[2184_${ik}$,481_${ik}$,2621_${ik}$,3973_${ik}$] + mm(30_${ik}$,1_${ik}$:4_${ik}$)=[1661_${ik}$,2075_${ik}$,1541_${ik}$,1865_${ik}$] + mm(31_${ik}$,1_${ik}$:4_${ik}$)=[3482_${ik}$,4058_${ik}$,893_${ik}$,2525_${ik}$] + mm(32_${ik}$,1_${ik}$:4_${ik}$)=[657_${ik}$,622_${ik}$,736_${ik}$,1409_${ik}$] + mm(33_${ik}$,1_${ik}$:4_${ik}$)=[3023_${ik}$,3376_${ik}$,3992_${ik}$,3445_${ik}$] + mm(34_${ik}$,1_${ik}$:4_${ik}$)=[3618_${ik}$,812_${ik}$,787_${ik}$,3577_${ik}$] + mm(35_${ik}$,1_${ik}$:4_${ik}$)=[1267_${ik}$,234_${ik}$,2125_${ik}$,77_${ik}$] + mm(36_${ik}$,1_${ik}$:4_${ik}$)=[1828_${ik}$,641_${ik}$,2364_${ik}$,3761_${ik}$] + mm(37_${ik}$,1_${ik}$:4_${ik}$)=[164_${ik}$,4005_${ik}$,2460_${ik}$,2149_${ik}$] + mm(38_${ik}$,1_${ik}$:4_${ik}$)=[3798_${ik}$,1122_${ik}$,257_${ik}$,1449_${ik}$] + mm(39_${ik}$,1_${ik}$:4_${ik}$)=[3087_${ik}$,3135_${ik}$,1574_${ik}$,3005_${ik}$] + mm(40_${ik}$,1_${ik}$:4_${ik}$)=[2400_${ik}$,2640_${ik}$,3912_${ik}$,225_${ik}$] + mm(41_${ik}$,1_${ik}$:4_${ik}$)=[2870_${ik}$,2302_${ik}$,1216_${ik}$,85_${ik}$] + mm(42_${ik}$,1_${ik}$:4_${ik}$)=[3876_${ik}$,40_${ik}$,3248_${ik}$,3673_${ik}$] + mm(43_${ik}$,1_${ik}$:4_${ik}$)=[1905_${ik}$,1832_${ik}$,3401_${ik}$,3117_${ik}$] + mm(44_${ik}$,1_${ik}$:4_${ik}$)=[1593_${ik}$,2247_${ik}$,2124_${ik}$,3089_${ik}$] + mm(45_${ik}$,1_${ik}$:4_${ik}$)=[1797_${ik}$,2034_${ik}$,2762_${ik}$,1349_${ik}$] + mm(46_${ik}$,1_${ik}$:4_${ik}$)=[1234_${ik}$,2637_${ik}$,149_${ik}$,2057_${ik}$] + mm(47_${ik}$,1_${ik}$:4_${ik}$)=[3460_${ik}$,1287_${ik}$,2245_${ik}$,413_${ik}$] + mm(48_${ik}$,1_${ik}$:4_${ik}$)=[328_${ik}$,1691_${ik}$,166_${ik}$,65_${ik}$] + mm(49_${ik}$,1_${ik}$:4_${ik}$)=[2861_${ik}$,496_${ik}$,466_${ik}$,1845_${ik}$] + mm(50_${ik}$,1_${ik}$:4_${ik}$)=[1950_${ik}$,1597_${ik}$,4018_${ik}$,697_${ik}$] + mm(51_${ik}$,1_${ik}$:4_${ik}$)=[617_${ik}$,2394_${ik}$,1399_${ik}$,3085_${ik}$] + mm(52_${ik}$,1_${ik}$:4_${ik}$)=[2070_${ik}$,2584_${ik}$,190_${ik}$,3441_${ik}$] + mm(53_${ik}$,1_${ik}$:4_${ik}$)=[3331_${ik}$,1843_${ik}$,2879_${ik}$,1573_${ik}$] + mm(54_${ik}$,1_${ik}$:4_${ik}$)=[769_${ik}$,336_${ik}$,153_${ik}$,3689_${ik}$] + mm(55_${ik}$,1_${ik}$:4_${ik}$)=[1558_${ik}$,1472_${ik}$,2320_${ik}$,2941_${ik}$] + mm(56_${ik}$,1_${ik}$:4_${ik}$)=[2412_${ik}$,2407_${ik}$,18_${ik}$,929_${ik}$] + mm(57_${ik}$,1_${ik}$:4_${ik}$)=[2800_${ik}$,433_${ik}$,712_${ik}$,533_${ik}$] + mm(58_${ik}$,1_${ik}$:4_${ik}$)=[189_${ik}$,2096_${ik}$,2159_${ik}$,2841_${ik}$] + mm(59_${ik}$,1_${ik}$:4_${ik}$)=[287_${ik}$,1761_${ik}$,2318_${ik}$,4077_${ik}$] + mm(60_${ik}$,1_${ik}$:4_${ik}$)=[2045_${ik}$,2810_${ik}$,2091_${ik}$,721_${ik}$] + mm(61_${ik}$,1_${ik}$:4_${ik}$)=[1227_${ik}$,566_${ik}$,3443_${ik}$,2821_${ik}$] + mm(62_${ik}$,1_${ik}$:4_${ik}$)=[2838_${ik}$,442_${ik}$,1510_${ik}$,2249_${ik}$] + mm(63_${ik}$,1_${ik}$:4_${ik}$)=[209_${ik}$,41_${ik}$,449_${ik}$,2397_${ik}$] + mm(64_${ik}$,1_${ik}$:4_${ik}$)=[2770_${ik}$,1238_${ik}$,1956_${ik}$,2817_${ik}$] + mm(65_${ik}$,1_${ik}$:4_${ik}$)=[3654_${ik}$,1086_${ik}$,2201_${ik}$,245_${ik}$] + mm(66_${ik}$,1_${ik}$:4_${ik}$)=[3993_${ik}$,603_${ik}$,3137_${ik}$,1913_${ik}$] + mm(67_${ik}$,1_${ik}$:4_${ik}$)=[192_${ik}$,840_${ik}$,3399_${ik}$,1997_${ik}$] + mm(68_${ik}$,1_${ik}$:4_${ik}$)=[2253_${ik}$,3168_${ik}$,1321_${ik}$,3121_${ik}$] + mm(69_${ik}$,1_${ik}$:4_${ik}$)=[3491_${ik}$,1499_${ik}$,2271_${ik}$,997_${ik}$] + mm(70_${ik}$,1_${ik}$:4_${ik}$)=[2889_${ik}$,1084_${ik}$,3667_${ik}$,1833_${ik}$] + mm(71_${ik}$,1_${ik}$:4_${ik}$)=[2857_${ik}$,3438_${ik}$,2703_${ik}$,2877_${ik}$] + mm(72_${ik}$,1_${ik}$:4_${ik}$)=[2094_${ik}$,2408_${ik}$,629_${ik}$,1633_${ik}$] + mm(73_${ik}$,1_${ik}$:4_${ik}$)=[1818_${ik}$,1589_${ik}$,2365_${ik}$,981_${ik}$] + mm(74_${ik}$,1_${ik}$:4_${ik}$)=[688_${ik}$,2391_${ik}$,2431_${ik}$,2009_${ik}$] + mm(75_${ik}$,1_${ik}$:4_${ik}$)=[1407_${ik}$,288_${ik}$,1113_${ik}$,941_${ik}$] + mm(76_${ik}$,1_${ik}$:4_${ik}$)=[634_${ik}$,26_${ik}$,3922_${ik}$,2449_${ik}$] + mm(77_${ik}$,1_${ik}$:4_${ik}$)=[3231_${ik}$,512_${ik}$,2554_${ik}$,197_${ik}$] + mm(78_${ik}$,1_${ik}$:4_${ik}$)=[815_${ik}$,1456_${ik}$,184_${ik}$,2441_${ik}$] + mm(79_${ik}$,1_${ik}$:4_${ik}$)=[3524_${ik}$,171_${ik}$,2099_${ik}$,285_${ik}$] + mm(80_${ik}$,1_${ik}$:4_${ik}$)=[1914_${ik}$,1677_${ik}$,3228_${ik}$,1473_${ik}$] + mm(81_${ik}$,1_${ik}$:4_${ik}$)=[516_${ik}$,2657_${ik}$,4012_${ik}$,2741_${ik}$] + mm(82_${ik}$,1_${ik}$:4_${ik}$)=[164_${ik}$,2270_${ik}$,1921_${ik}$,3129_${ik}$] + mm(83_${ik}$,1_${ik}$:4_${ik}$)=[303_${ik}$,2587_${ik}$,3452_${ik}$,909_${ik}$] + mm(84_${ik}$,1_${ik}$:4_${ik}$)=[2144_${ik}$,2961_${ik}$,3901_${ik}$,2801_${ik}$] + mm(85_${ik}$,1_${ik}$:4_${ik}$)=[3480_${ik}$,1970_${ik}$,572_${ik}$,421_${ik}$] + mm(86_${ik}$,1_${ik}$:4_${ik}$)=[119_${ik}$,1817_${ik}$,3309_${ik}$,4073_${ik}$] + mm(87_${ik}$,1_${ik}$:4_${ik}$)=[3357_${ik}$,676_${ik}$,3171_${ik}$,2813_${ik}$] + mm(88_${ik}$,1_${ik}$:4_${ik}$)=[837_${ik}$,1410_${ik}$,817_${ik}$,2337_${ik}$] + mm(89_${ik}$,1_${ik}$:4_${ik}$)=[2826_${ik}$,3723_${ik}$,3039_${ik}$,1429_${ik}$] + mm(90_${ik}$,1_${ik}$:4_${ik}$)=[2332_${ik}$,2803_${ik}$,1696_${ik}$,1177_${ik}$] + mm(91_${ik}$,1_${ik}$:4_${ik}$)=[2089_${ik}$,3185_${ik}$,1256_${ik}$,1901_${ik}$] + mm(92_${ik}$,1_${ik}$:4_${ik}$)=[3780_${ik}$,184_${ik}$,3715_${ik}$,81_${ik}$] + mm(93_${ik}$,1_${ik}$:4_${ik}$)=[1700_${ik}$,663_${ik}$,2077_${ik}$,1669_${ik}$] + mm(94_${ik}$,1_${ik}$:4_${ik}$)=[3712_${ik}$,499_${ik}$,3019_${ik}$,2633_${ik}$] + mm(95_${ik}$,1_${ik}$:4_${ik}$)=[150_${ik}$,3784_${ik}$,1497_${ik}$,2269_${ik}$] + mm(96_${ik}$,1_${ik}$:4_${ik}$)=[2000_${ik}$,1631_${ik}$,1101_${ik}$,129_${ik}$] + mm(97_${ik}$,1_${ik}$:4_${ik}$)=[3375_${ik}$,1925_${ik}$,717_${ik}$,1141_${ik}$] + mm(98_${ik}$,1_${ik}$:4_${ik}$)=[1621_${ik}$,3912_${ik}$,51_${ik}$,249_${ik}$] + mm(99_${ik}$,1_${ik}$:4_${ik}$)=[3090_${ik}$,1398_${ik}$,981_${ik}$,3917_${ik}$] + mm(100_${ik}$,1_${ik}$:4_${ik}$)=[3765_${ik}$,1349_${ik}$,1978_${ik}$,2481_${ik}$] + mm(101_${ik}$,1_${ik}$:4_${ik}$)=[1149_${ik}$,1441_${ik}$,1813_${ik}$,3941_${ik}$] + mm(102_${ik}$,1_${ik}$:4_${ik}$)=[3146_${ik}$,2224_${ik}$,3881_${ik}$,2217_${ik}$] + mm(103_${ik}$,1_${ik}$:4_${ik}$)=[33_${ik}$,2411_${ik}$,76_${ik}$,2749_${ik}$] + mm(104_${ik}$,1_${ik}$:4_${ik}$)=[3082_${ik}$,1907_${ik}$,3846_${ik}$,3041_${ik}$] + mm(105_${ik}$,1_${ik}$:4_${ik}$)=[2741_${ik}$,3192_${ik}$,3694_${ik}$,1877_${ik}$] + mm(106_${ik}$,1_${ik}$:4_${ik}$)=[359_${ik}$,2786_${ik}$,1682_${ik}$,345_${ik}$] + mm(107_${ik}$,1_${ik}$:4_${ik}$)=[3316_${ik}$,382_${ik}$,124_${ik}$,2861_${ik}$] + mm(108_${ik}$,1_${ik}$:4_${ik}$)=[1749_${ik}$,37_${ik}$,1660_${ik}$,1809_${ik}$] + mm(109_${ik}$,1_${ik}$:4_${ik}$)=[185_${ik}$,759_${ik}$,3997_${ik}$,3141_${ik}$] + mm(110_${ik}$,1_${ik}$:4_${ik}$)=[2784_${ik}$,2948_${ik}$,479_${ik}$,2825_${ik}$] + mm(111_${ik}$,1_${ik}$:4_${ik}$)=[2202_${ik}$,1862_${ik}$,1141_${ik}$,157_${ik}$] + mm(112_${ik}$,1_${ik}$:4_${ik}$)=[2199_${ik}$,3802_${ik}$,886_${ik}$,2881_${ik}$] + mm(113_${ik}$,1_${ik}$:4_${ik}$)=[1364_${ik}$,2423_${ik}$,3514_${ik}$,3637_${ik}$] + mm(114_${ik}$,1_${ik}$:4_${ik}$)=[1244_${ik}$,2051_${ik}$,1301_${ik}$,1465_${ik}$] + mm(115_${ik}$,1_${ik}$:4_${ik}$)=[2020_${ik}$,2295_${ik}$,3604_${ik}$,2829_${ik}$] + mm(116_${ik}$,1_${ik}$:4_${ik}$)=[3160_${ik}$,1332_${ik}$,1888_${ik}$,2161_${ik}$] + mm(117_${ik}$,1_${ik}$:4_${ik}$)=[2785_${ik}$,1832_${ik}$,1836_${ik}$,3365_${ik}$] + mm(118_${ik}$,1_${ik}$:4_${ik}$)=[2772_${ik}$,2405_${ik}$,1990_${ik}$,361_${ik}$] + mm(119_${ik}$,1_${ik}$:4_${ik}$)=[1217_${ik}$,3638_${ik}$,2058_${ik}$,2685_${ik}$] + mm(120_${ik}$,1_${ik}$:4_${ik}$)=[1822_${ik}$,3661_${ik}$,692_${ik}$,3745_${ik}$] + mm(121_${ik}$,1_${ik}$:4_${ik}$)=[1245_${ik}$,327_${ik}$,1194_${ik}$,2325_${ik}$] + mm(122_${ik}$,1_${ik}$:4_${ik}$)=[2252_${ik}$,3660_${ik}$,20_${ik}$,3609_${ik}$] + mm(123_${ik}$,1_${ik}$:4_${ik}$)=[3904_${ik}$,716_${ik}$,3285_${ik}$,3821_${ik}$] + mm(124_${ik}$,1_${ik}$:4_${ik}$)=[2774_${ik}$,1842_${ik}$,2046_${ik}$,3537_${ik}$] + mm(125_${ik}$,1_${ik}$:4_${ik}$)=[997_${ik}$,3987_${ik}$,2107_${ik}$,517_${ik}$] + mm(126_${ik}$,1_${ik}$:4_${ik}$)=[2573_${ik}$,1368_${ik}$,3508_${ik}$,3017_${ik}$] + mm(127_${ik}$,1_${ik}$:4_${ik}$)=[1148_${ik}$,1848_${ik}$,3525_${ik}$,2141_${ik}$] + mm(128_${ik}$,1_${ik}$:4_${ik}$)=[545_${ik}$,2366_${ik}$,3801_${ik}$,1537_${ik}$] ! Executable Statements - i1 = iseed( 1 ) - i2 = iseed( 2 ) - i3 = iseed( 3 ) - i4 = iseed( 4 ) + i1 = iseed( 1_${ik}$ ) + i2 = iseed( 2_${ik}$ ) + i3 = iseed( 3_${ik}$ ) + i4 = iseed( 4_${ik}$ ) loop_10: do i = 1, min( n, lv ) 20 continue - ! multiply the seed by i-th power of the multiplier modulo 2**48 - it4 = i4*mm( i, 4 ) + ! multiply the seed by i-th power of the multiplier modulo 2_${ik}$**48_${ik}$ + it4 = i4*mm( i, 4_${ik}$ ) it3 = it4 / ipw2 it4 = it4 - ipw2*it3 - it3 = it3 + i3*mm( i, 4 ) + i4*mm( i, 3 ) + it3 = it3 + i3*mm( i, 4_${ik}$ ) + i4*mm( i, 3_${ik}$ ) it2 = it3 / ipw2 it3 = it3 - ipw2*it2 - it2 = it2 + i2*mm( i, 4 ) + i3*mm( i, 3 ) + i4*mm( i, 2 ) + it2 = it2 + i2*mm( i, 4_${ik}$ ) + i3*mm( i, 3_${ik}$ ) + i4*mm( i, 2_${ik}$ ) it1 = it2 / ipw2 it2 = it2 - ipw2*it1 - it1 = it1 + i1*mm( i, 4 ) + i2*mm( i, 3 ) + i3*mm( i, 2 ) +i4*mm( i, 1 ) + it1 = it1 + i1*mm( i, 4_${ik}$ ) + i2*mm( i, 3_${ik}$ ) + i3*mm( i, 2_${ik}$ ) +i4*mm( i, 1_${ik}$ ) it1 = mod( it1, ipw2 ) - ! convert 48-bit integer to a realnumber in the interval (0,1,KIND=sp) + ! convert 48_${ik}$-bit integer to a realnumber in the interval (0_${ik}$,1_${ik}$,KIND=sp) x( i ) = r*( real( it1,KIND=sp)+r*( real( it2,KIND=sp)+r*( real( it3,KIND=sp)+& r*real( it4,KIND=sp) ) ) ) if (x( i )==1.0_sp) 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 + ! n bits of the 48_${ik}$-bit integer above happen to be all 1_${ik}$ (which + ! will occur about once every 2_${ik}$**n calls), then x( i ) will ! be rounded to exactly one. in ieee single precision arithmetic, ! this will happen relatively often since n = 24. ! since x( i ) is not supposed to return exactly 0.0_sp or 1.0_sp, ! the statistically correct thing to do in this situation is ! simply to iterate again. ! n.b. the case x( i ) = 0.0_sp should not be possible. - i1 = i1 + 2 - i2 = i2 + 2 - i3 = i3 + 2 - i4 = i4 + 2 + i1 = i1 + 2_${ik}$ + i2 = i2 + 2_${ik}$ + i3 = i3 + 2_${ik}$ + i4 = i4 + 2_${ik}$ goto 20 end if end do loop_10 ! return final value of seed - iseed( 1 ) = it1 - iseed( 2 ) = it2 - iseed( 3 ) = it3 - iseed( 4 ) = it4 + iseed( 1_${ik}$ ) = it1 + iseed( 2_${ik}$ ) = it2 + iseed( 3_${ik}$ ) = it3 + iseed( 4_${ik}$ ) = it4 return - end subroutine stdlib_slaruv + end subroutine stdlib${ii}$_slaruv - pure subroutine stdlib_slarz( side, m, n, l, v, incv, tau, c, ldc, work ) + pure subroutine stdlib${ii}$_slarz( side, m, n, l, v, incv, tau, c, ldc, work ) !! SLARZ 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 !! where tau is a real scalar and v is a real vector. - !! If tau = 0, then H is taken to be the unit matrix. + !! If tau = 0_${ik}$, then H is taken to be the unit matrix. !! H is a product of k elementary reflectors as returned by STZRZF. ! -- 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, intent(in) :: side - integer(ilp), intent(in) :: incv, l, ldc, m, n + integer(${ik}$), intent(in) :: incv, l, ldc, m, n real(sp), intent(in) :: tau ! Array Arguments real(sp), intent(inout) :: c(ldc,*) @@ -6278,37 +6280,37 @@ module stdlib_linalg_lapack_s if( stdlib_lsame( side, 'L' ) ) then ! form h * c if( tau/=zero ) then - ! w( 1:n ) = c( 1, 1:n ) - call stdlib_scopy( n, c, ldc, work, 1 ) - ! w( 1:n ) = w( 1:n ) + c( m-l+1:m, 1:n )**t * v( 1:l ) - call stdlib_sgemv( '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_saxpy( 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_sger( l, n, -tau, v, incv, work, 1, c( m-l+1, 1 ),ldc ) + ! w( 1_${ik}$:n ) = c( 1_${ik}$, 1_${ik}$:n ) + call stdlib${ii}$_scopy( n, c, ldc, work, 1_${ik}$ ) + ! w( 1_${ik}$:n ) = w( 1_${ik}$:n ) + c( m-l+1:m, 1_${ik}$:n )**t * v( 1_${ik}$:l ) + call stdlib${ii}$_sgemv( 'TRANSPOSE', l, n, one, c( m-l+1, 1_${ik}$ ), ldc, v,incv, one, work,& + 1_${ik}$ ) + ! c( 1_${ik}$, 1_${ik}$:n ) = c( 1_${ik}$, 1_${ik}$:n ) - tau * w( 1_${ik}$:n ) + call stdlib${ii}$_saxpy( n, -tau, work, 1_${ik}$, c, ldc ) + ! c( m-l+1:m, 1_${ik}$:n ) = c( m-l+1:m, 1_${ik}$:n ) - ... + ! tau * v( 1_${ik}$:l ) * w( 1_${ik}$:n )**t + call stdlib${ii}$_sger( l, n, -tau, v, incv, work, 1_${ik}$, c( m-l+1, 1_${ik}$ ),ldc ) end if else ! form c * h if( tau/=zero ) then - ! w( 1:m ) = c( 1:m, 1 ) - call stdlib_scopy( 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_sgemv( '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_saxpy( 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_sger( m, l, -tau, work, 1, v, incv, c( 1, n-l+1 ),ldc ) + ! w( 1_${ik}$:m ) = c( 1_${ik}$:m, 1_${ik}$ ) + call stdlib${ii}$_scopy( m, c, 1_${ik}$, work, 1_${ik}$ ) + ! w( 1_${ik}$:m ) = w( 1_${ik}$:m ) + c( 1_${ik}$:m, n-l+1:n, 1_${ik}$:n ) * v( 1_${ik}$:l ) + call stdlib${ii}$_sgemv( 'NO TRANSPOSE', m, l, one, c( 1_${ik}$, n-l+1 ), ldc,v, incv, one, & + work, 1_${ik}$ ) + ! c( 1_${ik}$:m, 1_${ik}$ ) = c( 1_${ik}$:m, 1_${ik}$ ) - tau * w( 1_${ik}$:m ) + call stdlib${ii}$_saxpy( m, -tau, work, 1_${ik}$, c, 1_${ik}$ ) + ! c( 1_${ik}$:m, n-l+1:n ) = c( 1_${ik}$:m, n-l+1:n ) - ... + ! tau * w( 1_${ik}$:m ) * v( 1_${ik}$:l )**t + call stdlib${ii}$_sger( m, l, -tau, work, 1_${ik}$, v, incv, c( 1_${ik}$, n-l+1 ),ldc ) end if end if return - end subroutine stdlib_slarz + end subroutine stdlib${ii}$_slarz - pure subroutine stdlib_slarzb( side, trans, direct, storev, m, n, k, l, v,ldv, t, ldt, c, & + pure subroutine stdlib${ii}$_slarzb( side, trans, direct, storev, m, n, k, l, v,ldv, t, ldt, c, & !! SLARZB 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. @@ -6318,7 +6320,7 @@ module stdlib_linalg_lapack_s ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: direct, side, storev, trans - integer(ilp), intent(in) :: k, l, ldc, ldt, ldv, ldwork, m, n + integer(${ik}$), intent(in) :: k, l, ldc, ldt, ldv, ldwork, m, n ! Array Arguments real(sp), intent(inout) :: c(ldc,*), t(ldt,*), v(ldv,*) real(sp), intent(out) :: work(ldwork,*) @@ -6326,19 +6328,19 @@ module stdlib_linalg_lapack_s ! Local Scalars character :: transt - integer(ilp) :: i, info, j + integer(${ik}$) :: i, info, j ! Executable Statements ! quick return if possible if( m<=0 .or. n<=0 )return ! check for currently supported options - info = 0 + info = 0_${ik}$ if( .not.stdlib_lsame( direct, 'B' ) ) then - info = -3 + info = -3_${ik}$ else if( .not.stdlib_lsame( storev, 'R' ) ) then - info = -4 + info = -4_${ik}$ end if - if( info/=0 ) then - call stdlib_xerbla( 'SLARZB', -info ) + if( info/=0_${ik}$ ) then + call stdlib${ii}$_xerbla( 'SLARZB', -info ) return end if if( stdlib_lsame( trans, 'N' ) ) then @@ -6348,61 +6350,61 @@ module stdlib_linalg_lapack_s end if if( stdlib_lsame( side, 'L' ) ) then ! form h * c or h**t * c - ! w( 1:n, 1:k ) = c( 1:k, 1:n )**t + ! w( 1_${ik}$:n, 1_${ik}$:k ) = c( 1_${ik}$:k, 1_${ik}$:n )**t do j = 1, k - call stdlib_scopy( n, c( j, 1 ), ldc, work( 1, j ), 1 ) + call stdlib${ii}$_scopy( n, c( j, 1_${ik}$ ), ldc, work( 1_${ik}$, j ), 1_${ik}$ ) 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_sgemm( 'TRANSPOSE', 'TRANSPOSE', n, k, l, one,c( m-l+1, 1 ), & + ! w( 1_${ik}$:n, 1_${ik}$:k ) = w( 1_${ik}$:n, 1_${ik}$:k ) + ... + ! c( m-l+1:m, 1_${ik}$:n )**t * v( 1_${ik}$:k, 1_${ik}$:l )**t + if( l>0_${ik}$ )call stdlib${ii}$_sgemm( 'TRANSPOSE', 'TRANSPOSE', n, k, l, one,c( m-l+1, 1_${ik}$ ), & 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_strmm( 'RIGHT', 'LOWER', transt, 'NON-UNIT', n, k, one, t,ldt, work, & + ! w( 1_${ik}$:n, 1_${ik}$:k ) = w( 1_${ik}$:n, 1_${ik}$:k ) * t**t or w( 1_${ik}$:m, 1_${ik}$:k ) * t + call stdlib${ii}$_strmm( '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 + ! c( 1_${ik}$:k, 1_${ik}$:n ) = c( 1_${ik}$:k, 1_${ik}$:n ) - w( 1_${ik}$:n, 1_${ik}$:k )**t do j = 1, n do i = 1, k c( i, j ) = c( i, j ) - work( j, i ) end do 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_sgemm( 'TRANSPOSE', 'TRANSPOSE', l, n, k, -one, v, ldv,work, & - ldwork, one, c( m-l+1, 1 ), ldc ) + ! c( m-l+1:m, 1_${ik}$:n ) = c( m-l+1:m, 1_${ik}$:n ) - ... + ! v( 1_${ik}$:k, 1_${ik}$:l )**t * w( 1_${ik}$:n, 1_${ik}$:k )**t + if( l>0_${ik}$ )call stdlib${ii}$_sgemm( 'TRANSPOSE', 'TRANSPOSE', l, n, k, -one, v, ldv,work, & + ldwork, one, c( m-l+1, 1_${ik}$ ), 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 ) + ! w( 1_${ik}$:m, 1_${ik}$:k ) = c( 1_${ik}$:m, 1_${ik}$:k ) do j = 1, k - call stdlib_scopy( m, c( 1, j ), 1, work( 1, j ), 1 ) + call stdlib${ii}$_scopy( m, c( 1_${ik}$, j ), 1_${ik}$, work( 1_${ik}$, j ), 1_${ik}$ ) 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_sgemm( 'NO TRANSPOSE', 'TRANSPOSE', m, k, l, one,c( 1, n-l+1 ),& + ! w( 1_${ik}$:m, 1_${ik}$:k ) = w( 1_${ik}$:m, 1_${ik}$:k ) + ... + ! c( 1_${ik}$:m, n-l+1:n ) * v( 1_${ik}$:k, 1_${ik}$:l )**t + if( l>0_${ik}$ )call stdlib${ii}$_sgemm( 'NO TRANSPOSE', 'TRANSPOSE', m, k, l, one,c( 1_${ik}$, 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_strmm( 'RIGHT', 'LOWER', trans, 'NON-UNIT', m, k, one, t,ldt, work, & + ! w( 1_${ik}$:m, 1_${ik}$:k ) = w( 1_${ik}$:m, 1_${ik}$:k ) * t or w( 1_${ik}$:m, 1_${ik}$:k ) * t**t + call stdlib${ii}$_strmm( '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 ) + ! c( 1_${ik}$:m, 1_${ik}$:k ) = c( 1_${ik}$:m, 1_${ik}$:k ) - w( 1_${ik}$:m, 1_${ik}$:k ) do j = 1, k do i = 1, m c( i, j ) = c( i, j ) - work( i, j ) end do 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_sgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', m, l, k, -one,work, & - ldwork, v, ldv, one, c( 1, n-l+1 ), ldc ) + ! c( 1_${ik}$:m, n-l+1:n ) = c( 1_${ik}$:m, n-l+1:n ) - ... + ! w( 1_${ik}$:m, 1_${ik}$:k ) * v( 1_${ik}$:k, 1_${ik}$:l ) + if( l>0_${ik}$ )call stdlib${ii}$_sgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', m, l, k, -one,work, & + ldwork, v, ldv, one, c( 1_${ik}$, n-l+1 ), ldc ) end if return - end subroutine stdlib_slarzb + end subroutine stdlib${ii}$_slarzb - pure subroutine stdlib_slarzt( direct, storev, n, k, v, ldv, tau, t, ldt ) + pure subroutine stdlib${ii}$_slarzt( direct, storev, n, k, v, ldv, tau, t, ldt ) !! SLARZT forms the triangular factor T of a real 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; - !! If DIRECT = 'B', H = H(k) . . . H(2) H(1) and T is lower triangular. + !! If DIRECT = 'F', H = H(1_${ik}$) H(2_${ik}$) . . . H(k) and T is upper triangular; + !! If DIRECT = 'B', H = H(k) . . . H(2_${ik}$) H(1_${ik}$) and T is lower triangular. !! If STOREV = 'C', the vector which defines the elementary reflector !! H(i) is stored in the i-th column of the array V, and !! H = I - V * T * V**T @@ -6415,7 +6417,7 @@ module stdlib_linalg_lapack_s ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: direct, storev - integer(ilp), intent(in) :: k, ldt, ldv, n + integer(${ik}$), intent(in) :: k, ldt, ldv, n ! Array Arguments real(sp), intent(out) :: t(ldt,*) real(sp), intent(in) :: tau(*) @@ -6423,17 +6425,17 @@ module stdlib_linalg_lapack_s ! ===================================================================== ! Local Scalars - integer(ilp) :: i, info, j + integer(${ik}$) :: i, info, j ! Executable Statements ! check for currently supported options - info = 0 + info = 0_${ik}$ if( .not.stdlib_lsame( direct, 'B' ) ) then - info = -1 + info = -1_${ik}$ else if( .not.stdlib_lsame( storev, 'R' ) ) then - info = -2 + info = -2_${ik}$ end if - if( info/=0 ) then - call stdlib_xerbla( 'SLARZT', -info ) + if( info/=0_${ik}$ ) then + call stdlib${ii}$_xerbla( 'SLARZT', -info ) return end if do i = k, 1, -1 @@ -6445,24 +6447,24 @@ module stdlib_linalg_lapack_s else ! general case if( i 0 and that the Euclidean norm of the vector + !! 0_${ik}$ <= D(i) < D(j) for i < j . + !! We also assume RHO > 0_${ik}$ and that the Euclidean norm of the vector !! Z is one. ! -- 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) :: i + integer(${ik}$), intent(in) :: i real(sp), intent(out) :: dsigma real(sp), intent(in) :: rho ! Array Arguments - real(sp), intent(in) :: d(2), z(2) - real(sp), intent(out) :: delta(2), work(2) + real(sp), intent(in) :: d(2_${ik}$), z(2_${ik}$) + real(sp), intent(out) :: delta(2_${ik}$), work(2_${ik}$) ! ===================================================================== ! Local Scalars @@ -6549,127 +6551,127 @@ module stdlib_linalg_lapack_s ! Intrinsic Functions intrinsic :: abs,sqrt ! Executable Statements - del = d( 2 ) - d( 1 ) - delsq = del*( d( 2 )+d( 1 ) ) - if( i==1 ) then - w = one + four*rho*( z( 2 )*z( 2 ) / ( d( 1 )+three*d( 2 ) )-z( 1 )*z( 1 ) / ( & - three*d( 1 )+d( 2 ) ) ) / del + del = d( 2_${ik}$ ) - d( 1_${ik}$ ) + delsq = del*( d( 2_${ik}$ )+d( 1_${ik}$ ) ) + if( i==1_${ik}$ ) then + w = one + four*rho*( z( 2_${ik}$ )*z( 2_${ik}$ ) / ( d( 1_${ik}$ )+three*d( 2_${ik}$ ) )-z( 1_${ik}$ )*z( 1_${ik}$ ) / ( & + three*d( 1_${ik}$ )+d( 2_${ik}$ ) ) ) / del if( w>zero ) then - b = delsq + rho*( z( 1 )*z( 1 )+z( 2 )*z( 2 ) ) - c = rho*z( 1 )*z( 1 )*delsq + b = delsq + rho*( z( 1_${ik}$ )*z( 1_${ik}$ )+z( 2_${ik}$ )*z( 2_${ik}$ ) ) + c = rho*z( 1_${ik}$ )*z( 1_${ik}$ )*delsq ! b > zero, always - ! the following tau is dsigma * dsigma - d( 1 ) * d( 1 ) + ! the following tau is dsigma * dsigma - d( 1_${ik}$ ) * d( 1_${ik}$ ) tau = two*c / ( b+sqrt( abs( b*b-four*c ) ) ) - ! the following tau is dsigma - d( 1 ) - tau = tau / ( d( 1 )+sqrt( d( 1 )*d( 1 )+tau ) ) - dsigma = d( 1 ) + tau - delta( 1 ) = -tau - delta( 2 ) = del - tau - work( 1 ) = two*d( 1 ) + tau - work( 2 ) = ( d( 1 )+tau ) + d( 2 ) - ! delta( 1 ) = -z( 1 ) / tau - ! delta( 2 ) = z( 2 ) / ( del-tau ) - else - b = -delsq + rho*( z( 1 )*z( 1 )+z( 2 )*z( 2 ) ) - c = rho*z( 2 )*z( 2 )*delsq - ! the following tau is dsigma * dsigma - d( 2 ) * d( 2 ) + ! the following tau is dsigma - d( 1_${ik}$ ) + tau = tau / ( d( 1_${ik}$ )+sqrt( d( 1_${ik}$ )*d( 1_${ik}$ )+tau ) ) + dsigma = d( 1_${ik}$ ) + tau + delta( 1_${ik}$ ) = -tau + delta( 2_${ik}$ ) = del - tau + work( 1_${ik}$ ) = two*d( 1_${ik}$ ) + tau + work( 2_${ik}$ ) = ( d( 1_${ik}$ )+tau ) + d( 2_${ik}$ ) + ! delta( 1_${ik}$ ) = -z( 1_${ik}$ ) / tau + ! delta( 2_${ik}$ ) = z( 2_${ik}$ ) / ( del-tau ) + else + b = -delsq + rho*( z( 1_${ik}$ )*z( 1_${ik}$ )+z( 2_${ik}$ )*z( 2_${ik}$ ) ) + c = rho*z( 2_${ik}$ )*z( 2_${ik}$ )*delsq + ! the following tau is dsigma * dsigma - d( 2_${ik}$ ) * d( 2_${ik}$ ) if( b>zero ) then tau = -two*c / ( b+sqrt( b*b+four*c ) ) else tau = ( b-sqrt( b*b+four*c ) ) / two end if - ! the following tau is dsigma - d( 2 ) - tau = tau / ( d( 2 )+sqrt( abs( d( 2 )*d( 2 )+tau ) ) ) - dsigma = d( 2 ) + tau - delta( 1 ) = -( del+tau ) - delta( 2 ) = -tau - work( 1 ) = d( 1 ) + tau + d( 2 ) - work( 2 ) = two*d( 2 ) + tau - ! delta( 1 ) = -z( 1 ) / ( del+tau ) - ! delta( 2 ) = -z( 2 ) / tau - end if - ! temp = sqrt( delta( 1 )*delta( 1 )+delta( 2 )*delta( 2 ) ) - ! delta( 1 ) = delta( 1 ) / temp - ! delta( 2 ) = delta( 2 ) / temp - else - ! now i=2 - b = -delsq + rho*( z( 1 )*z( 1 )+z( 2 )*z( 2 ) ) - c = rho*z( 2 )*z( 2 )*delsq - ! the following tau is dsigma * dsigma - d( 2 ) * d( 2 ) + ! the following tau is dsigma - d( 2_${ik}$ ) + tau = tau / ( d( 2_${ik}$ )+sqrt( abs( d( 2_${ik}$ )*d( 2_${ik}$ )+tau ) ) ) + dsigma = d( 2_${ik}$ ) + tau + delta( 1_${ik}$ ) = -( del+tau ) + delta( 2_${ik}$ ) = -tau + work( 1_${ik}$ ) = d( 1_${ik}$ ) + tau + d( 2_${ik}$ ) + work( 2_${ik}$ ) = two*d( 2_${ik}$ ) + tau + ! delta( 1_${ik}$ ) = -z( 1_${ik}$ ) / ( del+tau ) + ! delta( 2_${ik}$ ) = -z( 2_${ik}$ ) / tau + end if + ! temp = sqrt( delta( 1_${ik}$ )*delta( 1_${ik}$ )+delta( 2_${ik}$ )*delta( 2_${ik}$ ) ) + ! delta( 1_${ik}$ ) = delta( 1_${ik}$ ) / temp + ! delta( 2_${ik}$ ) = delta( 2_${ik}$ ) / temp + else + ! now i=2_${ik}$ + b = -delsq + rho*( z( 1_${ik}$ )*z( 1_${ik}$ )+z( 2_${ik}$ )*z( 2_${ik}$ ) ) + c = rho*z( 2_${ik}$ )*z( 2_${ik}$ )*delsq + ! the following tau is dsigma * dsigma - d( 2_${ik}$ ) * d( 2_${ik}$ ) if( b>zero ) then tau = ( b+sqrt( b*b+four*c ) ) / two else tau = two*c / ( -b+sqrt( b*b+four*c ) ) end if - ! the following tau is dsigma - d( 2 ) - tau = tau / ( d( 2 )+sqrt( d( 2 )*d( 2 )+tau ) ) - dsigma = d( 2 ) + tau - delta( 1 ) = -( del+tau ) - delta( 2 ) = -tau - work( 1 ) = d( 1 ) + tau + d( 2 ) - work( 2 ) = two*d( 2 ) + tau - ! delta( 1 ) = -z( 1 ) / ( del+tau ) - ! delta( 2 ) = -z( 2 ) / tau - ! temp = sqrt( delta( 1 )*delta( 1 )+delta( 2 )*delta( 2 ) ) - ! delta( 1 ) = delta( 1 ) / temp - ! delta( 2 ) = delta( 2 ) / temp + ! the following tau is dsigma - d( 2_${ik}$ ) + tau = tau / ( d( 2_${ik}$ )+sqrt( d( 2_${ik}$ )*d( 2_${ik}$ )+tau ) ) + dsigma = d( 2_${ik}$ ) + tau + delta( 1_${ik}$ ) = -( del+tau ) + delta( 2_${ik}$ ) = -tau + work( 1_${ik}$ ) = d( 1_${ik}$ ) + tau + d( 2_${ik}$ ) + work( 2_${ik}$ ) = two*d( 2_${ik}$ ) + tau + ! delta( 1_${ik}$ ) = -z( 1_${ik}$ ) / ( del+tau ) + ! delta( 2_${ik}$ ) = -z( 2_${ik}$ ) / tau + ! temp = sqrt( delta( 1_${ik}$ )*delta( 1_${ik}$ )+delta( 2_${ik}$ )*delta( 2_${ik}$ ) ) + ! delta( 1_${ik}$ ) = delta( 1_${ik}$ ) / temp + ! delta( 2_${ik}$ ) = delta( 2_${ik}$ ) / temp end if return - end subroutine stdlib_slasd5 + end subroutine stdlib${ii}$_slasd5 - pure subroutine stdlib_slasdt( n, lvl, nd, inode, ndiml, ndimr, msub ) + pure subroutine stdlib${ii}$_slasdt( n, lvl, nd, inode, ndiml, ndimr, msub ) !! SLASDT creates a tree of subproblems for bidiagonal divide and !! conquer. ! -- 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) :: lvl, nd - integer(ilp), intent(in) :: msub, n + integer(${ik}$), intent(out) :: lvl, nd + integer(${ik}$), intent(in) :: msub, n ! Array Arguments - integer(ilp), intent(out) :: inode(*), ndiml(*), ndimr(*) + integer(${ik}$), intent(out) :: inode(*), ndiml(*), ndimr(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, il, ir, llst, maxn, ncrnt, nlvl + integer(${ik}$) :: i, il, ir, llst, maxn, ncrnt, nlvl real(sp) :: temp ! Intrinsic Functions intrinsic :: int,log,max,real ! Executable Statements ! find the number of levels on the tree. - maxn = max( 1, n ) + maxn = max( 1_${ik}$, n ) temp = log( real( maxn,KIND=sp) / real( msub+1,KIND=sp) ) / log( two ) - lvl = int( temp,KIND=ilp) + 1 - i = n / 2 - inode( 1 ) = i + 1 - ndiml( 1 ) = i - ndimr( 1 ) = n - i - 1 - il = 0 - ir = 1 - llst = 1 + lvl = int( temp,KIND=${ik}$) + 1_${ik}$ + i = n / 2_${ik}$ + inode( 1_${ik}$ ) = i + 1_${ik}$ + ndiml( 1_${ik}$ ) = i + ndimr( 1_${ik}$ ) = n - i - 1_${ik}$ + il = 0_${ik}$ + ir = 1_${ik}$ + llst = 1_${ik}$ do nlvl = 1, lvl - 1 ! constructing the tree at (nlvl+1)-st level. the number of ! nodes created on this level is llst * 2. do i = 0, llst - 1 - il = il + 2 - ir = ir + 2 + il = il + 2_${ik}$ + ir = ir + 2_${ik}$ ncrnt = llst + i - ndiml( il ) = ndiml( ncrnt ) / 2 - ndimr( il ) = ndiml( ncrnt ) - ndiml( il ) - 1 - inode( il ) = inode( ncrnt ) - ndimr( il ) - 1 - ndiml( ir ) = ndimr( ncrnt ) / 2 - ndimr( ir ) = ndimr( ncrnt ) - ndiml( ir ) - 1 - inode( ir ) = inode( ncrnt ) + ndiml( ir ) + 1 - end do - llst = llst*2 + ndiml( il ) = ndiml( ncrnt ) / 2_${ik}$ + ndimr( il ) = ndiml( ncrnt ) - ndiml( il ) - 1_${ik}$ + inode( il ) = inode( ncrnt ) - ndimr( il ) - 1_${ik}$ + ndiml( ir ) = ndimr( ncrnt ) / 2_${ik}$ + ndimr( ir ) = ndimr( ncrnt ) - ndiml( ir ) - 1_${ik}$ + inode( ir ) = inode( ncrnt ) + ndiml( ir ) + 1_${ik}$ + end do + llst = llst*2_${ik}$ end do - nd = llst*2 - 1 + nd = llst*2_${ik}$ - 1_${ik}$ return - end subroutine stdlib_slasdt + end subroutine stdlib${ii}$_slasdt - pure subroutine stdlib_slaset( uplo, m, n, alpha, beta, a, lda ) + pure subroutine stdlib${ii}$_slaset( uplo, m, n, alpha, beta, a, lda ) !! SLASET initializes an m-by-n matrix A to BETA on the diagonal and !! ALPHA on the offdiagonals. ! -- lapack auxiliary routine -- @@ -6677,13 +6679,13 @@ module stdlib_linalg_lapack_s ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: uplo - integer(ilp), intent(in) :: lda, m, n + integer(${ik}$), intent(in) :: lda, m, n real(sp), intent(in) :: alpha, beta ! Array Arguments real(sp), intent(out) :: a(lda,*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, j + integer(${ik}$) :: i, j ! Intrinsic Functions intrinsic :: min ! Executable Statements @@ -6716,10 +6718,10 @@ module stdlib_linalg_lapack_s a( i, i ) = beta end do return - end subroutine stdlib_slaset + end subroutine stdlib${ii}$_slaset - pure subroutine stdlib_slasq4( i0, n0, z, pp, n0in, dmin, dmin1, dmin2, dn,dn1, dn2, tau, & + pure subroutine stdlib${ii}$_slasq4( i0, n0, z, pp, n0in, dmin, dmin1, dmin2, dn,dn1, dn2, tau, & !! SLASQ4 computes an approximation TAU to the smallest eigenvalue !! using values of d from the previous transform. ttype, g ) @@ -6727,8 +6729,8 @@ module stdlib_linalg_lapack_s ! -- 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) :: i0, n0, n0in, pp - integer(ilp), intent(out) :: ttype + integer(${ik}$), intent(in) :: i0, n0, n0in, pp + integer(${ik}$), intent(out) :: ttype real(sp), intent(in) :: dmin, dmin1, dmin2, dn, dn1, dn2 real(sp), intent(inout) :: g real(sp), intent(out) :: tau @@ -6745,7 +6747,7 @@ module stdlib_linalg_lapack_s ! Local Scalars - integer(ilp) :: i4, nn, np + integer(${ik}$) :: i4, nn, np real(sp) :: a2, b1, b2, gam, gap1, gap2, s ! Intrinsic Functions intrinsic :: max,min,sqrt @@ -6754,17 +6756,17 @@ module stdlib_linalg_lapack_s ! ttype records the type of shift. if( dmin<=zero ) then tau = -dmin - ttype = -1 + ttype = -1_${ik}$ return end if - nn = 4*n0 + pp + nn = 4_${ik}$*n0 + pp if( n0in==n0 ) then ! no eigenvalues deflated. if( dmin==dn .or. dmin==dn1 ) then b1 = sqrt( z( nn-3 ) )*sqrt( z( nn-5 ) ) b2 = sqrt( z( nn-7 ) )*sqrt( z( nn-9 ) ) a2 = z( nn-7 ) + z( nn-5 ) - ! cases 2 and 3. + ! cases 2_${ik}$ and 3. if( dmin==dn .and. dmin1==dn1 ) then gap2 = dmin2 - a2 - dmin2*qurtr if( gap2>zero .and. gap2>b2 ) then @@ -6774,32 +6776,32 @@ module stdlib_linalg_lapack_s end if if( gap1>zero .and. gap1>b1 ) then s = max( dn-( b1 / gap1 )*b1, half*dmin ) - ttype = -2 + ttype = -2_${ik}$ else s = zero if( dn>b1 )s = dn - b1 if( a2>( b1+b2 ) )s = min( s, a2-( b1+b2 ) ) s = max( s, third*dmin ) - ttype = -3 + ttype = -3_${ik}$ end if else ! case 4. - ttype = -4 + ttype = -4_${ik}$ s = qurtr*dmin if( dmin==dn ) then gam = dn a2 = zero if( z( nn-5 ) > z( nn-7 ) )return b2 = z( nn-5 ) / z( nn-7 ) - np = nn - 9 + np = nn - 9_${ik}$ else - np = nn - 2*pp + np = nn - 2_${ik}$*pp gam = dn1 if( z( np-4 ) > z( np-2 ) )return a2 = z( np-4 ) / z( np-2 ) if( z( nn-9 ) > z( nn-11 ) )return b2 = z( nn-9 ) / z( nn-11 ) - np = nn - 13 + np = nn - 13_${ik}$ end if ! approximate contribution to norm squared from i < nn-1. a2 = a2 + b2 @@ -6818,17 +6820,17 @@ module stdlib_linalg_lapack_s end if else if( dmin==dn2 ) then ! case 5. - ttype = -5 + ttype = -5_${ik}$ s = qurtr*dmin ! compute contribution to norm squared from i > nn-2. - np = nn - 2*pp + np = nn - 2_${ik}$*pp b1 = z( np-2 ) b2 = z( np-6 ) gam = dn2 if( z( np-8 )>b2 .or. z( np-4 )>b1 )return a2 = ( z( np-8 ) / b2 )*( one+z( np-4 ) / b1 ) ! approximate contribution to norm squared from i < nn-2. - if( n0-i0>2 ) then + if( n0-i0>2_${ik}$ ) then b2 = z( nn-13 ) / z( nn-15 ) a2 = a2 + b2 do i4 = nn - 17, 4*i0 - 1 + pp, -4 @@ -6844,22 +6846,22 @@ module stdlib_linalg_lapack_s end if if( a2z( nn-7 ) )return b1 = z( nn-5 ) / z( nn-7 ) @@ -6874,25 +6876,25 @@ module stdlib_linalg_lapack_s end do 60 continue b2 = sqrt( cnst3*b2 ) - a2 = dmin1 / ( one+b2**2 ) + a2 = dmin1 / ( one+b2**2_${ik}$ ) gap2 = half*dmin2 - a2 if( gap2>zero .and. gap2>b2*a2 ) then s = max( s, a2*( one-cnst2*a2*( b2 / gap2 )*b2 ) ) else s = max( s, a2*( one-cnst2*b2 ) ) - ttype = -8 + ttype = -8_${ik}$ end if else ! case 9. s = qurtr*dmin1 if( dmin1==dn1 )s = half*dmin1 - ttype = -9 + ttype = -9_${ik}$ end if else if( n0in==( n0+2 ) ) then ! two eigenvalues deflated. use dmin2, dn2 for dmin and dn. - ! cases 10 and 11. + ! cases 10_${ik}$ and 11. if( dmin2==dn2 .and. two*z( nn-5 )z( nn-7 ) )return b1 = z( nn-5 ) / z( nn-7 ) @@ -6906,7 +6908,7 @@ module stdlib_linalg_lapack_s end do 80 continue b2 = sqrt( cnst3*b2 ) - a2 = dmin2 / ( one+b2**2 ) + a2 = dmin2 / ( one+b2**2_${ik}$ ) gap2 = z( nn-7 ) + z( nn-9 ) -sqrt( z( nn-11 ) )*sqrt( z( nn-9 ) ) - a2 if( gap2>zero .and. gap2>b2*a2 ) then s = max( s, a2*( one-cnst2*a2*( b2 / gap2 )*b2 ) ) @@ -6915,19 +6917,19 @@ module stdlib_linalg_lapack_s end if else s = qurtr*dmin2 - ttype = -11 + ttype = -11_${ik}$ end if else if( n0in>( n0+2 ) ) then - ! case 12, more than two eigenvalues deflated. no information. + ! case 12_${ik}$, more than two eigenvalues deflated. no information. s = zero - ttype = -12 + ttype = -12_${ik}$ end if tau = s return - end subroutine stdlib_slasq4 + end subroutine stdlib${ii}$_slasq4 - pure subroutine stdlib_slasq5( i0, n0, z, pp, tau, sigma, dmin, dmin1, dmin2,dn, dnm1, dnm2, & + pure subroutine stdlib${ii}$_slasq5( i0, n0, z, pp, tau, sigma, dmin, dmin1, dmin2,dn, dnm1, dnm2, & !! SLASQ5 computes one dqds transform in ping-pong form, one !! version for IEEE machines another for non IEEE machines. ieee, eps ) @@ -6936,7 +6938,7 @@ module stdlib_linalg_lapack_s ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments logical(lk), intent(in) :: ieee - integer(ilp), intent(in) :: i0, n0, pp + integer(${ik}$), intent(in) :: i0, n0, pp real(sp), intent(out) :: dmin, dmin1, dmin2, dn, dnm1, dnm2 real(sp), intent(inout) :: tau real(sp), intent(in) :: sigma, eps @@ -6945,7 +6947,7 @@ module stdlib_linalg_lapack_s ! ===================================================================== ! Local Scalars - integer(ilp) :: j4, j4p2 + integer(${ik}$) :: j4, j4p2 real(sp) :: d, emin, temp, dthresh ! Intrinsic Functions intrinsic :: min @@ -6954,14 +6956,14 @@ module stdlib_linalg_lapack_s dthresh = eps*(sigma+tau) if( tau0 ) then + start = stack( 1_${ik}$, stkpnt ) + endd = stack( 2_${ik}$, stkpnt ) + stkpnt = stkpnt - 1_${ik}$ + if( endd-start<=select .and. endd-start>0_${ik}$ ) then ! do insertion sort on d( start:endd ) - if( dir==0 ) then + if( dir==0_${ik}$ ) then ! sort into decreasing order loop_30: do i = start + 1, endd do j = i, start + 1, -1 @@ -7605,10 +7607,10 @@ module stdlib_linalg_lapack_s end if else if( endd-start>select ) then ! partition d( start:endd ) and stack parts, largest one first - ! choose partition entry as median of 3 + ! choose partition entry as median of 3_${ik}$ d1 = d( start ) d2 = d( endd ) - i = ( start+endd ) / 2 + i = ( start+endd ) / 2_${ik}$ d3 = d( i ) if( d1dmnmx )go to 80 if( iendd-j-1 ) then - stkpnt = stkpnt + 1 - stack( 1, stkpnt ) = start - stack( 2, stkpnt ) = j - stkpnt = stkpnt + 1 - stack( 1, stkpnt ) = j + 1 - stack( 2, stkpnt ) = endd + stkpnt = stkpnt + 1_${ik}$ + stack( 1_${ik}$, stkpnt ) = start + stack( 2_${ik}$, stkpnt ) = j + stkpnt = stkpnt + 1_${ik}$ + stack( 1_${ik}$, stkpnt ) = j + 1_${ik}$ + stack( 2_${ik}$, stkpnt ) = endd else - stkpnt = stkpnt + 1 - stack( 1, stkpnt ) = j + 1 - stack( 2, stkpnt ) = endd - stkpnt = stkpnt + 1 - stack( 1, stkpnt ) = start - stack( 2, stkpnt ) = j + stkpnt = stkpnt + 1_${ik}$ + stack( 1_${ik}$, stkpnt ) = j + 1_${ik}$ + stack( 2_${ik}$, stkpnt ) = endd + stkpnt = stkpnt + 1_${ik}$ + stack( 1_${ik}$, stkpnt ) = start + stack( 2_${ik}$, stkpnt ) = j end if else ! sort into increasing order - i = start - 1 - j = endd + 1 + i = start - 1_${ik}$ + j = endd + 1_${ik}$ 90 continue 100 continue - j = j - 1 + j = j - 1_${ik}$ if( d( j )>dmnmx )go to 100 110 continue - i = i + 1 + i = i + 1_${ik}$ if( d( i )endd-j-1 ) then - stkpnt = stkpnt + 1 - stack( 1, stkpnt ) = start - stack( 2, stkpnt ) = j - stkpnt = stkpnt + 1 - stack( 1, stkpnt ) = j + 1 - stack( 2, stkpnt ) = endd + stkpnt = stkpnt + 1_${ik}$ + stack( 1_${ik}$, stkpnt ) = start + stack( 2_${ik}$, stkpnt ) = j + stkpnt = stkpnt + 1_${ik}$ + stack( 1_${ik}$, stkpnt ) = j + 1_${ik}$ + stack( 2_${ik}$, stkpnt ) = endd else - stkpnt = stkpnt + 1 - stack( 1, stkpnt ) = j + 1 - stack( 2, stkpnt ) = endd - stkpnt = stkpnt + 1 - stack( 1, stkpnt ) = start - stack( 2, stkpnt ) = j + stkpnt = stkpnt + 1_${ik}$ + stack( 1_${ik}$, stkpnt ) = j + 1_${ik}$ + stack( 2_${ik}$, stkpnt ) = endd + stkpnt = stkpnt + 1_${ik}$ + stack( 1_${ik}$, stkpnt ) = start + stack( 2_${ik}$, stkpnt ) = j end if end if end if if( stkpnt>0 )go to 10 return - end subroutine stdlib_slasrt + end subroutine stdlib${ii}$_slasrt - pure subroutine stdlib_slassq( n, x, incx, scl, sumsq ) + pure subroutine stdlib${ii}$_slassq( n, x, incx, scl, sumsq ) !! SLASSQ 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 + !! ( scl**2_${ik}$ )*smsq = x( 1_${ik}$ )**2_${ik}$ +...+ x( n )**2_${ik}$ + ( scale**2_${ik}$ )*sumsq, + !! where x( i ) = X( 1_${ik}$ + ( i - 1_${ik}$ )*INCX ). The value of sumsq is !! assumed to be non-negative. !! scale and sumsq must be supplied in SCALE and SUMSQ and !! scl and smsq are overwritten on SCALE and SUMSQ respectively. !! If scale * sqrt( sumsq ) > tbig then !! we require: scale >= sqrt( TINY*EPS ) / sbig on entry, - !! and if 0 < scale * sqrt( sumsq ) < tsml then + !! and if 0_${ik}$ < scale * sqrt( sumsq ) < tsml then !! we require: scale <= sqrt( HUGE ) / ssml on entry, !! where !! tbig -- upper threshold for values whose square is representable; @@ -7721,12 +7723,12 @@ module stdlib_linalg_lapack_s ! -- 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 + integer(${ik}$), intent(in) :: incx, n real(sp), intent(inout) :: scl, sumsq ! Array Arguments real(sp), intent(in) :: x(*) ! Local Scalars - integer(ilp) :: i, ix + integer(${ik}$) :: i, ix logical(lk) :: notbig real(sp) :: abig, amed, asml, ax, ymax, ymin ! quick return if possible @@ -7736,10 +7738,10 @@ module stdlib_linalg_lapack_s scl = one sumsq = zero end if - if (n <= 0) then + if (n <= 0_${ik}$) then return end if - ! compute the sum of squares in 3 accumulators: + ! compute the sum of squares in 3_${ik}$ accumulators: ! abig -- sums of squares scaled down to avoid overflow ! asml -- sums of squares scaled up to avoid underflow ! amed -- sums of squares that do not require scaling @@ -7750,17 +7752,17 @@ module stdlib_linalg_lapack_s asml = zero amed = zero abig = zero - ix = 1 - if( incx < 0 ) ix = 1 - (n-1)*incx + ix = 1_${ik}$ + if( incx < 0_${ik}$ ) ix = 1_${ik}$ - (n-1)*incx do i = 1, n ax = abs(x(ix)) if (ax > tbig) then - abig = abig + (ax*sbig)**2 + abig = abig + (ax*sbig)**2_${ik}$ notbig = .false. else if (ax < tsml) then - if (notbig) asml = asml + (ax*ssml)**2 + if (notbig) asml = asml + (ax*ssml)**2_${ik}$ else - amed = amed + ax**2 + amed = amed + ax**2_${ik}$ end if ix = ix + incx end do @@ -7769,12 +7771,12 @@ module stdlib_linalg_lapack_s ax = scl*sqrt( sumsq ) if (ax > tbig) then ! we assume scl >= sqrt( tiny*eps ) / sbig - abig = abig + (scl*sbig)**2 * sumsq + abig = abig + (scl*sbig)**2_${ik}$ * sumsq else if (ax < tsml) then ! we assume scl <= sqrt( huge ) / ssml - if (notbig) asml = asml + (scl*ssml)**2 * sumsq + if (notbig) asml = asml + (scl*ssml)**2_${ik}$ * sumsq else - amed = amed + scl**2 * sumsq + amed = amed + scl**2_${ik}$ * sumsq end if end if ! combine abig and amed or amed and asml if more than one @@ -7799,7 +7801,7 @@ module stdlib_linalg_lapack_s ymax = amed end if scl = one - sumsq = ymax**2*( one + (ymin/ymax)**2 ) + sumsq = ymax**2_${ik}$*( one + (ymin/ymax)**2_${ik}$ ) else scl = one / ssml sumsq = asml @@ -7810,19 +7812,19 @@ module stdlib_linalg_lapack_s sumsq = amed end if return - end subroutine stdlib_slassq + end subroutine stdlib${ii}$_slassq - pure subroutine stdlib_slasv2( f, g, h, ssmin, ssmax, snr, csr, snl, csl ) - !! SLASV2 computes the singular value decomposition of a 2-by-2 + pure subroutine stdlib${ii}$_slasv2( f, g, h, ssmin, ssmax, snr, csr, snl, csl ) + !! SLASV2 computes the singular value decomposition of a 2_${ik}$-by-2 !! triangular matrix !! [ F G ] - !! [ 0 H ]. + !! [ 0_${ik}$ H ]. !! On return, abs(SSMAX) is the larger singular value, abs(SSMIN) is the !! smaller singular value, and (CSL,SNL) and (CSR,SNR) are the left and !! right singular vectors for abs(SSMAX), giving the decomposition - !! [ CSL SNL ] [ F G ] [ CSR -SNR ] = [ SSMAX 0 ] - !! [-SNL CSL ] [ 0 H ] [ SNR CSR ] [ 0 SSMIN ]. + !! [ CSL SNL ] [ F G ] [ CSR -SNR ] = [ SSMAX 0_${ik}$ ] + !! [-SNL CSL ] [ 0_${ik}$ H ] [ SNR CSR ] [ 0_${ik}$ SSMIN ]. ! -- lapack auxiliary routine -- ! -- lapack is a software package provided by univ. of tennessee, -- ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- @@ -7837,7 +7839,7 @@ module stdlib_linalg_lapack_s ! Local Scalars logical(lk) :: gasmal, swap - integer(ilp) :: pmax + integer(${ik}$) :: pmax real(sp) :: a, clt, crt, d, fa, ft, ga, gt, ha, ht, l, m, mm, r, s, slt, srt, t, temp, & tsign, tt ! Intrinsic Functions @@ -7848,13 +7850,13 @@ module stdlib_linalg_lapack_s ht = h ha = abs( h ) ! pmax points to the maximum absolute element of matrix - ! pmax = 1 if f largest in absolute values - ! pmax = 2 if g largest in absolute values - ! pmax = 3 if h largest in absolute values - pmax = 1 + ! pmax = 1_${ik}$ if f largest in absolute values + ! pmax = 2_${ik}$ if g largest in absolute values + ! pmax = 3_${ik}$ if h largest in absolute values + pmax = 1_${ik}$ swap = ( ha>fa ) if( swap ) then - pmax = 3 + pmax = 3_${ik}$ temp = ft ft = ht ht = temp @@ -7876,8 +7878,8 @@ module stdlib_linalg_lapack_s else gasmal = .true. if( ga>fa ) then - pmax = 2 - if( ( fa / ga )0 ) then + if( incx>0_${ik}$ ) then ix0 = k1 i1 = k1 i2 = k2 - inc = 1 - else if( incx<0 ) then + inc = 1_${ik}$ + else if( incx<0_${ik}$ ) then ix0 = k1 + ( k1-k2 )*incx i1 = k2 i2 = k1 - inc = -1 + inc = -1_${ik}$ else return end if - n32 = ( n / 32 )*32 - if( n32/=0 ) then + n32 = ( n / 32_${ik}$ )*32_${ik}$ + if( n32/=0_${ik}$ ) then do j = 1, n32, 32 ix = ix0 do i = i1, i2, inc @@ -8007,7 +8009,7 @@ module stdlib_linalg_lapack_s end do end if if( n32/=n ) then - n32 = n32 + 1 + n32 = n32 + 1_${ik}$ ix = ix0 do i = i1, i2, inc ip = ipiv( ix ) @@ -8022,13 +8024,13 @@ module stdlib_linalg_lapack_s end do end if return - end subroutine stdlib_slaswp + end subroutine stdlib${ii}$_slaswp - pure subroutine stdlib_slasy2( ltranl, ltranr, isgn, n1, n2, tl, ldtl, tr,ldtr, b, ldb, & - !! SLASY2 solves for the N1 by N2 matrix X, 1 <= N1,N2 <= 2, in + pure subroutine stdlib${ii}$_slasy2( ltranl, ltranr, isgn, n1, n2, tl, ldtl, tr,ldtr, b, ldb, & + !! SLASY2 solves for the N1 by N2 matrix X, 1_${ik}$ <= N1,N2 <= 2_${ik}$, 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 + !! where TL is N1 by N1, TR is N2 by N2, B is N1 by N2, and ISGN = 1_${ik}$ or !! -1. op(T) = T or T**T, where T**T denotes the transpose of T. scale, x, ldx, xnorm, info ) ! -- lapack auxiliary routine -- @@ -8036,8 +8038,8 @@ module stdlib_linalg_lapack_s ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments logical(lk), intent(in) :: ltranl, ltranr - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: isgn, ldb, ldtl, ldtr, ldx, n1, n2 + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: isgn, ldb, ldtl, ldtr, ldx, n1, n2 real(sp), intent(out) :: scale, xnorm ! Array Arguments real(sp), intent(in) :: b(ldb,*), tl(ldtl,*), tr(ldtr,*) @@ -8047,89 +8049,89 @@ module stdlib_linalg_lapack_s ! Local Scalars logical(lk) :: bswap, xswap - integer(ilp) :: i, ip, ipiv, ipsv, j, jp, jpsv, k + integer(${ik}$) :: i, ip, ipiv, ipsv, j, jp, jpsv, k real(sp) :: 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(sp) :: btmp(4), t16(4,4), tmp(4), x2(2) + logical(lk) :: bswpiv(4_${ik}$), xswpiv(4_${ik}$) + integer(${ik}$) :: jpiv(4_${ik}$), locl21(4_${ik}$), locu12(4_${ik}$), locu22(4_${ik}$) + real(sp) :: btmp(4_${ik}$), t16(4_${ik}$,4_${ik}$), tmp(4_${ik}$), x2(2_${ik}$) ! Intrinsic Functions intrinsic :: abs,max ! Data Statements - locu12 = [3,4,1,2] - locl21 = [2,1,4,3] - locu22 = [4,3,2,1] + locu12 = [3_${ik}$,4_${ik}$,1_${ik}$,2_${ik}$] + locl21 = [2_${ik}$,1_${ik}$,4_${ik}$,3_${ik}$] + locu22 = [4_${ik}$,3_${ik}$,2_${ik}$,1_${ik}$] xswpiv = [.false.,.false.,.true.,.true.] bswpiv = [.false.,.true.,.false.,.true.] ! Executable Statements ! do not check the input parameters for errors - info = 0 + info = 0_${ik}$ ! quick return if possible if( n1==0 .or. n2==0 )return ! set constants to control overflow - eps = stdlib_slamch( 'P' ) - smlnum = stdlib_slamch( 'S' ) / eps + eps = stdlib${ii}$_slamch( 'P' ) + smlnum = stdlib${ii}$_slamch( 'S' ) / eps sgn = isgn - k = n1 + n1 + n2 - 2 + k = n1 + n1 + n2 - 2_${ik}$ go to ( 10, 20, 30, 50 )k - ! 1 by 1: tl11*x + sgn*x*tr11 = b11 + ! 1_${ik}$ by 1_${ik}$: tl11*x + sgn*x*tr11 = b11 10 continue - tau1 = tl( 1, 1 ) + sgn*tr( 1, 1 ) + tau1 = tl( 1_${ik}$, 1_${ik}$ ) + sgn*tr( 1_${ik}$, 1_${ik}$ ) bet = abs( tau1 ) if( bet<=smlnum ) then tau1 = smlnum bet = smlnum - info = 1 + info = 1_${ik}$ end if scale = one - gam = abs( b( 1, 1 ) ) + gam = abs( b( 1_${ik}$, 1_${ik}$ ) ) if( smlnum*gam>bet )scale = one / gam - x( 1, 1 ) = ( b( 1, 1 )*scale ) / tau1 - xnorm = abs( x( 1, 1 ) ) + x( 1_${ik}$, 1_${ik}$ ) = ( b( 1_${ik}$, 1_${ik}$ )*scale ) / tau1 + xnorm = abs( x( 1_${ik}$, 1_${ik}$ ) ) return - ! 1 by 2: + ! 1_${ik}$ by 2_${ik}$: ! tl11*[x11 x12] + isgn*[x11 x12]*op[tr11 tr12] = [b11 b12] ! [tr21 tr22] 20 continue - smin = max( eps*max( abs( tl( 1, 1 ) ), abs( tr( 1, 1 ) ),abs( tr( 1, 2 ) ), abs( tr( & - 2, 1 ) ), abs( tr( 2, 2 ) ) ),smlnum ) - tmp( 1 ) = tl( 1, 1 ) + sgn*tr( 1, 1 ) - tmp( 4 ) = tl( 1, 1 ) + sgn*tr( 2, 2 ) + smin = max( eps*max( abs( tl( 1_${ik}$, 1_${ik}$ ) ), abs( tr( 1_${ik}$, 1_${ik}$ ) ),abs( tr( 1_${ik}$, 2_${ik}$ ) ), abs( tr( & + 2_${ik}$, 1_${ik}$ ) ), abs( tr( 2_${ik}$, 2_${ik}$ ) ) ),smlnum ) + tmp( 1_${ik}$ ) = tl( 1_${ik}$, 1_${ik}$ ) + sgn*tr( 1_${ik}$, 1_${ik}$ ) + tmp( 4_${ik}$ ) = tl( 1_${ik}$, 1_${ik}$ ) + sgn*tr( 2_${ik}$, 2_${ik}$ ) if( ltranr ) then - tmp( 2 ) = sgn*tr( 2, 1 ) - tmp( 3 ) = sgn*tr( 1, 2 ) + tmp( 2_${ik}$ ) = sgn*tr( 2_${ik}$, 1_${ik}$ ) + tmp( 3_${ik}$ ) = sgn*tr( 1_${ik}$, 2_${ik}$ ) else - tmp( 2 ) = sgn*tr( 1, 2 ) - tmp( 3 ) = sgn*tr( 2, 1 ) + tmp( 2_${ik}$ ) = sgn*tr( 1_${ik}$, 2_${ik}$ ) + tmp( 3_${ik}$ ) = sgn*tr( 2_${ik}$, 1_${ik}$ ) end if - btmp( 1 ) = b( 1, 1 ) - btmp( 2 ) = b( 1, 2 ) + btmp( 1_${ik}$ ) = b( 1_${ik}$, 1_${ik}$ ) + btmp( 2_${ik}$ ) = b( 1_${ik}$, 2_${ik}$ ) go to 40 - ! 2 by 1: + ! 2_${ik}$ by 1_${ik}$: ! op[tl11 tl12]*[x11] + isgn* [x11]*tr11 = [b11] ! [tl21 tl22] [x21] [x21] [b21] 30 continue - smin = max( eps*max( abs( tr( 1, 1 ) ), abs( tl( 1, 1 ) ),abs( tl( 1, 2 ) ), abs( tl( & - 2, 1 ) ), abs( tl( 2, 2 ) ) ),smlnum ) - tmp( 1 ) = tl( 1, 1 ) + sgn*tr( 1, 1 ) - tmp( 4 ) = tl( 2, 2 ) + sgn*tr( 1, 1 ) + smin = max( eps*max( abs( tr( 1_${ik}$, 1_${ik}$ ) ), abs( tl( 1_${ik}$, 1_${ik}$ ) ),abs( tl( 1_${ik}$, 2_${ik}$ ) ), abs( tl( & + 2_${ik}$, 1_${ik}$ ) ), abs( tl( 2_${ik}$, 2_${ik}$ ) ) ),smlnum ) + tmp( 1_${ik}$ ) = tl( 1_${ik}$, 1_${ik}$ ) + sgn*tr( 1_${ik}$, 1_${ik}$ ) + tmp( 4_${ik}$ ) = tl( 2_${ik}$, 2_${ik}$ ) + sgn*tr( 1_${ik}$, 1_${ik}$ ) if( ltranl ) then - tmp( 2 ) = tl( 1, 2 ) - tmp( 3 ) = tl( 2, 1 ) + tmp( 2_${ik}$ ) = tl( 1_${ik}$, 2_${ik}$ ) + tmp( 3_${ik}$ ) = tl( 2_${ik}$, 1_${ik}$ ) else - tmp( 2 ) = tl( 2, 1 ) - tmp( 3 ) = tl( 1, 2 ) + tmp( 2_${ik}$ ) = tl( 2_${ik}$, 1_${ik}$ ) + tmp( 3_${ik}$ ) = tl( 1_${ik}$, 2_${ik}$ ) end if - btmp( 1 ) = b( 1, 1 ) - btmp( 2 ) = b( 2, 1 ) + btmp( 1_${ik}$ ) = b( 1_${ik}$, 1_${ik}$ ) + btmp( 2_${ik}$ ) = b( 2_${ik}$, 1_${ik}$ ) 40 continue - ! solve 2 by 2 system using complete pivoting. + ! solve 2_${ik}$ by 2_${ik}$ system using complete pivoting. ! set pivots less than smin to smin. - ipiv = stdlib_isamax( 4, tmp, 1 ) + ipiv = stdlib${ii}$_isamax( 4_${ik}$, tmp, 1_${ik}$ ) u11 = tmp( ipiv ) if( abs( u11 )<=smin ) then - info = 1 + info = 1_${ik}$ u11 = smin end if u12 = tmp( locu12( ipiv ) ) @@ -8138,82 +8140,82 @@ module stdlib_linalg_lapack_s xswap = xswpiv( ipiv ) bswap = bswpiv( ipiv ) if( abs( u22 )<=smin ) then - info = 1 + info = 1_${ik}$ u22 = smin end if if( bswap ) then - temp = btmp( 2 ) - btmp( 2 ) = btmp( 1 ) - l21*temp - btmp( 1 ) = temp + temp = btmp( 2_${ik}$ ) + btmp( 2_${ik}$ ) = btmp( 1_${ik}$ ) - l21*temp + btmp( 1_${ik}$ ) = temp else - btmp( 2 ) = btmp( 2 ) - l21*btmp( 1 ) + btmp( 2_${ik}$ ) = btmp( 2_${ik}$ ) - l21*btmp( 1_${ik}$ ) end if scale = one - if( ( two*smlnum )*abs( btmp( 2 ) )>abs( u22 ) .or.( two*smlnum )*abs( btmp( 1 ) )>abs(& + if( ( two*smlnum )*abs( btmp( 2_${ik}$ ) )>abs( u22 ) .or.( two*smlnum )*abs( btmp( 1_${ik}$ ) )>abs(& u11 ) ) then - scale = half / max( abs( btmp( 1 ) ), abs( btmp( 2 ) ) ) - btmp( 1 ) = btmp( 1 )*scale - btmp( 2 ) = btmp( 2 )*scale + scale = half / max( abs( btmp( 1_${ik}$ ) ), abs( btmp( 2_${ik}$ ) ) ) + btmp( 1_${ik}$ ) = btmp( 1_${ik}$ )*scale + btmp( 2_${ik}$ ) = btmp( 2_${ik}$ )*scale end if - x2( 2 ) = btmp( 2 ) / u22 - x2( 1 ) = btmp( 1 ) / u11 - ( u12 / u11 )*x2( 2 ) + x2( 2_${ik}$ ) = btmp( 2_${ik}$ ) / u22 + x2( 1_${ik}$ ) = btmp( 1_${ik}$ ) / u11 - ( u12 / u11 )*x2( 2_${ik}$ ) if( xswap ) then - temp = x2( 2 ) - x2( 2 ) = x2( 1 ) - x2( 1 ) = temp + temp = x2( 2_${ik}$ ) + x2( 2_${ik}$ ) = x2( 1_${ik}$ ) + x2( 1_${ik}$ ) = temp end if - x( 1, 1 ) = x2( 1 ) - if( n1==1 ) then - x( 1, 2 ) = x2( 2 ) - xnorm = abs( x( 1, 1 ) ) + abs( x( 1, 2 ) ) + x( 1_${ik}$, 1_${ik}$ ) = x2( 1_${ik}$ ) + if( n1==1_${ik}$ ) then + x( 1_${ik}$, 2_${ik}$ ) = x2( 2_${ik}$ ) + xnorm = abs( x( 1_${ik}$, 1_${ik}$ ) ) + abs( x( 1_${ik}$, 2_${ik}$ ) ) else - x( 2, 1 ) = x2( 2 ) - xnorm = max( abs( x( 1, 1 ) ), abs( x( 2, 1 ) ) ) + x( 2_${ik}$, 1_${ik}$ ) = x2( 2_${ik}$ ) + xnorm = max( abs( x( 1_${ik}$, 1_${ik}$ ) ), abs( x( 2_${ik}$, 1_${ik}$ ) ) ) end if return - ! 2 by 2: + ! 2_${ik}$ by 2_${ik}$: ! op[tl11 tl12]*[x11 x12] +isgn* [x11 x12]*op[tr11 tr12] = [b11 b12] ! [tl21 tl22] [x21 x22] [x21 x22] [tr21 tr22] [b21 b22] - ! solve equivalent 4 by 4 system using complete pivoting. + ! solve equivalent 4_${ik}$ by 4_${ik}$ system using complete pivoting. ! set pivots less than smin to smin. 50 continue - smin = max( abs( tr( 1, 1 ) ), abs( tr( 1, 2 ) ),abs( tr( 2, 1 ) ), abs( tr( 2, 2 ) ) ) + smin = max( abs( tr( 1_${ik}$, 1_${ik}$ ) ), abs( tr( 1_${ik}$, 2_${ik}$ ) ),abs( tr( 2_${ik}$, 1_${ik}$ ) ), abs( tr( 2_${ik}$, 2_${ik}$ ) ) ) - smin = max( smin, abs( tl( 1, 1 ) ), abs( tl( 1, 2 ) ),abs( tl( 2, 1 ) ), abs( tl( 2, & - 2 ) ) ) + smin = max( smin, abs( tl( 1_${ik}$, 1_${ik}$ ) ), abs( tl( 1_${ik}$, 2_${ik}$ ) ),abs( tl( 2_${ik}$, 1_${ik}$ ) ), abs( tl( 2_${ik}$, & + 2_${ik}$ ) ) ) smin = max( eps*smin, smlnum ) - btmp( 1 ) = zero - call stdlib_scopy( 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 ) - t16( 4, 4 ) = tl( 2, 2 ) + sgn*tr( 2, 2 ) + btmp( 1_${ik}$ ) = zero + call stdlib${ii}$_scopy( 16_${ik}$, btmp, 0_${ik}$, t16, 1_${ik}$ ) + t16( 1_${ik}$, 1_${ik}$ ) = tl( 1_${ik}$, 1_${ik}$ ) + sgn*tr( 1_${ik}$, 1_${ik}$ ) + t16( 2_${ik}$, 2_${ik}$ ) = tl( 2_${ik}$, 2_${ik}$ ) + sgn*tr( 1_${ik}$, 1_${ik}$ ) + t16( 3_${ik}$, 3_${ik}$ ) = tl( 1_${ik}$, 1_${ik}$ ) + sgn*tr( 2_${ik}$, 2_${ik}$ ) + t16( 4_${ik}$, 4_${ik}$ ) = tl( 2_${ik}$, 2_${ik}$ ) + sgn*tr( 2_${ik}$, 2_${ik}$ ) if( ltranl ) then - t16( 1, 2 ) = tl( 2, 1 ) - t16( 2, 1 ) = tl( 1, 2 ) - t16( 3, 4 ) = tl( 2, 1 ) - t16( 4, 3 ) = tl( 1, 2 ) + t16( 1_${ik}$, 2_${ik}$ ) = tl( 2_${ik}$, 1_${ik}$ ) + t16( 2_${ik}$, 1_${ik}$ ) = tl( 1_${ik}$, 2_${ik}$ ) + t16( 3_${ik}$, 4_${ik}$ ) = tl( 2_${ik}$, 1_${ik}$ ) + t16( 4_${ik}$, 3_${ik}$ ) = tl( 1_${ik}$, 2_${ik}$ ) else - t16( 1, 2 ) = tl( 1, 2 ) - t16( 2, 1 ) = tl( 2, 1 ) - t16( 3, 4 ) = tl( 1, 2 ) - t16( 4, 3 ) = tl( 2, 1 ) + t16( 1_${ik}$, 2_${ik}$ ) = tl( 1_${ik}$, 2_${ik}$ ) + t16( 2_${ik}$, 1_${ik}$ ) = tl( 2_${ik}$, 1_${ik}$ ) + t16( 3_${ik}$, 4_${ik}$ ) = tl( 1_${ik}$, 2_${ik}$ ) + t16( 4_${ik}$, 3_${ik}$ ) = tl( 2_${ik}$, 1_${ik}$ ) end if if( ltranr ) then - t16( 1, 3 ) = sgn*tr( 1, 2 ) - t16( 2, 4 ) = sgn*tr( 1, 2 ) - t16( 3, 1 ) = sgn*tr( 2, 1 ) - t16( 4, 2 ) = sgn*tr( 2, 1 ) - else - t16( 1, 3 ) = sgn*tr( 2, 1 ) - t16( 2, 4 ) = sgn*tr( 2, 1 ) - t16( 3, 1 ) = sgn*tr( 1, 2 ) - t16( 4, 2 ) = sgn*tr( 1, 2 ) - end if - btmp( 1 ) = b( 1, 1 ) - btmp( 2 ) = b( 2, 1 ) - btmp( 3 ) = b( 1, 2 ) - btmp( 4 ) = b( 2, 2 ) + t16( 1_${ik}$, 3_${ik}$ ) = sgn*tr( 1_${ik}$, 2_${ik}$ ) + t16( 2_${ik}$, 4_${ik}$ ) = sgn*tr( 1_${ik}$, 2_${ik}$ ) + t16( 3_${ik}$, 1_${ik}$ ) = sgn*tr( 2_${ik}$, 1_${ik}$ ) + t16( 4_${ik}$, 2_${ik}$ ) = sgn*tr( 2_${ik}$, 1_${ik}$ ) + else + t16( 1_${ik}$, 3_${ik}$ ) = sgn*tr( 2_${ik}$, 1_${ik}$ ) + t16( 2_${ik}$, 4_${ik}$ ) = sgn*tr( 2_${ik}$, 1_${ik}$ ) + t16( 3_${ik}$, 1_${ik}$ ) = sgn*tr( 1_${ik}$, 2_${ik}$ ) + t16( 4_${ik}$, 2_${ik}$ ) = sgn*tr( 1_${ik}$, 2_${ik}$ ) + end if + btmp( 1_${ik}$ ) = b( 1_${ik}$, 1_${ik}$ ) + btmp( 2_${ik}$ ) = b( 2_${ik}$, 1_${ik}$ ) + btmp( 3_${ik}$ ) = b( 1_${ik}$, 2_${ik}$ ) + btmp( 4_${ik}$ ) = b( 2_${ik}$, 2_${ik}$ ) ! perform elimination loop_100: do i = 1, 3 xmax = zero @@ -8227,15 +8229,15 @@ module stdlib_linalg_lapack_s end do end do if( ipsv/=i ) then - call stdlib_sswap( 4, t16( ipsv, 1 ), 4, t16( i, 1 ), 4 ) + call stdlib${ii}$_sswap( 4_${ik}$, t16( ipsv, 1_${ik}$ ), 4_${ik}$, t16( i, 1_${ik}$ ), 4_${ik}$ ) temp = btmp( i ) btmp( i ) = btmp( ipsv ) btmp( ipsv ) = temp end if - if( jpsv/=i )call stdlib_sswap( 4, t16( 1, jpsv ), 1, t16( 1, i ), 1 ) + if( jpsv/=i )call stdlib${ii}$_sswap( 4_${ik}$, t16( 1_${ik}$, jpsv ), 1_${ik}$, t16( 1_${ik}$, i ), 1_${ik}$ ) jpiv( i ) = jpsv if( abs( t16( i, i ) )abs( t16( 1, 1 ) ) .or.( eight*smlnum )*abs( & - btmp( 2 ) )>abs( t16( 2, 2 ) ) .or.( eight*smlnum )*abs( btmp( 3 ) )>abs( t16( 3, 3 ) )& - .or.( eight*smlnum )*abs( btmp( 4 ) )>abs( t16( 4, 4 ) ) ) then - scale = ( one / eight ) / max( abs( btmp( 1 ) ),abs( btmp( 2 ) ), abs( btmp( 3 ) ), & - abs( btmp( 4 ) ) ) - btmp( 1 ) = btmp( 1 )*scale - btmp( 2 ) = btmp( 2 )*scale - btmp( 3 ) = btmp( 3 )*scale - btmp( 4 ) = btmp( 4 )*scale + if( ( eight*smlnum )*abs( btmp( 1_${ik}$ ) )>abs( t16( 1_${ik}$, 1_${ik}$ ) ) .or.( eight*smlnum )*abs( & + btmp( 2_${ik}$ ) )>abs( t16( 2_${ik}$, 2_${ik}$ ) ) .or.( eight*smlnum )*abs( btmp( 3_${ik}$ ) )>abs( t16( 3_${ik}$, 3_${ik}$ ) )& + .or.( eight*smlnum )*abs( btmp( 4_${ik}$ ) )>abs( t16( 4_${ik}$, 4_${ik}$ ) ) ) then + scale = ( one / eight ) / max( abs( btmp( 1_${ik}$ ) ),abs( btmp( 2_${ik}$ ) ), abs( btmp( 3_${ik}$ ) ), & + abs( btmp( 4_${ik}$ ) ) ) + btmp( 1_${ik}$ ) = btmp( 1_${ik}$ )*scale + btmp( 2_${ik}$ ) = btmp( 2_${ik}$ )*scale + btmp( 3_${ik}$ ) = btmp( 3_${ik}$ )*scale + btmp( 4_${ik}$ ) = btmp( 4_${ik}$ )*scale end if do i = 1, 4 - k = 5 - i + k = 5_${ik}$ - i temp = one / t16( k, k ) tmp( k ) = btmp( k )*temp do j = k + 1, 4 @@ -8270,43 +8272,43 @@ module stdlib_linalg_lapack_s end do end do do i = 1, 3 - if( jpiv( 4-i )/=4-i ) then - temp = tmp( 4-i ) - tmp( 4-i ) = tmp( jpiv( 4-i ) ) - tmp( jpiv( 4-i ) ) = temp + if( jpiv( 4_${ik}$-i )/=4_${ik}$-i ) then + temp = tmp( 4_${ik}$-i ) + tmp( 4_${ik}$-i ) = tmp( jpiv( 4_${ik}$-i ) ) + tmp( jpiv( 4_${ik}$-i ) ) = temp end if end do - x( 1, 1 ) = tmp( 1 ) - x( 2, 1 ) = tmp( 2 ) - x( 1, 2 ) = tmp( 3 ) - x( 2, 2 ) = tmp( 4 ) - xnorm = max( abs( tmp( 1 ) )+abs( tmp( 3 ) ),abs( tmp( 2 ) )+abs( tmp( 4 ) ) ) + x( 1_${ik}$, 1_${ik}$ ) = tmp( 1_${ik}$ ) + x( 2_${ik}$, 1_${ik}$ ) = tmp( 2_${ik}$ ) + x( 1_${ik}$, 2_${ik}$ ) = tmp( 3_${ik}$ ) + x( 2_${ik}$, 2_${ik}$ ) = tmp( 4_${ik}$ ) + xnorm = max( abs( tmp( 1_${ik}$ ) )+abs( tmp( 3_${ik}$ ) ),abs( tmp( 2_${ik}$ ) )+abs( tmp( 4_${ik}$ ) ) ) return - end subroutine stdlib_slasy2 + end subroutine stdlib${ii}$_slasy2 - pure subroutine stdlib_slasyf( uplo, n, nb, kb, a, lda, ipiv, w, ldw, info ) + pure subroutine stdlib${ii}$_slasyf( uplo, n, nb, kb, a, lda, ipiv, w, ldw, info ) !! SLASYF computes a partial factorization of a real symmetric matrix A !! using the Bunch-Kaufman diagonal pivoting method. The partial !! factorization has the form: - !! A = ( I U12 ) ( A11 0 ) ( I 0 ) if UPLO = 'U', or: - !! ( 0 U22 ) ( 0 D ) ( U12**T U22**T ) - !! A = ( L11 0 ) ( D 0 ) ( L11**T L21**T ) if UPLO = 'L' - !! ( L21 I ) ( 0 A22 ) ( 0 I ) + !! A = ( I U12 ) ( A11 0_${ik}$ ) ( I 0_${ik}$ ) if UPLO = 'U', or: + !! ( 0_${ik}$ U22 ) ( 0_${ik}$ D ) ( U12**T U22**T ) + !! A = ( L11 0_${ik}$ ) ( D 0_${ik}$ ) ( L11**T L21**T ) if UPLO = 'L' + !! ( L21 I ) ( 0_${ik}$ A22 ) ( 0_${ik}$ I ) !! where the order of D is at most NB. The actual order is returned in !! the argument KB, and is either NB or NB-1, or N if N <= NB. !! SLASYF is an auxiliary routine called by SSYTRF. It uses blocked code - !! (calling Level 3 BLAS) to update the submatrix A11 (if UPLO = 'U') or + !! (calling Level 3_${ik}$ BLAS) to update the submatrix A11 (if UPLO = 'U') or !! A22 (if UPLO = 'L'). ! -- lapack computational routine -- ! -- lapack is a software package provided by univ. of tennessee, -- ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: uplo - integer(ilp), intent(out) :: info, kb - integer(ilp), intent(in) :: lda, ldw, n, nb + integer(${ik}$), intent(out) :: info, kb + integer(${ik}$), intent(in) :: lda, ldw, n, nb ! Array Arguments - integer(ilp), intent(out) :: ipiv(*) + integer(${ik}$), intent(out) :: ipiv(*) real(sp), intent(inout) :: a(lda,*) real(sp), intent(out) :: w(ldw,*) ! ===================================================================== @@ -8315,19 +8317,19 @@ module stdlib_linalg_lapack_s ! Local Scalars - integer(ilp) :: imax, j, jb, jj, jmax, jp, k, kk, kkw, kp, kstep, kw + integer(${ik}$) :: imax, j, jb, jj, jmax, jp, k, kk, kkw, kp, kstep, kw real(sp) :: absakk, alpha, colmax, d11, d21, d22, r1, rowmax, t ! Intrinsic Functions intrinsic :: abs,max,min,sqrt ! Executable Statements - info = 0 + info = 0_${ik}$ ! initialize alpha for use in choosing pivot block size. alpha = ( one+sqrt( sevten ) ) / eight if( stdlib_lsame( uplo, 'U' ) ) then ! factorize the trailing columns of a using the upper triangle ! of a and working backwards, and compute the matrix w = u12*d ! for use in updating a11 - ! k is the main loop index, decreasing from n in steps of 1 or 2 + ! k is the main loop index, decreasing from n in steps of 1_${ik}$ or 2_${ik}$ ! kw is the column of w which corresponds to column k of a k = n 10 continue @@ -8335,64 +8337,64 @@ module stdlib_linalg_lapack_s ! exit from loop if( ( k<=n-nb+1 .and. nb1 ) then - imax = stdlib_isamax( k-1, w( 1, kw ), 1 ) + if( k>1_${ik}$ ) then + imax = stdlib${ii}$_isamax( k-1, w( 1_${ik}$, kw ), 1_${ik}$ ) colmax = abs( w( imax, kw ) ) else colmax = zero end if if( max( absakk, colmax )==zero ) then ! column k is zero or underflow: set info and continue - if( info==0 )info = k + if( info==0_${ik}$ )info = k kp = k else if( absakk>=alpha*colmax ) then - ! no interchange, use 1-by-1 pivot block + ! no interchange, use 1_${ik}$-by-1 pivot block kp = k else ! copy column imax to column kw-1 of w and update it - call stdlib_scopy( imax, a( 1, imax ), 1, w( 1, kw-1 ), 1 ) - call stdlib_scopy( k-imax, a( imax, imax+1 ), lda,w( imax+1, kw-1 ), 1 ) + call stdlib${ii}$_scopy( imax, a( 1_${ik}$, imax ), 1_${ik}$, w( 1_${ik}$, kw-1 ), 1_${ik}$ ) + call stdlib${ii}$_scopy( k-imax, a( imax, imax+1 ), lda,w( imax+1, kw-1 ), 1_${ik}$ ) - if( k1 ) then - jmax = stdlib_isamax( imax-1, w( 1, kw-1 ), 1 ) + if( imax>1_${ik}$ ) then + jmax = stdlib${ii}$_isamax( imax-1, w( 1_${ik}$, kw-1 ), 1_${ik}$ ) rowmax = max( rowmax, abs( w( jmax, kw-1 ) ) ) end if if( absakk>=alpha*colmax*( colmax / rowmax ) ) then - ! no interchange, use 1-by-1 pivot block + ! no interchange, use 1_${ik}$-by-1 pivot block kp = k else if( abs( w( imax, kw-1 ) )>=alpha*rowmax ) then - ! interchange rows and columns k and imax, use 1-by-1 + ! interchange rows and columns k and imax, use 1_${ik}$-by-1 ! pivot block kp = imax ! copy column kw-1 of w to column kw of w - call stdlib_scopy( k, w( 1, kw-1 ), 1, w( 1, kw ), 1 ) + call stdlib${ii}$_scopy( k, w( 1_${ik}$, kw-1 ), 1_${ik}$, w( 1_${ik}$, kw ), 1_${ik}$ ) else - ! interchange rows and columns k-1 and imax, use 2-by-2 + ! interchange rows and columns k-1 and imax, use 2_${ik}$-by-2 ! pivot block kp = imax - kstep = 2 + kstep = 2_${ik}$ end if end if ! ============================================================ ! kk is the column of a where pivoting step stopped - kk = k - kstep + 1 + kk = k - kstep + 1_${ik}$ ! kkw is the column of w which corresponds to column kk of a kkw = nb + kk - n ! interchange rows and columns kp and kk. @@ -8400,61 +8402,61 @@ module stdlib_linalg_lapack_s if( kp/=kk ) then ! copy non-updated column kk to column kp of submatrix a ! 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 + ! (or k and k-1 for 2_${ik}$-by-2 pivot) of a, since these columns ! will be later overwritten. a( kp, kp ) = a( kk, kk ) - call stdlib_scopy( kk-1-kp, a( kp+1, kk ), 1, a( kp, kp+1 ),lda ) - if( kp>1 )call stdlib_scopy( kp-1, a( 1, kk ), 1, a( 1, kp ), 1 ) + call stdlib${ii}$_scopy( kk-1-kp, a( kp+1, kk ), 1_${ik}$, a( kp, kp+1 ),lda ) + if( kp>1_${ik}$ )call stdlib${ii}$_scopy( kp-1, a( 1_${ik}$, kk ), 1_${ik}$, a( 1_${ik}$, kp ), 1_${ik}$ ) ! 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 + ! (columns k (or k and k-1 for 2_${ik}$-by-2 pivot) of a will be ! later overwritten). interchange rows kk and kp ! in last kkw to nb columns of w. - if( k2 ) then - ! compose the columns of the inverse of 2-by-2 pivot + ! a(1_${ik}$:k-2,k-1:k) := u(1_${ik}$:k-2,k:k-1:k) = + ! = w(1_${ik}$:k-2,kw-1:kw) * ( d(k-1:k,k-1:k)**(-1_${ik}$) ) + if( k>2_${ik}$ ) then + ! compose the columns of the inverse of 2_${ik}$-by-2 pivot ! block d in the following way to reduce the number ! of flops when we myltiply panel ( w(kw-1) w(kw) ) by ! this inverse - ! d**(-1) = ( d11 d21 )**(-1) = + ! d**(-1_${ik}$) = ( d11 d21 )**(-1_${ik}$) = ! ( d21 d22 ) - ! = 1/(d11*d22-d21**2) * ( ( d22 ) (-d21 ) ) = + ! = 1_${ik}$/(d11*d22-d21**2_${ik}$) * ( ( d22 ) (-d21 ) ) = ! ( (-d21 ) ( d11 ) ) - ! = 1/d21 * 1/((d11/d21)*(d22/d21)-1) * - ! * ( ( d22/d21 ) ( -1 ) ) = - ! ( ( -1 ) ( d11/d21 ) ) - ! = 1/d21 * 1/(d22*d11-1) * ( ( d11 ) ( -1 ) ) = - ! ( ( -1 ) ( d22 ) ) - ! = 1/d21 * t * ( ( d11 ) ( -1 ) ) - ! ( ( -1 ) ( d22 ) ) - ! = d21 * ( ( d11 ) ( -1 ) ) - ! ( ( -1 ) ( d22 ) ) + ! = 1_${ik}$/d21 * 1_${ik}$/((d11/d21)*(d22/d21)-1_${ik}$) * + ! * ( ( d22/d21 ) ( -1_${ik}$ ) ) = + ! ( ( -1_${ik}$ ) ( d11/d21 ) ) + ! = 1_${ik}$/d21 * 1_${ik}$/(d22*d11-1) * ( ( d11 ) ( -1_${ik}$ ) ) = + ! ( ( -1_${ik}$ ) ( d22 ) ) + ! = 1_${ik}$/d21 * t * ( ( d11 ) ( -1_${ik}$ ) ) + ! ( ( -1_${ik}$ ) ( d22 ) ) + ! = d21 * ( ( d11 ) ( -1_${ik}$ ) ) + ! ( ( -1_${ik}$ ) ( d22 ) ) d21 = w( k-1, kw ) d11 = w( k, kw ) / d21 d22 = w( k-1, kw-1 ) / d21 @@ -8462,7 +8464,7 @@ module stdlib_linalg_lapack_s 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 - ! of d**(-1) + ! of d**(-1_${ik}$) do j = 1, k - 2 a( j, k-1 ) = d21*( d11*w( j, kw-1 )-w( j, kw ) ) a( j, k ) = d21*( d22*w( j, kw )-w( j, kw-1 ) ) @@ -8475,7 +8477,7 @@ module stdlib_linalg_lapack_s end if end if ! store details of the interchanges in ipiv - if( kstep==1 ) then + if( kstep==1_${ik}$ ) then ipiv( k ) = kp else ipiv( k ) = -kp @@ -8485,38 +8487,38 @@ module stdlib_linalg_lapack_s k = k - kstep go to 10 30 continue - ! update the upper triangle of a11 (= a(1:k,1:k)) as + ! update the upper triangle of a11 (= a(1_${ik}$:k,1_${ik}$:k)) as ! a11 := a11 - u12*d*u12**t = a11 - u12*w**t ! computing blocks of nb columns at a time do j = ( ( k-1 ) / nb )*nb + 1, 1, -nb jb = min( nb, k-j+1 ) ! update the upper triangle of the diagonal block do jj = j, j + jb - 1 - call stdlib_sgemv( 'NO TRANSPOSE', jj-j+1, n-k, -one,a( j, k+1 ), lda, w( jj, & - kw+1 ), ldw, one,a( j, jj ), 1 ) + call stdlib${ii}$_sgemv( 'NO TRANSPOSE', jj-j+1, n-k, -one,a( j, k+1 ), lda, w( jj, & + kw+1 ), ldw, one,a( j, jj ), 1_${ik}$ ) end do ! update the rectangular superdiagonal block - call stdlib_sgemm( 'NO TRANSPOSE', 'TRANSPOSE', j-1, jb, n-k, -one,a( 1, k+1 ), & - lda, w( j, kw+1 ), ldw, one,a( 1, j ), lda ) + call stdlib${ii}$_sgemm( 'NO TRANSPOSE', 'TRANSPOSE', j-1, jb, n-k, -one,a( 1_${ik}$, k+1 ), & + lda, w( j, kw+1 ), ldw, one,a( 1_${ik}$, j ), lda ) end do ! put u12 in standard form by partially undoing the interchanges ! in columns k+1:n looping backwards from k+1 to n - j = k + 1 + j = k + 1_${ik}$ 60 continue ! undo the interchanges (if any) of rows jj and jp at each ! step j ! (here, j is a diagonal index) jj = j jp = ipiv( j ) - if( jp<0 ) then + if( jp<0_${ik}$ ) then jp = -jp ! (here, j is a diagonal index) - j = j + 1 + j = j + 1_${ik}$ end if ! (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_sswap( n-j+1, a( jp, j ), lda, a( jj, j ), & + j = j + 1_${ik}$ + if( jp/=jj .and. j<=n )call stdlib${ii}$_sswap( n-j+1, a( jp, j ), lda, a( jj, j ), & lda ) if( j=nb .and. nbn )go to 90 ! copy column k of a to column k of w and update it - call stdlib_scopy( n-k+1, a( k, k ), 1, w( k, k ), 1 ) - call stdlib_sgemv( 'NO TRANSPOSE', n-k+1, k-1, -one, a( k, 1 ), lda,w( k, 1 ), ldw, & - one, w( k, k ), 1 ) - kstep = 1 + call stdlib${ii}$_scopy( n-k+1, a( k, k ), 1_${ik}$, w( k, k ), 1_${ik}$ ) + call stdlib${ii}$_sgemv( 'NO TRANSPOSE', n-k+1, k-1, -one, a( k, 1_${ik}$ ), lda,w( k, 1_${ik}$ ), ldw, & + one, w( k, k ), 1_${ik}$ ) + kstep = 1_${ik}$ ! determine rows and columns to be interchanged and whether - ! a 1-by-1 or 2-by-2 pivot block will be used + ! a 1_${ik}$-by-1 or 2_${ik}$-by-2 pivot block will be used absakk = abs( w( k, k ) ) ! imax is the row-index of the largest off-diagonal element in ! column k, and colmax is its absolute value. ! determine both colmax and imax. if( k=alpha*colmax ) then - ! no interchange, use 1-by-1 pivot block + ! no interchange, use 1_${ik}$-by-1 pivot block kp = k else ! copy column imax to column k+1 of w and update it - call stdlib_scopy( imax-k, a( imax, k ), lda, w( k, k+1 ), 1 ) - call stdlib_scopy( n-imax+1, a( imax, imax ), 1, w( imax, k+1 ),1 ) - call stdlib_sgemv( 'NO TRANSPOSE', n-k+1, k-1, -one, a( k, 1 ),lda, w( imax, & - 1 ), ldw, one, w( k, k+1 ), 1 ) + call stdlib${ii}$_scopy( imax-k, a( imax, k ), lda, w( k, k+1 ), 1_${ik}$ ) + call stdlib${ii}$_scopy( n-imax+1, a( imax, imax ), 1_${ik}$, w( imax, k+1 ),1_${ik}$ ) + call stdlib${ii}$_sgemv( 'NO TRANSPOSE', n-k+1, k-1, -one, a( k, 1_${ik}$ ),lda, w( imax, & + 1_${ik}$ ), ldw, one, w( k, k+1 ), 1_${ik}$ ) ! jmax is the column-index of the largest off-diagonal ! element in row imax, and rowmax is its absolute value - jmax = k - 1 + stdlib_isamax( imax-k, w( k, k+1 ), 1 ) + jmax = k - 1_${ik}$ + stdlib${ii}$_isamax( imax-k, w( k, k+1 ), 1_${ik}$ ) rowmax = abs( w( jmax, k+1 ) ) if( imax=alpha*colmax*( colmax / rowmax ) ) then - ! no interchange, use 1-by-1 pivot block + ! no interchange, use 1_${ik}$-by-1 pivot block kp = k else if( abs( w( imax, k+1 ) )>=alpha*rowmax ) then - ! interchange rows and columns k and imax, use 1-by-1 + ! interchange rows and columns k and imax, use 1_${ik}$-by-1 ! pivot block kp = imax ! copy column k+1 of w to column k of w - call stdlib_scopy( n-k+1, w( k, k+1 ), 1, w( k, k ), 1 ) + call stdlib${ii}$_scopy( n-k+1, w( k, k+1 ), 1_${ik}$, w( k, k ), 1_${ik}$ ) else - ! interchange rows and columns k+1 and imax, use 2-by-2 + ! interchange rows and columns k+1 and imax, use 2_${ik}$-by-2 ! pivot block kp = imax - kstep = 2 + kstep = 2_${ik}$ end if end if ! ============================================================ ! kk is the column of a where pivoting step stopped - kk = k + kstep - 1 + kk = k + kstep - 1_${ik}$ ! interchange rows and columns kp and kk. ! updated column kp is already stored in column kk of w. if( kp/=kk ) then ! copy non-updated column kk to column kp of submatrix a ! 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 + ! (or k and k+1 for 2_${ik}$-by-2 pivot) of a, since these columns ! will be later overwritten. a( kp, kp ) = a( kk, kk ) - call stdlib_scopy( kp-kk-1, a( kk+1, kk ), 1, a( kp, kk+1 ),lda ) - if( kp1 )call stdlib_sswap( k-1, a( kk, 1 ), lda, a( kp, 1 ), lda ) - call stdlib_sswap( kk, w( kk, 1 ), ldw, w( kp, 1 ), ldw ) + if( k>1_${ik}$ )call stdlib${ii}$_sswap( k-1, a( kk, 1_${ik}$ ), lda, a( kp, 1_${ik}$ ), lda ) + call stdlib${ii}$_sswap( kk, w( kk, 1_${ik}$ ), ldw, w( kp, 1_${ik}$ ), ldw ) end if - if( kstep==1 ) then - ! 1-by-1 pivot block d(k): column k of w now holds + if( kstep==1_${ik}$ ) then + ! 1_${ik}$-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 subdiag. elements of column l(k) - ! and 1-by-1 block d(k) in column k of a. + ! and 1_${ik}$-by-1 block d(k) in column k of a. ! (note: diagonal element l(k,k) is a unit element ! 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_scopy( n-k+1, w( k, k ), 1, a( k, k ), 1 ) + call stdlib${ii}$_scopy( n-k+1, w( k, k ), 1_${ik}$, a( k, k ), 1_${ik}$ ) if( k=1 )call stdlib_sswap( j, a( jp, 1 ), lda, a( jj, 1 ), lda ) + j = j - 1_${ik}$ + if( jp/=jj .and. j>=1_${ik}$ )call stdlib${ii}$_sswap( j, a( jp, 1_${ik}$ ), lda, a( jj, 1_${ik}$ ), lda ) if( j>1 )go to 120 ! set kb to the number of columns factorized - kb = k - 1 + kb = k - 1_${ik}$ end if return - end subroutine stdlib_slasyf + end subroutine stdlib${ii}$_slasyf - pure subroutine stdlib_slasyf_rk( uplo, n, nb, kb, a, lda, e, ipiv, w, ldw,info ) + pure subroutine stdlib${ii}$_slasyf_rk( uplo, n, nb, kb, a, lda, e, ipiv, w, ldw,info ) !! SLASYF_RK computes a partial factorization of a real symmetric !! matrix A using the bounded Bunch-Kaufman (rook) diagonal !! pivoting method. The partial factorization has the form: - !! A = ( I U12 ) ( A11 0 ) ( I 0 ) if UPLO = 'U', or: - !! ( 0 U22 ) ( 0 D ) ( U12**T U22**T ) - !! A = ( L11 0 ) ( D 0 ) ( L11**T L21**T ) if UPLO = 'L', - !! ( L21 I ) ( 0 A22 ) ( 0 I ) + !! A = ( I U12 ) ( A11 0_${ik}$ ) ( I 0_${ik}$ ) if UPLO = 'U', or: + !! ( 0_${ik}$ U22 ) ( 0_${ik}$ D ) ( U12**T U22**T ) + !! A = ( L11 0_${ik}$ ) ( D 0_${ik}$ ) ( L11**T L21**T ) if UPLO = 'L', + !! ( L21 I ) ( 0_${ik}$ A22 ) ( 0_${ik}$ I ) !! where the order of D is at most NB. The actual order is returned in !! the argument KB, and is either NB or NB-1, or N if N <= NB. !! SLASYF_RK is an auxiliary routine called by SSYTRF_RK. It uses - !! blocked code (calling Level 3 BLAS) to update the submatrix + !! blocked code (calling Level 3_${ik}$ BLAS) to update the submatrix !! A11 (if UPLO = 'U') or A22 (if UPLO = 'L'). ! -- lapack computational routine -- ! -- lapack is a software package provided by univ. of tennessee, -- ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: uplo - integer(ilp), intent(out) :: info, kb - integer(ilp), intent(in) :: lda, ldw, n, nb + integer(${ik}$), intent(out) :: info, kb + integer(${ik}$), intent(in) :: lda, ldw, n, nb ! Array Arguments - integer(ilp), intent(out) :: ipiv(*) + integer(${ik}$), intent(out) :: ipiv(*) real(sp), intent(inout) :: a(lda,*) real(sp), intent(out) :: e(*), w(ldw,*) ! ===================================================================== @@ -8753,63 +8755,63 @@ module stdlib_linalg_lapack_s ! Local Scalars logical(lk) :: done - integer(ilp) :: imax, itemp, j, jb, jj, jmax, k, kk, kw, kkw, kp, kstep, p, ii + integer(${ik}$) :: imax, itemp, j, jb, jj, jmax, k, kk, kw, kkw, kp, kstep, p, ii real(sp) :: absakk, alpha, colmax, d11, d12, d21, d22, stemp, r1, rowmax, t, & sfmin ! Intrinsic Functions intrinsic :: abs,max,min,sqrt ! Executable Statements - info = 0 + info = 0_${ik}$ ! initialize alpha for use in choosing pivot block size. alpha = ( one+sqrt( sevten ) ) / eight ! compute machine safe minimum - sfmin = stdlib_slamch( 'S' ) + sfmin = stdlib${ii}$_slamch( 'S' ) if( stdlib_lsame( uplo, 'U' ) ) then ! factorize the trailing columns of a using the upper triangle ! of a and working backwards, and compute the matrix w = u12*d ! for use in updating a11 ! initialize the first entry of array e, where superdiagonal ! elements of d are stored - e( 1 ) = zero - ! k is the main loop index, decreasing from n in steps of 1 or 2 + e( 1_${ik}$ ) = zero + ! k is the main loop index, decreasing from n in steps of 1_${ik}$ or 2_${ik}$ k = n 10 continue ! kw is the column of w which corresponds to column k of a kw = nb + k - n ! exit from loop if( ( k<=n-nb+1 .and. nb1 ) then - imax = stdlib_isamax( k-1, w( 1, kw ), 1 ) + if( k>1_${ik}$ ) then + imax = stdlib${ii}$_isamax( k-1, w( 1_${ik}$, kw ), 1_${ik}$ ) colmax = abs( w( imax, kw ) ) else colmax = zero end if if( max( absakk, colmax )==zero ) then ! column k is zero or underflow: set info and continue - if( info==0 )info = k + if( info==0_${ik}$ )info = k kp = k - call stdlib_scopy( k, w( 1, kw ), 1, a( 1, k ), 1 ) + call stdlib${ii}$_scopy( k, w( 1_${ik}$, kw ), 1_${ik}$, a( 1_${ik}$, k ), 1_${ik}$ ) ! set e( k ) to zero - if( k>1 )e( k ) = zero + if( k>1_${ik}$ )e( k ) = zero else ! ============================================================ ! test for interchange ! equivalent to testing for absakk>=alpha*colmax ! (used to handle nan and inf) if( .not.( absakk1 ) then - itemp = stdlib_isamax( imax-1, w( 1, kw-1 ), 1 ) + if( imax>1_${ik}$ ) then + itemp = stdlib${ii}$_isamax( imax-1, w( 1_${ik}$, kw-1 ), 1_${ik}$ ) stemp = abs( w( itemp, kw-1 ) ) if( stemp>rowmax ) then rowmax = stemp @@ -8844,18 +8846,18 @@ module stdlib_linalg_lapack_s ! (used to handle nan and inf) if( .not.(abs( w( imax, kw-1 ) )1 ) then + call stdlib${ii}$_scopy( k, w( 1_${ik}$, kw ), 1_${ik}$, a( 1_${ik}$, k ), 1_${ik}$ ) + if( k>1_${ik}$ ) then if( abs( a( k, k ) )>=sfmin ) then r1 = one / a( k, k ) - call stdlib_sscal( k-1, r1, a( 1, k ), 1 ) + call stdlib${ii}$_sscal( k-1, r1, a( 1_${ik}$, k ), 1_${ik}$ ) else if( a( k, k )/=zero ) then do ii = 1, k - 1 a( ii, k ) = a( ii, k ) / a( k, k ) @@ -8911,12 +8913,12 @@ module stdlib_linalg_lapack_s e( k ) = zero end if else - ! 2-by-2 pivot block d(k): columns kw and kw-1 of w now + ! 2_${ik}$-by-2 pivot block d(k): columns kw and kw-1 of w now ! hold ! ( w(k-1) w(k) ) = ( u(k-1) u(k) )*d(k) ! where u(k) and u(k-1) are the k-th and (k-1)-th columns ! of u - if( k>2 ) then + if( k>2_${ik}$ ) then ! store u(k) and u(k-1) in columns k and k-1 of a d12 = w( k-1, kw ) d11 = w( k, kw ) / d12 @@ -8939,7 +8941,7 @@ module stdlib_linalg_lapack_s ! end column k is nonsingular end if ! store details of the interchanges in ipiv - if( kstep==1 ) then + if( kstep==1_${ik}$ ) then ipiv( k ) = kp else ipiv( k ) = -p @@ -8949,19 +8951,19 @@ module stdlib_linalg_lapack_s k = k - kstep go to 10 30 continue - ! update the upper triangle of a11 (= a(1:k,1:k)) as + ! update the upper triangle of a11 (= a(1_${ik}$:k,1_${ik}$:k)) as ! a11 := a11 - u12*d*u12**t = a11 - u12*w**t ! computing blocks of nb columns at a time do j = ( ( k-1 ) / nb )*nb + 1, 1, -nb jb = min( nb, k-j+1 ) ! update the upper triangle of the diagonal block do jj = j, j + jb - 1 - call stdlib_sgemv( 'NO TRANSPOSE', jj-j+1, n-k, -one,a( j, k+1 ), lda, w( jj, & - kw+1 ), ldw, one,a( j, jj ), 1 ) + call stdlib${ii}$_sgemv( 'NO TRANSPOSE', jj-j+1, n-k, -one,a( j, k+1 ), lda, w( jj, & + kw+1 ), ldw, one,a( j, jj ), 1_${ik}$ ) end do ! update the rectangular superdiagonal block - if( j>=2 )call stdlib_sgemm( 'NO TRANSPOSE', 'TRANSPOSE', j-1, jb,n-k, -one, a( & - 1, k+1 ), lda, w( j, kw+1 ),ldw, one, a( 1, j ), lda ) + if( j>=2_${ik}$ )call stdlib${ii}$_sgemm( 'NO TRANSPOSE', 'TRANSPOSE', j-1, jb,n-k, -one, a( & + 1_${ik}$, k+1 ), lda, w( j, kw+1 ),ldw, one, a( 1_${ik}$, j ), lda ) end do ! set kb to the number of columns factorized kb = n - k @@ -8971,34 +8973,34 @@ module stdlib_linalg_lapack_s ! for use in updating a22 ! initialize the unused last entry of the subdiagonal array e. e( n ) = zero - ! k is the main loop index, increasing from 1 in steps of 1 or 2 - k = 1 + ! k is the main loop index, increasing from 1_${ik}$ in steps of 1_${ik}$ or 2_${ik}$ + k = 1_${ik}$ 70 continue ! exit from loop if( ( k>=nb .and. nbn )go to 90 - kstep = 1 + kstep = 1_${ik}$ p = k ! copy column k of a to column k of w and update it - call stdlib_scopy( n-k+1, a( k, k ), 1, w( k, k ), 1 ) - if( k>1 )call stdlib_sgemv( 'NO TRANSPOSE', n-k+1, k-1, -one, a( k, 1 ),lda, w( k, & - 1 ), ldw, one, w( k, k ), 1 ) + call stdlib${ii}$_scopy( n-k+1, a( k, k ), 1_${ik}$, w( k, k ), 1_${ik}$ ) + if( k>1_${ik}$ )call stdlib${ii}$_sgemv( 'NO TRANSPOSE', n-k+1, k-1, -one, a( k, 1_${ik}$ ),lda, w( k, & + 1_${ik}$ ), ldw, one, w( k, k ), 1_${ik}$ ) ! determine rows and columns to be interchanged and whether - ! a 1-by-1 or 2-by-2 pivot block will be used + ! a 1_${ik}$-by-1 or 2_${ik}$-by-2 pivot block will be used absakk = abs( w( k, k ) ) ! imax is the row-index of the largest off-diagonal element in ! column k, and colmax is its absolute value. ! determine both colmax and imax. if( k=alpha*colmax ! (used to handle nan and inf) if( .not.( absakk1 )call stdlib_sgemv( 'NO TRANSPOSE', n-k+1, k-1, -one,a( k, 1 ), & - lda, w( imax, 1 ), ldw,one, w( k, k+1 ), 1 ) + call stdlib${ii}$_scopy( imax-k, a( imax, k ), lda, w( k, k+1 ), 1_${ik}$) + call stdlib${ii}$_scopy( n-imax+1, a( imax, imax ), 1_${ik}$,w( imax, k+1 ), 1_${ik}$ ) + if( k>1_${ik}$ )call stdlib${ii}$_sgemv( 'NO TRANSPOSE', n-k+1, k-1, -one,a( k, 1_${ik}$ ), & + lda, w( imax, 1_${ik}$ ), ldw,one, w( k, k+1 ), 1_${ik}$ ) ! jmax is the column-index of the largest off-diagonal ! element in row imax, and rowmax is its absolute value. ! determine both rowmax and jmax. if( imax/=k ) then - jmax = k - 1 + stdlib_isamax( imax-k, w( k, k+1 ), 1 ) + jmax = k - 1_${ik}$ + stdlib${ii}$_isamax( imax-k, w( k, k+1 ), 1_${ik}$ ) rowmax = abs( w( jmax, k+1 ) ) else rowmax = zero end if if( imaxrowmax ) then rowmax = stemp @@ -9041,18 +9043,18 @@ module stdlib_linalg_lapack_s ! (used to handle nan and inf) if( .not.( abs( w( imax, k+1 ) )=sfmin ) then r1 = one / a( k, k ) - call stdlib_sscal( n-k, r1, a( k+1, k ), 1 ) + call stdlib${ii}$_sscal( n-k, r1, a( k+1, k ), 1_${ik}$ ) else if( a( k, k )/=zero ) then do ii = k + 1, n a( ii, k ) = a( ii, k ) / a( k, k ) @@ -9105,7 +9107,7 @@ module stdlib_linalg_lapack_s e( k ) = zero end if else - ! 2-by-2 pivot block d(k): columns k and k+1 of w now hold + ! 2_${ik}$-by-2 pivot block d(k): columns k and k+1 of w now hold ! ( w(k) w(k+1) ) = ( l(k) l(k+1) )*d(k) ! where l(k) and l(k+1) are the k-th and (k+1)-th columns ! of l @@ -9132,7 +9134,7 @@ module stdlib_linalg_lapack_s ! end column k is nonsingular end if ! store details of the interchanges in ipiv - if( kstep==1 ) then + if( kstep==1_${ik}$ ) then ipiv( k ) = kp else ipiv( k ) = -p @@ -9149,42 +9151,42 @@ module stdlib_linalg_lapack_s jb = min( nb, n-j+1 ) ! update the lower triangle of the diagonal block do jj = j, j + jb - 1 - call stdlib_sgemv( 'NO TRANSPOSE', j+jb-jj, k-1, -one,a( jj, 1 ), lda, w( jj, & - 1 ), ldw, one,a( jj, jj ), 1 ) + call stdlib${ii}$_sgemv( 'NO TRANSPOSE', j+jb-jj, k-1, -one,a( jj, 1_${ik}$ ), lda, w( jj, & + 1_${ik}$ ), ldw, one,a( jj, jj ), 1_${ik}$ ) end do ! update the rectangular subdiagonal block - if( j+jb<=n )call stdlib_sgemm( '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 ) + if( j+jb<=n )call stdlib${ii}$_sgemm( 'NO TRANSPOSE', 'TRANSPOSE', n-j-jb+1, jb,k-1, -& + one, a( j+jb, 1_${ik}$ ), lda, w( j, 1_${ik}$ ),ldw, one, a( j+jb, j ), lda ) end do ! set kb to the number of columns factorized - kb = k - 1 + kb = k - 1_${ik}$ end if return - end subroutine stdlib_slasyf_rk + end subroutine stdlib${ii}$_slasyf_rk - pure subroutine stdlib_slasyf_rook( uplo, n, nb, kb, a, lda, ipiv, w, ldw,info ) + pure subroutine stdlib${ii}$_slasyf_rook( uplo, n, nb, kb, a, lda, ipiv, w, ldw,info ) !! SLASYF_ROOK computes a partial factorization of a real symmetric !! matrix A using the bounded Bunch-Kaufman ("rook") diagonal !! pivoting method. The partial factorization has the form: - !! A = ( I U12 ) ( A11 0 ) ( I 0 ) if UPLO = 'U', or: - !! ( 0 U22 ) ( 0 D ) ( U12**T U22**T ) - !! A = ( L11 0 ) ( D 0 ) ( L11**T L21**T ) if UPLO = 'L' - !! ( L21 I ) ( 0 A22 ) ( 0 I ) + !! A = ( I U12 ) ( A11 0_${ik}$ ) ( I 0_${ik}$ ) if UPLO = 'U', or: + !! ( 0_${ik}$ U22 ) ( 0_${ik}$ D ) ( U12**T U22**T ) + !! A = ( L11 0_${ik}$ ) ( D 0_${ik}$ ) ( L11**T L21**T ) if UPLO = 'L' + !! ( L21 I ) ( 0_${ik}$ A22 ) ( 0_${ik}$ I ) !! where the order of D is at most NB. The actual order is returned in !! the argument KB, and is either NB or NB-1, or N if N <= NB. !! SLASYF_ROOK is an auxiliary routine called by SSYTRF_ROOK. It uses - !! blocked code (calling Level 3 BLAS) to update the submatrix + !! blocked code (calling Level 3_${ik}$ BLAS) to update the submatrix !! A11 (if UPLO = 'U') or A22 (if UPLO = 'L'). ! -- lapack computational routine -- ! -- lapack is a software package provided by univ. of tennessee, -- ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: uplo - integer(ilp), intent(out) :: info, kb - integer(ilp), intent(in) :: lda, ldw, n, nb + integer(${ik}$), intent(out) :: info, kb + integer(${ik}$), intent(in) :: lda, ldw, n, nb ! Array Arguments - integer(ilp), intent(out) :: ipiv(*) + integer(${ik}$), intent(out) :: ipiv(*) real(sp), intent(inout) :: a(lda,*) real(sp), intent(out) :: w(ldw,*) ! ===================================================================== @@ -9194,59 +9196,59 @@ module stdlib_linalg_lapack_s ! Local Scalars logical(lk) :: done - integer(ilp) :: imax, itemp, j, jb, jj, jmax, jp1, jp2, k, kk, kw, kkw, kp, kstep, p, & + integer(${ik}$) :: imax, itemp, j, jb, jj, jmax, jp1, jp2, k, kk, kw, kkw, kp, kstep, p, & ii real(sp) :: absakk, alpha, colmax, d11, d12, d21, d22, stemp, r1, rowmax, t, & sfmin ! Intrinsic Functions intrinsic :: abs,max,min,sqrt ! Executable Statements - info = 0 + info = 0_${ik}$ ! initialize alpha for use in choosing pivot block size. alpha = ( one+sqrt( sevten ) ) / eight ! compute machine safe minimum - sfmin = stdlib_slamch( 'S' ) + sfmin = stdlib${ii}$_slamch( 'S' ) if( stdlib_lsame( uplo, 'U' ) ) then ! factorize the trailing columns of a using the upper triangle ! of a and working backwards, and compute the matrix w = u12*d ! for use in updating a11 - ! k is the main loop index, decreasing from n in steps of 1 or 2 + ! k is the main loop index, decreasing from n in steps of 1_${ik}$ or 2_${ik}$ k = n 10 continue ! kw is the column of w which corresponds to column k of a kw = nb + k - n ! exit from loop if( ( k<=n-nb+1 .and. nb1 ) then - imax = stdlib_isamax( k-1, w( 1, kw ), 1 ) + if( k>1_${ik}$ ) then + imax = stdlib${ii}$_isamax( k-1, w( 1_${ik}$, kw ), 1_${ik}$ ) colmax = abs( w( imax, kw ) ) else colmax = zero end if if( max( absakk, colmax )==zero ) then ! column k is zero or underflow: set info and continue - if( info==0 )info = k + if( info==0_${ik}$ )info = k kp = k - call stdlib_scopy( k, w( 1, kw ), 1, a( 1, k ), 1 ) + call stdlib${ii}$_scopy( k, w( 1_${ik}$, kw ), 1_${ik}$, a( 1_${ik}$, k ), 1_${ik}$ ) else ! ============================================================ ! test for interchange ! equivalent to testing for absakk>=alpha*colmax ! (used to handle nan and inf) if( .not.( absakk1 ) then - itemp = stdlib_isamax( imax-1, w( 1, kw-1 ), 1 ) + if( imax>1_${ik}$ ) then + itemp = stdlib${ii}$_isamax( imax-1, w( 1_${ik}$, kw-1 ), 1_${ik}$ ) stemp = abs( w( itemp, kw-1 ) ) if( stemp>rowmax ) then rowmax = stemp @@ -9281,18 +9283,18 @@ module stdlib_linalg_lapack_s ! (used to handle nan and inf) if( .not.(abs( w( imax, kw-1 ) )1 ) then + call stdlib${ii}$_scopy( k, w( 1_${ik}$, kw ), 1_${ik}$, a( 1_${ik}$, k ), 1_${ik}$ ) + if( k>1_${ik}$ ) then if( abs( a( k, k ) )>=sfmin ) then r1 = one / a( k, k ) - call stdlib_sscal( k-1, r1, a( 1, k ), 1 ) + call stdlib${ii}$_sscal( k-1, r1, a( 1_${ik}$, k ), 1_${ik}$ ) else if( a( k, k )/=zero ) then do ii = 1, k - 1 a( ii, k ) = a( ii, k ) / a( k, k ) @@ -9346,12 +9348,12 @@ module stdlib_linalg_lapack_s end if end if else - ! 2-by-2 pivot block d(k): columns kw and kw-1 of w now + ! 2_${ik}$-by-2 pivot block d(k): columns kw and kw-1 of w now ! hold ! ( w(k-1) w(k) ) = ( u(k-1) u(k) )*d(k) ! where u(k) and u(k-1) are the k-th and (k-1)-th columns ! of u - if( k>2 ) then + if( k>2_${ik}$ ) then ! store u(k) and u(k-1) in columns k and k-1 of a d12 = w( k-1, kw ) d11 = w( k, kw ) / d12 @@ -9369,7 +9371,7 @@ module stdlib_linalg_lapack_s end if end if ! store details of the interchanges in ipiv - if( kstep==1 ) then + if( kstep==1_${ik}$ ) then ipiv( k ) = kp else ipiv( k ) = -p @@ -9379,39 +9381,39 @@ module stdlib_linalg_lapack_s k = k - kstep go to 10 30 continue - ! update the upper triangle of a11 (= a(1:k,1:k)) as + ! update the upper triangle of a11 (= a(1_${ik}$:k,1_${ik}$:k)) as ! a11 := a11 - u12*d*u12**t = a11 - u12*w**t ! computing blocks of nb columns at a time do j = ( ( k-1 ) / nb )*nb + 1, 1, -nb jb = min( nb, k-j+1 ) ! update the upper triangle of the diagonal block do jj = j, j + jb - 1 - call stdlib_sgemv( 'NO TRANSPOSE', jj-j+1, n-k, -one,a( j, k+1 ), lda, w( jj, & - kw+1 ), ldw, one,a( j, jj ), 1 ) + call stdlib${ii}$_sgemv( 'NO TRANSPOSE', jj-j+1, n-k, -one,a( j, k+1 ), lda, w( jj, & + kw+1 ), ldw, one,a( j, jj ), 1_${ik}$ ) end do ! update the rectangular superdiagonal block - if( j>=2 )call stdlib_sgemm( 'NO TRANSPOSE', 'TRANSPOSE', j-1, jb,n-k, -one, a( & - 1, k+1 ), lda, w( j, kw+1 ), ldw,one, a( 1, j ), lda ) + if( j>=2_${ik}$ )call stdlib${ii}$_sgemm( 'NO TRANSPOSE', 'TRANSPOSE', j-1, jb,n-k, -one, a( & + 1_${ik}$, k+1 ), lda, w( j, kw+1 ), ldw,one, a( 1_${ik}$, j ), lda ) end do ! put u12 in standard form by partially undoing the interchanges ! in columns k+1:n - j = k + 1 + j = k + 1_${ik}$ 60 continue - kstep = 1 - jp1 = 1 + kstep = 1_${ik}$ + jp1 = 1_${ik}$ jj = j jp2 = ipiv( j ) - if( jp2<0 ) then + if( jp2<0_${ik}$ ) then jp2 = -jp2 - j = j + 1 + j = j + 1_${ik}$ jp1 = -ipiv( j ) - kstep = 2 + kstep = 2_${ik}$ end if - j = j + 1 - if( jp2/=jj .and. j<=n )call stdlib_sswap( n-j+1, a( jp2, j ), lda, a( jj, j ), & + j = j + 1_${ik}$ + if( jp2/=jj .and. j<=n )call stdlib${ii}$_sswap( n-j+1, a( jp2, j ), lda, a( jj, j ), & lda ) - jj = j - 1 - if( jp1/=jj .and. kstep==2 )call stdlib_sswap( n-j+1, a( jp1, j ), lda, a( jj, j & + jj = j - 1_${ik}$ + if( jp1/=jj .and. kstep==2_${ik}$ )call stdlib${ii}$_sswap( n-j+1, a( jp1, j ), lda, a( jj, j & ), lda ) if( j<=n )go to 60 ! set kb to the number of columns factorized @@ -9420,41 +9422,41 @@ module stdlib_linalg_lapack_s ! factorize the leading columns of a using the lower triangle ! of a and working forwards, and compute the matrix w = l21*d ! for use in updating a22 - ! k is the main loop index, increasing from 1 in steps of 1 or 2 - k = 1 + ! k is the main loop index, increasing from 1_${ik}$ in steps of 1_${ik}$ or 2_${ik}$ + k = 1_${ik}$ 70 continue ! exit from loop if( ( k>=nb .and. nbn )go to 90 - kstep = 1 + kstep = 1_${ik}$ p = k ! copy column k of a to column k of w and update it - call stdlib_scopy( n-k+1, a( k, k ), 1, w( k, k ), 1 ) - if( k>1 )call stdlib_sgemv( 'NO TRANSPOSE', n-k+1, k-1, -one, a( k, 1 ),lda, w( k, & - 1 ), ldw, one, w( k, k ), 1 ) + call stdlib${ii}$_scopy( n-k+1, a( k, k ), 1_${ik}$, w( k, k ), 1_${ik}$ ) + if( k>1_${ik}$ )call stdlib${ii}$_sgemv( 'NO TRANSPOSE', n-k+1, k-1, -one, a( k, 1_${ik}$ ),lda, w( k, & + 1_${ik}$ ), ldw, one, w( k, k ), 1_${ik}$ ) ! determine rows and columns to be interchanged and whether - ! a 1-by-1 or 2-by-2 pivot block will be used + ! a 1_${ik}$-by-1 or 2_${ik}$-by-2 pivot block will be used absakk = abs( w( k, k ) ) ! imax is the row-index of the largest off-diagonal element in ! column k, and colmax is its absolute value. ! determine both colmax and imax. if( k=alpha*colmax ! (used to handle nan and inf) if( .not.( absakk1 )call stdlib_sgemv( 'NO TRANSPOSE', n-k+1, k-1, -one,a( k, 1 ), & - lda, w( imax, 1 ), ldw,one, w( k, k+1 ), 1 ) + call stdlib${ii}$_scopy( imax-k, a( imax, k ), lda, w( k, k+1 ), 1_${ik}$) + call stdlib${ii}$_scopy( n-imax+1, a( imax, imax ), 1_${ik}$,w( imax, k+1 ), 1_${ik}$ ) + if( k>1_${ik}$ )call stdlib${ii}$_sgemv( 'NO TRANSPOSE', n-k+1, k-1, -one,a( k, 1_${ik}$ ), & + lda, w( imax, 1_${ik}$ ), ldw,one, w( k, k+1 ), 1_${ik}$ ) ! jmax is the column-index of the largest off-diagonal ! element in row imax, and rowmax is its absolute value. ! determine both rowmax and jmax. if( imax/=k ) then - jmax = k - 1 + stdlib_isamax( imax-k, w( k, k+1 ), 1 ) + jmax = k - 1_${ik}$ + stdlib${ii}$_isamax( imax-k, w( k, k+1 ), 1_${ik}$ ) rowmax = abs( w( jmax, k+1 ) ) else rowmax = zero end if if( imaxrowmax ) then rowmax = stemp @@ -9488,18 +9490,18 @@ module stdlib_linalg_lapack_s ! (used to handle nan and inf) if( .not.( abs( w( imax, k+1 ) )=sfmin ) then r1 = one / a( k, k ) - call stdlib_sscal( n-k, r1, a( k+1, k ), 1 ) + call stdlib${ii}$_sscal( n-k, r1, a( k+1, k ), 1_${ik}$ ) else if( a( k, k )/=zero ) then do ii = k + 1, n a( ii, k ) = a( ii, k ) / a( k, k ) @@ -9550,7 +9552,7 @@ module stdlib_linalg_lapack_s end if end if else - ! 2-by-2 pivot block d(k): columns k and k+1 of w now hold + ! 2_${ik}$-by-2 pivot block d(k): columns k and k+1 of w now hold ! ( w(k) w(k+1) ) = ( l(k) l(k+1) )*d(k) ! where l(k) and l(k+1) are the k-th and (k+1)-th columns ! of l @@ -9572,7 +9574,7 @@ module stdlib_linalg_lapack_s end if end if ! store details of the interchanges in ipiv - if( kstep==1 ) then + if( kstep==1_${ik}$ ) then ipiv( k ) = kp else ipiv( k ) = -p @@ -9589,60 +9591,60 @@ module stdlib_linalg_lapack_s jb = min( nb, n-j+1 ) ! update the lower triangle of the diagonal block do jj = j, j + jb - 1 - call stdlib_sgemv( 'NO TRANSPOSE', j+jb-jj, k-1, -one,a( jj, 1 ), lda, w( jj, & - 1 ), ldw, one,a( jj, jj ), 1 ) + call stdlib${ii}$_sgemv( 'NO TRANSPOSE', j+jb-jj, k-1, -one,a( jj, 1_${ik}$ ), lda, w( jj, & + 1_${ik}$ ), ldw, one,a( jj, jj ), 1_${ik}$ ) end do ! update the rectangular subdiagonal block - if( j+jb<=n )call stdlib_sgemm( '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 ) + if( j+jb<=n )call stdlib${ii}$_sgemm( 'NO TRANSPOSE', 'TRANSPOSE', n-j-jb+1, jb,k-1, -& + one, a( j+jb, 1_${ik}$ ), lda, w( j, 1_${ik}$ ), ldw,one, a( j+jb, j ), lda ) end do ! put l21 in standard form by partially undoing the interchanges - ! in columns 1:k-1 - j = k - 1 + ! in columns 1_${ik}$:k-1 + j = k - 1_${ik}$ 120 continue - kstep = 1 - jp1 = 1 + kstep = 1_${ik}$ + jp1 = 1_${ik}$ jj = j jp2 = ipiv( j ) - if( jp2<0 ) then + if( jp2<0_${ik}$ ) then jp2 = -jp2 - j = j - 1 + j = j - 1_${ik}$ jp1 = -ipiv( j ) - kstep = 2 + kstep = 2_${ik}$ end if - j = j - 1 - if( jp2/=jj .and. j>=1 )call stdlib_sswap( j, a( jp2, 1 ), lda, a( jj, 1 ), lda ) + j = j - 1_${ik}$ + if( jp2/=jj .and. j>=1_${ik}$ )call stdlib${ii}$_sswap( j, a( jp2, 1_${ik}$ ), lda, a( jj, 1_${ik}$ ), lda ) - jj = j + 1 - if( jp1/=jj .and. kstep==2 )call stdlib_sswap( j, a( jp1, 1 ), lda, a( jj, 1 ), & + jj = j + 1_${ik}$ + if( jp1/=jj .and. kstep==2_${ik}$ )call stdlib${ii}$_sswap( j, a( jp1, 1_${ik}$ ), lda, a( jj, 1_${ik}$ ), & lda ) if( j>=1 )go to 120 ! set kb to the number of columns factorized - kb = k - 1 + kb = k - 1_${ik}$ end if return - end subroutine stdlib_slasyf_rook + end subroutine stdlib${ii}$_slasyf_rook - pure subroutine stdlib_slatbs( uplo, trans, diag, normin, n, kd, ab, ldab, x,scale, cnorm, & + pure subroutine stdlib${ii}$_slatbs( uplo, trans, diag, normin, n, kd, ab, ldab, x,scale, cnorm, & !! SLATBS 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 !! triangular band matrix. Here A**T denotes the transpose of A, x and b !! are n-element vectors, and s is a scaling factor, usually less than - !! or equal to 1, chosen so that the components of x will be less than + !! or equal to 1_${ik}$, chosen so that the components of x will be less than !! the overflow threshold. If the unscaled problem will not cause - !! overflow, the Level 2 BLAS routine STBSV is called. If the matrix A - !! is singular (A(j,j) = 0 for some j), then s is set to 0 and a - !! non-trivial solution to A*x = 0 is returned. + !! overflow, the Level 2_${ik}$ BLAS routine STBSV is called. If the matrix A + !! is singular (A(j,j) = 0_${ik}$ for some j), then s is set to 0_${ik}$ and a + !! non-trivial solution to A*x = 0_${ik}$ is returned. info ) ! -- 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 character, intent(in) :: diag, normin, trans, uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: kd, ldab, n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: kd, ldab, n real(sp), intent(out) :: scale ! Array Arguments real(sp), intent(in) :: ab(ldab,*) @@ -9651,58 +9653,58 @@ module stdlib_linalg_lapack_s ! Local Scalars logical(lk) :: notran, nounit, upper - integer(ilp) :: i, imax, j, jfirst, jinc, jlast, jlen, maind + integer(${ik}$) :: i, imax, j, jfirst, jinc, jlast, jlen, maind real(sp) :: bignum, grow, rec, smlnum, sumj, tjj, tjjs, tmax, tscal, uscal, xbnd, xj, & xmax ! Intrinsic Functions intrinsic :: abs,max,min ! Executable Statements - info = 0 + info = 0_${ik}$ upper = stdlib_lsame( uplo, 'U' ) notran = stdlib_lsame( trans, 'N' ) nounit = stdlib_lsame( diag, 'N' ) ! test the input parameters. if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then - info = -1 + info = -1_${ik}$ else if( .not.notran .and. .not.stdlib_lsame( trans, 'T' ) .and. .not.stdlib_lsame( & trans, 'C' ) ) then - info = -2 + info = -2_${ik}$ else if( .not.nounit .and. .not.stdlib_lsame( diag, 'U' ) ) then - info = -3 + info = -3_${ik}$ else if( .not.stdlib_lsame( normin, 'Y' ) .and. .not.stdlib_lsame( normin, 'N' ) ) & then - info = -4 - else if( n<0 ) then - info = -5 - else if( kd<0 ) then - info = -6 + info = -4_${ik}$ + else if( n<0_${ik}$ ) then + info = -5_${ik}$ + else if( kd<0_${ik}$ ) then + info = -6_${ik}$ else if( ldab0 ) then - cnorm( j ) = stdlib_sasum( jlen, ab( 2, j ), 1 ) + if( jlen>0_${ik}$ ) then + cnorm( j ) = stdlib${ii}$_sasum( jlen, ab( 2_${ik}$, j ), 1_${ik}$ ) else cnorm( j ) = zero end if @@ -9711,31 +9713,31 @@ module stdlib_linalg_lapack_s end if ! scale the column norms by tscal if the maximum element in cnorm is ! greater than bignum. - imax = stdlib_isamax( n, cnorm, 1 ) + imax = stdlib${ii}$_isamax( n, cnorm, 1_${ik}$ ) tmax = cnorm( imax ) if( tmax<=bignum ) then tscal = one else tscal = one / ( smlnum*tmax ) - call stdlib_sscal( n, tscal, cnorm, 1 ) + call stdlib${ii}$_sscal( n, tscal, cnorm, 1_${ik}$ ) end if ! compute a bound on the computed solution vector to see if the - ! level 2 blas routine stdlib_stbsv can be used. - j = stdlib_isamax( n, x, 1 ) + ! level 2_${ik}$ blas routine stdlib${ii}$_stbsv can be used. + j = stdlib${ii}$_isamax( n, x, 1_${ik}$ ) xmax = abs( x( j ) ) xbnd = xmax if( notran ) then ! compute the growth in a * x = b. if( upper ) then jfirst = n - jlast = 1 - jinc = -1 - maind = kd + 1 + jlast = 1_${ik}$ + jinc = -1_${ik}$ + maind = kd + 1_${ik}$ else - jfirst = 1 + jfirst = 1_${ik}$ jlast = n - jinc = 1 - maind = 1 + jinc = 1_${ik}$ + maind = 1_${ik}$ end if if( tscal/=one ) then grow = zero @@ -9743,8 +9745,8 @@ module stdlib_linalg_lapack_s end if if( nounit ) then ! a is non-unit triangular. - ! compute grow = 1/g(j) and xbnd = 1/m(j). - ! initially, g(0) = max{x(i), i=1,...,n}. + ! compute grow = 1_${ik}$/g(j) and xbnd = 1_${ik}$/m(j). + ! initially, g(0_${ik}$) = max{x(i), i=1_${ik}$,...,n}. grow = one / max( xbnd, smlnum ) xbnd = grow do j = jfirst, jlast, jinc @@ -9754,7 +9756,7 @@ module stdlib_linalg_lapack_s tjj = abs( ab( maind, j ) ) xbnd = min( xbnd, min( one, tjj )*grow ) if( tjj+cnorm( j )>=smlnum ) then - ! g(j) = g(j-1)*( 1 + cnorm(j) / abs(a(j,j)) ) + ! g(j) = g(j-1)*( 1_${ik}$ + cnorm(j) / abs(a(j,j)) ) grow = grow*( tjj / ( tjj+cnorm( j ) ) ) else ! g(j) could overflow, set grow to 0. @@ -9764,12 +9766,12 @@ module stdlib_linalg_lapack_s grow = xbnd else ! a is unit triangular. - ! compute grow = 1/g(j), where g(0) = max{x(i), i=1,...,n}. + ! compute grow = 1_${ik}$/g(j), where g(0_${ik}$) = max{x(i), i=1_${ik}$,...,n}. grow = min( one, one / max( xbnd, smlnum ) ) do j = jfirst, jlast, jinc ! exit the loop if the growth factor is too small. if( grow<=smlnum )go to 50 - ! g(j) = g(j-1)*( 1 + cnorm(j) ) + ! g(j) = g(j-1)*( 1_${ik}$ + cnorm(j) ) grow = grow*( one / ( one+cnorm( j ) ) ) end do end if @@ -9777,15 +9779,15 @@ module stdlib_linalg_lapack_s else ! compute the growth in a**t * x = b. if( upper ) then - jfirst = 1 + jfirst = 1_${ik}$ jlast = n - jinc = 1 - maind = kd + 1 + jinc = 1_${ik}$ + maind = kd + 1_${ik}$ else jfirst = n - jlast = 1 - jinc = -1 - maind = 1 + jlast = 1_${ik}$ + jinc = -1_${ik}$ + maind = 1_${ik}$ end if if( tscal/=one ) then grow = zero @@ -9793,29 +9795,29 @@ module stdlib_linalg_lapack_s end if if( nounit ) then ! a is non-unit triangular. - ! compute grow = 1/g(j) and xbnd = 1/m(j). - ! initially, m(0) = max{x(i), i=1,...,n}. + ! compute grow = 1_${ik}$/g(j) and xbnd = 1_${ik}$/m(j). + ! initially, m(0_${ik}$) = max{x(i), i=1_${ik}$,...,n}. grow = one / max( xbnd, smlnum ) xbnd = grow do j = jfirst, jlast, jinc ! exit the loop if the growth factor is too small. if( grow<=smlnum )go to 80 - ! g(j) = max( g(j-1), m(j-1)*( 1 + cnorm(j) ) ) + ! g(j) = max( g(j-1), m(j-1)*( 1_${ik}$ + cnorm(j) ) ) xj = one + cnorm( j ) grow = min( grow, xbnd / xj ) - ! m(j) = m(j-1)*( 1 + cnorm(j) ) / abs(a(j,j)) + ! m(j) = m(j-1)*( 1_${ik}$ + cnorm(j) ) / abs(a(j,j)) tjj = abs( ab( maind, j ) ) if( xj>tjj )xbnd = xbnd*( tjj / xj ) end do grow = min( grow, xbnd ) else ! a is unit triangular. - ! compute grow = 1/g(j), where g(0) = max{x(i), i=1,...,n}. + ! compute grow = 1_${ik}$/g(j), where g(0_${ik}$) = max{x(i), i=1_${ik}$,...,n}. grow = min( one, one / max( xbnd, smlnum ) ) do j = jfirst, jlast, jinc ! exit the loop if the growth factor is too small. if( grow<=smlnum )go to 80 - ! g(j) = ( 1 + cnorm(j) )*g(j-1) + ! g(j) = ( 1_${ik}$ + cnorm(j) )*g(j-1) xj = one + cnorm( j ) grow = grow / xj end do @@ -9823,16 +9825,16 @@ module stdlib_linalg_lapack_s 80 continue end if if( ( grow*tscal )>smlnum ) then - ! use the level 2 blas solve if the reciprocal of the bound on + ! use the level 2_${ik}$ blas solve if the reciprocal of the bound on ! elements of x is not too small. - call stdlib_stbsv( uplo, trans, diag, n, kd, ab, ldab, x, 1 ) + call stdlib${ii}$_stbsv( uplo, trans, diag, n, kd, ab, ldab, x, 1_${ik}$ ) else - ! use a level 1 blas solve, scaling intermediate results. + ! use a level 1_${ik}$ 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_sscal( n, scale, x, 1 ) + call stdlib${ii}$_sscal( n, scale, x, 1_${ik}$ ) xmax = bignum end if if( notran ) then @@ -9851,9 +9853,9 @@ module stdlib_linalg_lapack_s ! abs(a(j,j)) > smlnum: if( tjjtjj*bignum ) then - ! scale x by 1/b(j). + ! scale x by 1_${ik}$/b(j). rec = one / xj - call stdlib_sscal( n, rec, x, 1 ) + call stdlib${ii}$_sscal( n, rec, x, 1_${ik}$ ) scale = scale*rec xmax = xmax*rec end if @@ -9861,25 +9863,25 @@ module stdlib_linalg_lapack_s x( j ) = x( j ) / tjjs xj = abs( x( j ) ) else if( tjj>zero ) then - ! 0 < abs(a(j,j)) <= smlnum: + ! 0_${ik}$ < abs(a(j,j)) <= smlnum: if( xj>tjj*bignum ) then - ! scale x by (1/abs(x(j)))*abs(a(j,j))*bignum + ! scale x by (1_${ik}$/abs(x(j)))*abs(a(j,j))*bignum ! to avoid overflow when dividing by a(j,j). rec = ( tjj*bignum ) / xj if( cnorm( j )>one ) then - ! scale by 1/cnorm(j) to avoid overflow when + ! scale by 1_${ik}$/cnorm(j) to avoid overflow when ! multiplying x(j) times column j. rec = rec / cnorm( j ) end if - call stdlib_sscal( n, rec, x, 1 ) + call stdlib${ii}$_sscal( n, rec, x, 1_${ik}$ ) scale = scale*rec xmax = xmax*rec end if x( j ) = x( j ) / tjjs xj = abs( x( j ) ) else - ! a(j,j) = 0: set x(1:n) = 0, x(j) = 1, and - ! scale = 0, and compute a solution to a*x = 0. + ! a(j,j) = 0_${ik}$: set x(1_${ik}$:n) = 0_${ik}$, x(j) = 1_${ik}$, and + ! scale = 0_${ik}$, and compute a solution to a*x = 0. do i = 1, n x( i ) = zero end do @@ -9894,25 +9896,25 @@ module stdlib_linalg_lapack_s if( xj>one ) then rec = one / xj if( cnorm( j )>( bignum-xmax )*rec ) then - ! scale x by 1/(2*abs(x(j))). + ! scale x by 1_${ik}$/(2_${ik}$*abs(x(j))). rec = rec*half - call stdlib_sscal( n, rec, x, 1 ) + call stdlib${ii}$_sscal( n, rec, x, 1_${ik}$ ) scale = scale*rec end if else if( xj*cnorm( j )>( bignum-xmax ) ) then - ! scale x by 1/2. - call stdlib_sscal( n, half, x, 1 ) + ! scale x by 1_${ik}$/2. + call stdlib${ii}$_sscal( n, half, x, 1_${ik}$ ) scale = scale*half end if if( upper ) then - if( j>1 ) then + if( j>1_${ik}$ ) then ! compute the update - ! x(max(1,j-kd):j-1) := x(max(1,j-kd):j-1) - - ! x(j)* a(max(1,j-kd):j-1,j) + ! x(max(1_${ik}$,j-kd):j-1) := x(max(1_${ik}$,j-kd):j-1) - + ! x(j)* a(max(1_${ik}$,j-kd):j-1,j) jlen = min( kd, j-1 ) - call stdlib_saxpy( jlen, -x( j )*tscal,ab( kd+1-jlen, j ), 1, x( j-jlen & - ), 1 ) - i = stdlib_isamax( j-1, x, 1 ) + call stdlib${ii}$_saxpy( jlen, -x( j )*tscal,ab( kd+1-jlen, j ), 1_${ik}$, x( j-jlen & + ), 1_${ik}$ ) + i = stdlib${ii}$_isamax( j-1, x, 1_${ik}$ ) xmax = abs( x( i ) ) end if else if( j0 )call stdlib_saxpy( jlen, -x( j )*tscal, ab( 2, j ), 1,x( j+1 ),& - 1 ) - i = j + stdlib_isamax( n-j, x( j+1 ), 1 ) + if( jlen>0_${ik}$ )call stdlib${ii}$_saxpy( jlen, -x( j )*tscal, ab( 2_${ik}$, j ), 1_${ik}$,x( j+1 ),& + 1_${ik}$ ) + i = j + stdlib${ii}$_isamax( n-j, x( j+1 ), 1_${ik}$ ) xmax = abs( x( i ) ) end if end do loop_100 @@ -9935,7 +9937,7 @@ module stdlib_linalg_lapack_s uscal = tscal rec = one / max( xmax, one ) if( cnorm( j )>( bignum-xj )*rec ) then - ! if x(j) could overflow, scale x by 1/(2*xmax). + ! if x(j) could overflow, scale x by 1_${ik}$/(2_${ik}$*xmax). rec = rec*half if( nounit ) then tjjs = ab( maind, j )*tscal @@ -9949,21 +9951,21 @@ module stdlib_linalg_lapack_s uscal = uscal / tjjs end if if( rec0 )sumj = stdlib_sdot( jlen, ab( 2, j ), 1, x( j+1 ), 1 ) + if( jlen>0_${ik}$ )sumj = stdlib${ii}$_sdot( jlen, ab( 2_${ik}$, j ), 1_${ik}$, x( j+1 ), 1_${ik}$ ) end if else @@ -9981,7 +9983,7 @@ module stdlib_linalg_lapack_s end if end if if( uscal==tscal ) then - ! compute x(j) := ( x(j) - sumj ) / a(j,j) if 1/a(j,j) + ! compute x(j) := ( x(j) - sumj ) / a(j,j) if 1_${ik}$/a(j,j) ! was not used to scale the dotproduct. x( j ) = x( j ) - sumj xj = abs( x( j ) ) @@ -9997,27 +9999,27 @@ module stdlib_linalg_lapack_s ! abs(a(j,j)) > smlnum: if( tjjtjj*bignum ) then - ! scale x by 1/abs(x(j)). + ! scale x by 1_${ik}$/abs(x(j)). rec = one / xj - call stdlib_sscal( n, rec, x, 1 ) + call stdlib${ii}$_sscal( n, rec, x, 1_${ik}$ ) scale = scale*rec xmax = xmax*rec end if end if x( j ) = x( j ) / tjjs else if( tjj>zero ) then - ! 0 < abs(a(j,j)) <= smlnum: + ! 0_${ik}$ < abs(a(j,j)) <= smlnum: if( xj>tjj*bignum ) then - ! scale x by (1/abs(x(j)))*abs(a(j,j))*bignum. + ! scale x by (1_${ik}$/abs(x(j)))*abs(a(j,j))*bignum. rec = ( tjj*bignum ) / xj - call stdlib_sscal( n, rec, x, 1 ) + call stdlib${ii}$_sscal( n, rec, x, 1_${ik}$ ) scale = scale*rec xmax = xmax*rec end if x( j ) = 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. + ! a(j,j) = 0_${ik}$: set x(1_${ik}$:n) = 0_${ik}$, x(j) = 1_${ik}$, and + ! scale = 0_${ik}$, and compute a solution to a**t*x = 0. do i = 1, n x( i ) = zero end do @@ -10028,7 +10030,7 @@ module stdlib_linalg_lapack_s 135 continue else ! compute x(j) := x(j) / a(j,j) - sumj if the dot - ! product has already been divided by 1/a(j,j). + ! product has already been divided by 1_${ik}$/a(j,j). x( j ) = x( j ) / tjjs - sumj end if xmax = max( xmax, abs( x( j ) ) ) @@ -10038,31 +10040,31 @@ module stdlib_linalg_lapack_s end if ! scale the column norms by 1/tscal for return. if( tscal/=one ) then - call stdlib_sscal( n, one / tscal, cnorm, 1 ) + call stdlib${ii}$_sscal( n, one / tscal, cnorm, 1_${ik}$ ) end if return - end subroutine stdlib_slatbs + end subroutine stdlib${ii}$_slatbs - pure subroutine stdlib_slatps( uplo, trans, diag, normin, n, ap, x, scale,cnorm, info ) + pure subroutine stdlib${ii}$_slatps( uplo, trans, diag, normin, n, ap, x, scale,cnorm, info ) !! SLATPS 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 !! triangular matrix stored in packed form. Here A**T denotes the !! transpose of A, x and b are n-element vectors, and s is a scaling - !! factor, usually less than or equal to 1, chosen so that the + !! factor, usually less than or equal to 1_${ik}$, chosen so that the !! components of x will be less than the overflow threshold. If the - !! unscaled problem will not cause overflow, the Level 2 BLAS routine - !! STPSV is called. If the matrix A is singular (A(j,j) = 0 for some j), - !! then s is set to 0 and a non-trivial solution to A*x = 0 is returned. + !! unscaled problem will not cause overflow, the Level 2_${ik}$ BLAS routine + !! STPSV is called. If the matrix A is singular (A(j,j) = 0_${ik}$ for some j), + !! then s is set to 0_${ik}$ and a non-trivial solution to A*x = 0_${ik}$ is returned. ! -- 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 character, intent(in) :: diag, normin, trans, uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: n real(sp), intent(out) :: scale ! Array Arguments real(sp), intent(in) :: ap(*) @@ -10071,84 +10073,84 @@ module stdlib_linalg_lapack_s ! Local Scalars logical(lk) :: notran, nounit, upper - integer(ilp) :: i, imax, ip, j, jfirst, jinc, jlast, jlen + integer(${ik}$) :: i, imax, ip, j, jfirst, jinc, jlast, jlen real(sp) :: bignum, grow, rec, smlnum, sumj, tjj, tjjs, tmax, tscal, uscal, xbnd, xj, & xmax ! Intrinsic Functions intrinsic :: abs,max,min ! Executable Statements - info = 0 + info = 0_${ik}$ upper = stdlib_lsame( uplo, 'U' ) notran = stdlib_lsame( trans, 'N' ) nounit = stdlib_lsame( diag, 'N' ) ! test the input parameters. if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then - info = -1 + info = -1_${ik}$ else if( .not.notran .and. .not.stdlib_lsame( trans, 'T' ) .and. .not.stdlib_lsame( & trans, 'C' ) ) then - info = -2 + info = -2_${ik}$ else if( .not.nounit .and. .not.stdlib_lsame( diag, 'U' ) ) then - info = -3 + info = -3_${ik}$ else if( .not.stdlib_lsame( normin, 'Y' ) .and. .not.stdlib_lsame( normin, 'N' ) ) & then - info = -4 - else if( n<0 ) then - info = -5 + info = -4_${ik}$ + else if( n<0_${ik}$ ) then + info = -5_${ik}$ end if - if( info/=0 ) then - call stdlib_xerbla( 'SLATPS', -info ) + if( info/=0_${ik}$ ) then + call stdlib${ii}$_xerbla( 'SLATPS', -info ) return end if ! quick return if possible if( n==0 )return ! determine machine dependent parameters to control overflow. - smlnum = stdlib_slamch( 'SAFE MINIMUM' ) / stdlib_slamch( 'PRECISION' ) + smlnum = stdlib${ii}$_slamch( 'SAFE MINIMUM' ) / stdlib${ii}$_slamch( 'PRECISION' ) bignum = one / smlnum scale = one if( stdlib_lsame( normin, 'N' ) ) then - ! compute the 1-norm of each column, not including the diagonal. + ! compute the 1_${ik}$-norm of each column, not including the diagonal. if( upper ) then ! a is upper triangular. - ip = 1 + ip = 1_${ik}$ do j = 1, n - cnorm( j ) = stdlib_sasum( j-1, ap( ip ), 1 ) + cnorm( j ) = stdlib${ii}$_sasum( j-1, ap( ip ), 1_${ik}$ ) ip = ip + j end do else ! a is lower triangular. - ip = 1 + ip = 1_${ik}$ do j = 1, n - 1 - cnorm( j ) = stdlib_sasum( n-j, ap( ip+1 ), 1 ) - ip = ip + n - j + 1 + cnorm( j ) = stdlib${ii}$_sasum( n-j, ap( ip+1 ), 1_${ik}$ ) + ip = ip + n - j + 1_${ik}$ end do cnorm( n ) = zero end if end if ! scale the column norms by tscal if the maximum element in cnorm is ! greater than bignum. - imax = stdlib_isamax( n, cnorm, 1 ) + imax = stdlib${ii}$_isamax( n, cnorm, 1_${ik}$ ) tmax = cnorm( imax ) if( tmax<=bignum ) then tscal = one else tscal = one / ( smlnum*tmax ) - call stdlib_sscal( n, tscal, cnorm, 1 ) + call stdlib${ii}$_sscal( n, tscal, cnorm, 1_${ik}$ ) end if ! compute a bound on the computed solution vector to see if the - ! level 2 blas routine stdlib_stpsv can be used. - j = stdlib_isamax( n, x, 1 ) + ! level 2_${ik}$ blas routine stdlib${ii}$_stpsv can be used. + j = stdlib${ii}$_isamax( n, x, 1_${ik}$ ) xmax = abs( x( j ) ) xbnd = xmax if( notran ) then ! compute the growth in a * x = b. if( upper ) then jfirst = n - jlast = 1 - jinc = -1 + jlast = 1_${ik}$ + jinc = -1_${ik}$ else - jfirst = 1 + jfirst = 1_${ik}$ jlast = n - jinc = 1 + jinc = 1_${ik}$ end if if( tscal/=one ) then grow = zero @@ -10156,11 +10158,11 @@ module stdlib_linalg_lapack_s end if if( nounit ) then ! a is non-unit triangular. - ! compute grow = 1/g(j) and xbnd = 1/m(j). - ! initially, g(0) = max{x(i), i=1,...,n}. + ! compute grow = 1_${ik}$/g(j) and xbnd = 1_${ik}$/m(j). + ! initially, g(0_${ik}$) = max{x(i), i=1_${ik}$,...,n}. grow = one / max( xbnd, smlnum ) xbnd = grow - ip = jfirst*( jfirst+1 ) / 2 + ip = jfirst*( jfirst+1 ) / 2_${ik}$ jlen = n do j = jfirst, jlast, jinc ! exit the loop if the growth factor is too small. @@ -10169,24 +10171,24 @@ module stdlib_linalg_lapack_s tjj = abs( ap( ip ) ) xbnd = min( xbnd, min( one, tjj )*grow ) if( tjj+cnorm( j )>=smlnum ) then - ! g(j) = g(j-1)*( 1 + cnorm(j) / abs(a(j,j)) ) + ! g(j) = g(j-1)*( 1_${ik}$ + cnorm(j) / abs(a(j,j)) ) grow = grow*( tjj / ( tjj+cnorm( j ) ) ) else ! g(j) could overflow, set grow to 0. grow = zero end if ip = ip + jinc*jlen - jlen = jlen - 1 + jlen = jlen - 1_${ik}$ end do grow = xbnd else ! a is unit triangular. - ! compute grow = 1/g(j), where g(0) = max{x(i), i=1,...,n}. + ! compute grow = 1_${ik}$/g(j), where g(0_${ik}$) = max{x(i), i=1_${ik}$,...,n}. grow = min( one, one / max( xbnd, smlnum ) ) do j = jfirst, jlast, jinc ! exit the loop if the growth factor is too small. if( grow<=smlnum )go to 50 - ! g(j) = g(j-1)*( 1 + cnorm(j) ) + ! g(j) = g(j-1)*( 1_${ik}$ + cnorm(j) ) grow = grow*( one / ( one+cnorm( j ) ) ) end do end if @@ -10194,13 +10196,13 @@ module stdlib_linalg_lapack_s else ! compute the growth in a**t * x = b. if( upper ) then - jfirst = 1 + jfirst = 1_${ik}$ jlast = n - jinc = 1 + jinc = 1_${ik}$ else jfirst = n - jlast = 1 - jinc = -1 + jlast = 1_${ik}$ + jinc = -1_${ik}$ end if if( tscal/=one ) then grow = zero @@ -10208,33 +10210,33 @@ module stdlib_linalg_lapack_s end if if( nounit ) then ! a is non-unit triangular. - ! compute grow = 1/g(j) and xbnd = 1/m(j). - ! initially, m(0) = max{x(i), i=1,...,n}. + ! compute grow = 1_${ik}$/g(j) and xbnd = 1_${ik}$/m(j). + ! initially, m(0_${ik}$) = max{x(i), i=1_${ik}$,...,n}. grow = one / max( xbnd, smlnum ) xbnd = grow - ip = jfirst*( jfirst+1 ) / 2 - jlen = 1 + ip = jfirst*( jfirst+1 ) / 2_${ik}$ + jlen = 1_${ik}$ do j = jfirst, jlast, jinc ! exit the loop if the growth factor is too small. if( grow<=smlnum )go to 80 - ! g(j) = max( g(j-1), m(j-1)*( 1 + cnorm(j) ) ) + ! g(j) = max( g(j-1), m(j-1)*( 1_${ik}$ + cnorm(j) ) ) xj = one + cnorm( j ) grow = min( grow, xbnd / xj ) - ! m(j) = m(j-1)*( 1 + cnorm(j) ) / abs(a(j,j)) + ! m(j) = m(j-1)*( 1_${ik}$ + cnorm(j) ) / abs(a(j,j)) tjj = abs( ap( ip ) ) if( xj>tjj )xbnd = xbnd*( tjj / xj ) - jlen = jlen + 1 + jlen = jlen + 1_${ik}$ ip = ip + jinc*jlen end do grow = min( grow, xbnd ) else ! a is unit triangular. - ! compute grow = 1/g(j), where g(0) = max{x(i), i=1,...,n}. + ! compute grow = 1_${ik}$/g(j), where g(0_${ik}$) = max{x(i), i=1_${ik}$,...,n}. grow = min( one, one / max( xbnd, smlnum ) ) do j = jfirst, jlast, jinc ! exit the loop if the growth factor is too small. if( grow<=smlnum )go to 80 - ! g(j) = ( 1 + cnorm(j) )*g(j-1) + ! g(j) = ( 1_${ik}$ + cnorm(j) )*g(j-1) xj = one + cnorm( j ) grow = grow / xj end do @@ -10242,21 +10244,21 @@ module stdlib_linalg_lapack_s 80 continue end if if( ( grow*tscal )>smlnum ) then - ! use the level 2 blas solve if the reciprocal of the bound on + ! use the level 2_${ik}$ blas solve if the reciprocal of the bound on ! elements of x is not too small. - call stdlib_stpsv( uplo, trans, diag, n, ap, x, 1 ) + call stdlib${ii}$_stpsv( uplo, trans, diag, n, ap, x, 1_${ik}$ ) else - ! use a level 1 blas solve, scaling intermediate results. + ! use a level 1_${ik}$ 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_sscal( n, scale, x, 1 ) + call stdlib${ii}$_sscal( n, scale, x, 1_${ik}$ ) xmax = bignum end if if( notran ) then ! solve a * x = b - ip = jfirst*( jfirst+1 ) / 2 + ip = jfirst*( jfirst+1 ) / 2_${ik}$ loop_100: do j = jfirst, jlast, jinc ! compute x(j) = b(j) / a(j,j), scaling x if necessary. xj = abs( x( j ) ) @@ -10271,9 +10273,9 @@ module stdlib_linalg_lapack_s ! abs(a(j,j)) > smlnum: if( tjjtjj*bignum ) then - ! scale x by 1/b(j). + ! scale x by 1_${ik}$/b(j). rec = one / xj - call stdlib_sscal( n, rec, x, 1 ) + call stdlib${ii}$_sscal( n, rec, x, 1_${ik}$ ) scale = scale*rec xmax = xmax*rec end if @@ -10281,25 +10283,25 @@ module stdlib_linalg_lapack_s x( j ) = x( j ) / tjjs xj = abs( x( j ) ) else if( tjj>zero ) then - ! 0 < abs(a(j,j)) <= smlnum: + ! 0_${ik}$ < abs(a(j,j)) <= smlnum: if( xj>tjj*bignum ) then - ! scale x by (1/abs(x(j)))*abs(a(j,j))*bignum + ! scale x by (1_${ik}$/abs(x(j)))*abs(a(j,j))*bignum ! to avoid overflow when dividing by a(j,j). rec = ( tjj*bignum ) / xj if( cnorm( j )>one ) then - ! scale by 1/cnorm(j) to avoid overflow when + ! scale by 1_${ik}$/cnorm(j) to avoid overflow when ! multiplying x(j) times column j. rec = rec / cnorm( j ) end if - call stdlib_sscal( n, rec, x, 1 ) + call stdlib${ii}$_sscal( n, rec, x, 1_${ik}$ ) scale = scale*rec xmax = xmax*rec end if x( j ) = x( j ) / tjjs xj = abs( x( j ) ) else - ! a(j,j) = 0: set x(1:n) = 0, x(j) = 1, and - ! scale = 0, and compute a solution to a*x = 0. + ! a(j,j) = 0_${ik}$: set x(1_${ik}$:n) = 0_${ik}$, x(j) = 1_${ik}$, and + ! scale = 0_${ik}$, and compute a solution to a*x = 0. do i = 1, n x( i ) = zero end do @@ -10314,22 +10316,22 @@ module stdlib_linalg_lapack_s if( xj>one ) then rec = one / xj if( cnorm( j )>( bignum-xmax )*rec ) then - ! scale x by 1/(2*abs(x(j))). + ! scale x by 1_${ik}$/(2_${ik}$*abs(x(j))). rec = rec*half - call stdlib_sscal( n, rec, x, 1 ) + call stdlib${ii}$_sscal( n, rec, x, 1_${ik}$ ) scale = scale*rec end if else if( xj*cnorm( j )>( bignum-xmax ) ) then - ! scale x by 1/2. - call stdlib_sscal( n, half, x, 1 ) + ! scale x by 1_${ik}$/2. + call stdlib${ii}$_sscal( n, half, x, 1_${ik}$ ) scale = scale*half end if if( upper ) then - if( j>1 ) then + if( j>1_${ik}$ ) then ! compute the update - ! x(1:j-1) := x(1:j-1) - x(j) * a(1:j-1,j) - call stdlib_saxpy( j-1, -x( j )*tscal, ap( ip-j+1 ), 1, x,1 ) - i = stdlib_isamax( j-1, x, 1 ) + ! x(1_${ik}$:j-1) := x(1_${ik}$:j-1) - x(j) * a(1_${ik}$:j-1,j) + call stdlib${ii}$_saxpy( j-1, -x( j )*tscal, ap( ip-j+1 ), 1_${ik}$, x,1_${ik}$ ) + i = stdlib${ii}$_isamax( j-1, x, 1_${ik}$ ) xmax = abs( x( i ) ) end if ip = ip - j @@ -10337,18 +10339,18 @@ module stdlib_linalg_lapack_s if( jj @@ -10356,7 +10358,7 @@ module stdlib_linalg_lapack_s uscal = tscal rec = one / max( xmax, one ) if( cnorm( j )>( bignum-xj )*rec ) then - ! if x(j) could overflow, scale x by 1/(2*xmax). + ! if x(j) could overflow, scale x by 1_${ik}$/(2_${ik}$*xmax). rec = rec*half if( nounit ) then tjjs = ap( ip )*tscal @@ -10370,19 +10372,19 @@ module stdlib_linalg_lapack_s uscal = uscal / tjjs end if if( rec smlnum: if( tjjtjj*bignum ) then - ! scale x by 1/abs(x(j)). + ! scale x by 1_${ik}$/abs(x(j)). rec = one / xj - call stdlib_sscal( n, rec, x, 1 ) + call stdlib${ii}$_sscal( n, rec, x, 1_${ik}$ ) scale = scale*rec xmax = xmax*rec end if end if x( j ) = x( j ) / tjjs else if( tjj>zero ) then - ! 0 < abs(a(j,j)) <= smlnum: + ! 0_${ik}$ < abs(a(j,j)) <= smlnum: if( xj>tjj*bignum ) then - ! scale x by (1/abs(x(j)))*abs(a(j,j))*bignum. + ! scale x by (1_${ik}$/abs(x(j)))*abs(a(j,j))*bignum. rec = ( tjj*bignum ) / xj - call stdlib_sscal( n, rec, x, 1 ) + call stdlib${ii}$_sscal( n, rec, x, 1_${ik}$ ) scale = scale*rec xmax = xmax*rec end if x( j ) = 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. + ! a(j,j) = 0_${ik}$: set x(1_${ik}$:n) = 0_${ik}$, x(j) = 1_${ik}$, and + ! scale = 0_${ik}$, and compute a solution to a**t*x = 0. do i = 1, n x( i ) = zero end do @@ -10444,11 +10446,11 @@ module stdlib_linalg_lapack_s 135 continue else ! compute x(j) := x(j) / a(j,j) - sumj if the dot - ! product has already been divided by 1/a(j,j). + ! product has already been divided by 1_${ik}$/a(j,j). x( j ) = x( j ) / tjjs - sumj end if xmax = max( xmax, abs( x( j ) ) ) - jlen = jlen + 1 + jlen = jlen + 1_${ik}$ ip = ip + jinc*jlen end do loop_140 end if @@ -10456,31 +10458,31 @@ module stdlib_linalg_lapack_s end if ! scale the column norms by 1/tscal for return. if( tscal/=one ) then - call stdlib_sscal( n, one / tscal, cnorm, 1 ) + call stdlib${ii}$_sscal( n, one / tscal, cnorm, 1_${ik}$ ) end if return - end subroutine stdlib_slatps + end subroutine stdlib${ii}$_slatps - pure subroutine stdlib_slatrs( uplo, trans, diag, normin, n, a, lda, x, scale,cnorm, info ) + pure subroutine stdlib${ii}$_slatrs( uplo, trans, diag, normin, n, a, lda, x, scale,cnorm, info ) !! SLATRS solves one of the triangular systems !! A *x = s*b or A**T*x = s*b !! with scaling to prevent overflow. Here A is an upper or lower !! triangular matrix, A**T denotes the transpose of A, x and b are !! n-element vectors, and s is a scaling factor, usually less than - !! or equal to 1, chosen so that the components of x will be less than + !! or equal to 1_${ik}$, chosen so that the components of x will be less than !! the overflow threshold. If the unscaled problem will not cause - !! overflow, the Level 2 BLAS routine STRSV is called. If the matrix A - !! is singular (A(j,j) = 0 for some j), then s is set to 0 and a - !! non-trivial solution to A*x = 0 is returned. + !! overflow, the Level 2_${ik}$ BLAS routine STRSV is called. If the matrix A + !! is singular (A(j,j) = 0_${ik}$ for some j), then s is set to 0_${ik}$ and a + !! non-trivial solution to A*x = 0_${ik}$ is returned. ! -- 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 character, intent(in) :: diag, normin, trans, uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda, n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, n real(sp), intent(out) :: scale ! Array Arguments real(sp), intent(in) :: a(lda,*) @@ -10489,82 +10491,82 @@ module stdlib_linalg_lapack_s ! Local Scalars logical(lk) :: notran, nounit, upper - integer(ilp) :: i, imax, j, jfirst, jinc, jlast + integer(${ik}$) :: i, imax, j, jfirst, jinc, jlast real(sp) :: bignum, grow, rec, smlnum, sumj, tjj, tjjs, tmax, tscal, uscal, xbnd, xj, & xmax ! Intrinsic Functions intrinsic :: abs,max,min ! Executable Statements - info = 0 + info = 0_${ik}$ upper = stdlib_lsame( uplo, 'U' ) notran = stdlib_lsame( trans, 'N' ) nounit = stdlib_lsame( diag, 'N' ) ! test the input parameters. if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then - info = -1 + info = -1_${ik}$ else if( .not.notran .and. .not.stdlib_lsame( trans, 'T' ) .and. .not.stdlib_lsame( & trans, 'C' ) ) then - info = -2 + info = -2_${ik}$ else if( .not.nounit .and. .not.stdlib_lsame( diag, 'U' ) ) then - info = -3 + info = -3_${ik}$ else if( .not.stdlib_lsame( normin, 'Y' ) .and. .not.stdlib_lsame( normin, 'N' ) ) & then - info = -4 - else if( n<0 ) then - info = -5 - else if( lda=smlnum ) then - ! g(j) = g(j-1)*( 1 + cnorm(j) / abs(a(j,j)) ) + ! g(j) = g(j-1)*( 1_${ik}$ + cnorm(j) / abs(a(j,j)) ) grow = grow*( tjj / ( tjj+cnorm( j ) ) ) else ! g(j) could overflow, set grow to 0. @@ -10593,12 +10595,12 @@ module stdlib_linalg_lapack_s grow = xbnd else ! a is unit triangular. - ! compute grow = 1/g(j), where g(0) = max{x(i), i=1,...,n}. + ! compute grow = 1_${ik}$/g(j), where g(0_${ik}$) = max{x(i), i=1_${ik}$,...,n}. grow = min( one, one / max( xbnd, smlnum ) ) do j = jfirst, jlast, jinc ! exit the loop if the growth factor is too small. if( grow<=smlnum )go to 50 - ! g(j) = g(j-1)*( 1 + cnorm(j) ) + ! g(j) = g(j-1)*( 1_${ik}$ + cnorm(j) ) grow = grow*( one / ( one+cnorm( j ) ) ) end do end if @@ -10606,13 +10608,13 @@ module stdlib_linalg_lapack_s else ! compute the growth in a**t * x = b. if( upper ) then - jfirst = 1 + jfirst = 1_${ik}$ jlast = n - jinc = 1 + jinc = 1_${ik}$ else jfirst = n - jlast = 1 - jinc = -1 + jlast = 1_${ik}$ + jinc = -1_${ik}$ end if if( tscal/=one ) then grow = zero @@ -10620,29 +10622,29 @@ module stdlib_linalg_lapack_s end if if( nounit ) then ! a is non-unit triangular. - ! compute grow = 1/g(j) and xbnd = 1/m(j). - ! initially, m(0) = max{x(i), i=1,...,n}. + ! compute grow = 1_${ik}$/g(j) and xbnd = 1_${ik}$/m(j). + ! initially, m(0_${ik}$) = max{x(i), i=1_${ik}$,...,n}. grow = one / max( xbnd, smlnum ) xbnd = grow do j = jfirst, jlast, jinc ! exit the loop if the growth factor is too small. if( grow<=smlnum )go to 80 - ! g(j) = max( g(j-1), m(j-1)*( 1 + cnorm(j) ) ) + ! g(j) = max( g(j-1), m(j-1)*( 1_${ik}$ + cnorm(j) ) ) xj = one + cnorm( j ) grow = min( grow, xbnd / xj ) - ! m(j) = m(j-1)*( 1 + cnorm(j) ) / abs(a(j,j)) + ! m(j) = m(j-1)*( 1_${ik}$ + cnorm(j) ) / abs(a(j,j)) tjj = abs( a( j, j ) ) if( xj>tjj )xbnd = xbnd*( tjj / xj ) end do grow = min( grow, xbnd ) else ! a is unit triangular. - ! compute grow = 1/g(j), where g(0) = max{x(i), i=1,...,n}. + ! compute grow = 1_${ik}$/g(j), where g(0_${ik}$) = max{x(i), i=1_${ik}$,...,n}. grow = min( one, one / max( xbnd, smlnum ) ) do j = jfirst, jlast, jinc ! exit the loop if the growth factor is too small. if( grow<=smlnum )go to 80 - ! g(j) = ( 1 + cnorm(j) )*g(j-1) + ! g(j) = ( 1_${ik}$ + cnorm(j) )*g(j-1) xj = one + cnorm( j ) grow = grow / xj end do @@ -10650,16 +10652,16 @@ module stdlib_linalg_lapack_s 80 continue end if if( ( grow*tscal )>smlnum ) then - ! use the level 2 blas solve if the reciprocal of the bound on + ! use the level 2_${ik}$ blas solve if the reciprocal of the bound on ! elements of x is not too small. - call stdlib_strsv( uplo, trans, diag, n, a, lda, x, 1 ) + call stdlib${ii}$_strsv( uplo, trans, diag, n, a, lda, x, 1_${ik}$ ) else - ! use a level 1 blas solve, scaling intermediate results. + ! use a level 1_${ik}$ 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_sscal( n, scale, x, 1 ) + call stdlib${ii}$_sscal( n, scale, x, 1_${ik}$ ) xmax = bignum end if if( notran ) then @@ -10678,9 +10680,9 @@ module stdlib_linalg_lapack_s ! abs(a(j,j)) > smlnum: if( tjjtjj*bignum ) then - ! scale x by 1/b(j). + ! scale x by 1_${ik}$/b(j). rec = one / xj - call stdlib_sscal( n, rec, x, 1 ) + call stdlib${ii}$_sscal( n, rec, x, 1_${ik}$ ) scale = scale*rec xmax = xmax*rec end if @@ -10688,25 +10690,25 @@ module stdlib_linalg_lapack_s x( j ) = x( j ) / tjjs xj = abs( x( j ) ) else if( tjj>zero ) then - ! 0 < abs(a(j,j)) <= smlnum: + ! 0_${ik}$ < abs(a(j,j)) <= smlnum: if( xj>tjj*bignum ) then - ! scale x by (1/abs(x(j)))*abs(a(j,j))*bignum + ! scale x by (1_${ik}$/abs(x(j)))*abs(a(j,j))*bignum ! to avoid overflow when dividing by a(j,j). rec = ( tjj*bignum ) / xj if( cnorm( j )>one ) then - ! scale by 1/cnorm(j) to avoid overflow when + ! scale by 1_${ik}$/cnorm(j) to avoid overflow when ! multiplying x(j) times column j. rec = rec / cnorm( j ) end if - call stdlib_sscal( n, rec, x, 1 ) + call stdlib${ii}$_sscal( n, rec, x, 1_${ik}$ ) scale = scale*rec xmax = xmax*rec end if x( j ) = x( j ) / tjjs xj = abs( x( j ) ) else - ! a(j,j) = 0: set x(1:n) = 0, x(j) = 1, and - ! scale = 0, and compute a solution to a*x = 0. + ! a(j,j) = 0_${ik}$: set x(1_${ik}$:n) = 0_${ik}$, x(j) = 1_${ik}$, and + ! scale = 0_${ik}$, and compute a solution to a*x = 0. do i = 1, n x( i ) = zero end do @@ -10721,31 +10723,31 @@ module stdlib_linalg_lapack_s if( xj>one ) then rec = one / xj if( cnorm( j )>( bignum-xmax )*rec ) then - ! scale x by 1/(2*abs(x(j))). + ! scale x by 1_${ik}$/(2_${ik}$*abs(x(j))). rec = rec*half - call stdlib_sscal( n, rec, x, 1 ) + call stdlib${ii}$_sscal( n, rec, x, 1_${ik}$ ) scale = scale*rec end if else if( xj*cnorm( j )>( bignum-xmax ) ) then - ! scale x by 1/2. - call stdlib_sscal( n, half, x, 1 ) + ! scale x by 1_${ik}$/2. + call stdlib${ii}$_sscal( n, half, x, 1_${ik}$ ) scale = scale*half end if if( upper ) then - if( j>1 ) then + if( j>1_${ik}$ ) then ! compute the update - ! x(1:j-1) := x(1:j-1) - x(j) * a(1:j-1,j) - call stdlib_saxpy( j-1, -x( j )*tscal, a( 1, j ), 1, x,1 ) - i = stdlib_isamax( j-1, x, 1 ) + ! x(1_${ik}$:j-1) := x(1_${ik}$:j-1) - x(j) * a(1_${ik}$:j-1,j) + call stdlib${ii}$_saxpy( j-1, -x( j )*tscal, a( 1_${ik}$, j ), 1_${ik}$, x,1_${ik}$ ) + i = stdlib${ii}$_isamax( j-1, x, 1_${ik}$ ) xmax = abs( x( i ) ) end if else if( j( bignum-xj )*rec ) then - ! if x(j) could overflow, scale x by 1/(2*xmax). + ! if x(j) could overflow, scale x by 1_${ik}$/(2_${ik}$*xmax). rec = rec*half if( nounit ) then tjjs = a( j, j )*tscal @@ -10773,19 +10775,19 @@ module stdlib_linalg_lapack_s uscal = uscal / tjjs end if if( rec smlnum: if( tjjtjj*bignum ) then - ! scale x by 1/abs(x(j)). + ! scale x by 1_${ik}$/abs(x(j)). rec = one / xj - call stdlib_sscal( n, rec, x, 1 ) + call stdlib${ii}$_sscal( n, rec, x, 1_${ik}$ ) scale = scale*rec xmax = xmax*rec end if end if x( j ) = x( j ) / tjjs else if( tjj>zero ) then - ! 0 < abs(a(j,j)) <= smlnum: + ! 0_${ik}$ < abs(a(j,j)) <= smlnum: if( xj>tjj*bignum ) then - ! scale x by (1/abs(x(j)))*abs(a(j,j))*bignum. + ! scale x by (1_${ik}$/abs(x(j)))*abs(a(j,j))*bignum. rec = ( tjj*bignum ) / xj - call stdlib_sscal( n, rec, x, 1 ) + call stdlib${ii}$_sscal( n, rec, x, 1_${ik}$ ) scale = scale*rec xmax = xmax*rec end if x( j ) = 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. + ! a(j,j) = 0_${ik}$: set x(1_${ik}$:n) = 0_${ik}$, x(j) = 1_${ik}$, and + ! scale = 0_${ik}$, and compute a solution to a**t*x = 0. do i = 1, n x( i ) = zero end do @@ -10847,7 +10849,7 @@ module stdlib_linalg_lapack_s 135 continue else ! compute x(j) := x(j) / a(j,j) - sumj if the dot - ! product has already been divided by 1/a(j,j). + ! product has already been divided by 1_${ik}$/a(j,j). x( j ) = x( j ) / tjjs - sumj end if xmax = max( xmax, abs( x( j ) ) ) @@ -10857,13 +10859,13 @@ module stdlib_linalg_lapack_s end if ! scale the column norms by 1/tscal for return. if( tscal/=one ) then - call stdlib_sscal( n, one / tscal, cnorm, 1 ) + call stdlib${ii}$_sscal( n, one / tscal, cnorm, 1_${ik}$ ) end if return - end subroutine stdlib_slatrs + end subroutine stdlib${ii}$_slatrs - pure subroutine stdlib_slauu2( uplo, n, a, lda, info ) + pure subroutine stdlib${ii}$_slauu2( uplo, n, a, lda, info ) !! SLAUU2 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. @@ -10871,37 +10873,37 @@ module stdlib_linalg_lapack_s !! overwriting the factor U in A. !! If UPLO = 'L' or 'l' then the lower triangle of the result is stored, !! overwriting the factor L in A. - !! This is the unblocked form of the algorithm, calling Level 2 BLAS. + !! This is the unblocked form of the algorithm, calling Level 2_${ik}$ BLAS. ! -- 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 character, intent(in) :: uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda, n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, n ! Array Arguments real(sp), intent(inout) :: a(lda,*) ! ===================================================================== ! Local Scalars logical(lk) :: upper - integer(ilp) :: i + integer(${ik}$) :: i real(sp) :: aii ! Intrinsic Functions intrinsic :: max ! Executable Statements ! test the input parameters. - info = 0 + info = 0_${ik}$ upper = stdlib_lsame( uplo, 'U' ) if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then - info = -1 - else if( n<0 ) then - info = -2 - else if( lda=n ) then + nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'SLAUUM', uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ ) + if( nb<=1_${ik}$ .or. nb>=n ) then ! use unblocked code - call stdlib_slauu2( uplo, n, a, lda, info ) + call stdlib${ii}$_slauu2( 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_strmm( 'RIGHT', 'UPPER', 'TRANSPOSE', 'NON-UNIT',i-1, ib, one, a( & - i, i ), lda, a( 1, i ),lda ) - call stdlib_slauu2( 'UPPER', ib, a( i, i ), lda, info ) + call stdlib${ii}$_strmm( 'RIGHT', 'UPPER', 'TRANSPOSE', 'NON-UNIT',i-1, ib, one, a( & + i, i ), lda, a( 1_${ik}$, i ),lda ) + call stdlib${ii}$_slauu2( 'UPPER', ib, a( i, i ), lda, info ) if( i+ib<=n ) then - call stdlib_sgemm( '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_ssyrk( 'UPPER', 'NO TRANSPOSE', ib, n-i-ib+1,one, a( i, i+ib ),& + call stdlib${ii}$_sgemm( 'NO TRANSPOSE', 'TRANSPOSE', i-1, ib,n-i-ib+1, one, a( & + 1_${ik}$, i+ib ), lda,a( i, i+ib ), lda, one, a( 1_${ik}$, i ), lda ) + call stdlib${ii}$_ssyrk( 'UPPER', 'NO TRANSPOSE', ib, n-i-ib+1,one, a( i, i+ib ),& lda, one, a( i, i ),lda ) end if end do @@ -11002,23 +11004,23 @@ module stdlib_linalg_lapack_s ! compute the product l**t * l. do i = 1, n, nb ib = min( nb, n-i+1 ) - call stdlib_strmm( 'LEFT', 'LOWER', 'TRANSPOSE', 'NON-UNIT', ib,i-1, one, a( & - i, i ), lda, a( i, 1 ), lda ) - call stdlib_slauu2( 'LOWER', ib, a( i, i ), lda, info ) + call stdlib${ii}$_strmm( 'LEFT', 'LOWER', 'TRANSPOSE', 'NON-UNIT', ib,i-1, one, a( & + i, i ), lda, a( i, 1_${ik}$ ), lda ) + call stdlib${ii}$_slauu2( 'LOWER', ib, a( i, i ), lda, info ) if( i+ib<=n ) then - call stdlib_sgemm( '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_ssyrk( 'LOWER', 'TRANSPOSE', ib, n-i-ib+1, one,a( i+ib, i ), & + call stdlib${ii}$_sgemm( 'TRANSPOSE', 'NO TRANSPOSE', ib, i-1,n-i-ib+1, one, a( & + i+ib, i ), lda,a( i+ib, 1_${ik}$ ), lda, one, a( i, 1_${ik}$ ), lda ) + call stdlib${ii}$_ssyrk( '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_slauum + end subroutine stdlib${ii}$_slauum - pure subroutine stdlib_sorbdb6( m1, m2, n, x1, incx1, x2, incx2, q1, ldq1, q2,ldq2, work, & + pure subroutine stdlib${ii}$_sorbdb6( m1, m2, n, x1, incx1, x2, incx2, q1, ldq1, q2,ldq2, work, & !! SORBDB6 orthogonalizes the column vector !! X = [ X1 ] !! [ X2 ] @@ -11033,8 +11035,8 @@ module stdlib_linalg_lapack_s ! -- 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) :: incx1, incx2, ldq1, ldq2, lwork, m1, m2, n - integer(ilp), intent(out) :: info + integer(${ik}$), intent(in) :: incx1, incx2, ldq1, ldq2, lwork, m1, m2, n + integer(${ik}$), intent(out) :: info ! Array Arguments real(sp), intent(in) :: q1(ldq1,*), q2(ldq2,*) real(sp), intent(out) :: work(*) @@ -11047,60 +11049,60 @@ module stdlib_linalg_lapack_s ! Local Scalars - integer(ilp) :: i + integer(${ik}$) :: i real(sp) :: normsq1, normsq2, scl1, scl2, ssq1, ssq2 ! Intrinsic Function intrinsic :: max ! Executable Statements ! test input arguments - info = 0 - if( m1 < 0 ) then - info = -1 - else if( m2 < 0 ) then - info = -2 - else if( n < 0 ) then - info = -3 - else if( incx1 < 1 ) then - info = -5 - else if( incx2 < 1 ) then - info = -7 - else if( ldq1 < max( 1, m1 ) ) then - info = -9 - else if( ldq2 < max( 1, m2 ) ) then - info = -11 + info = 0_${ik}$ + if( m1 < 0_${ik}$ ) then + info = -1_${ik}$ + else if( m2 < 0_${ik}$ ) then + info = -2_${ik}$ + else if( n < 0_${ik}$ ) then + info = -3_${ik}$ + else if( incx1 < 1_${ik}$ ) then + info = -5_${ik}$ + else if( incx2 < 1_${ik}$ ) then + info = -7_${ik}$ + else if( ldq1 < max( 1_${ik}$, m1 ) ) then + info = -9_${ik}$ + else if( ldq2 < max( 1_${ik}$, m2 ) ) then + info = -11_${ik}$ else if( lwork < n ) then - info = -13 + info = -13_${ik}$ end if - if( info /= 0 ) then - call stdlib_xerbla( 'SORBDB6', -info ) + if( info /= 0_${ik}$ ) then + call stdlib${ii}$_xerbla( 'SORBDB6', -info ) return end if ! first, project x onto the orthogonal complement of q's column ! space scl1 = realzero ssq1 = realone - call stdlib_slassq( m1, x1, incx1, scl1, ssq1 ) + call stdlib${ii}$_slassq( m1, x1, incx1, scl1, ssq1 ) scl2 = realzero ssq2 = realone - call stdlib_slassq( m2, x2, incx2, scl2, ssq2 ) - normsq1 = scl1**2*ssq1 + scl2**2*ssq2 - if( m1 == 0 ) then + call stdlib${ii}$_slassq( m2, x2, incx2, scl2, ssq2 ) + normsq1 = scl1**2_${ik}$*ssq1 + scl2**2_${ik}$*ssq2 + if( m1 == 0_${ik}$ ) then do i = 1, n work(i) = zero end do else - call stdlib_sgemv( 'C', m1, n, one, q1, ldq1, x1, incx1, zero, work,1 ) + call stdlib${ii}$_sgemv( 'C', m1, n, one, q1, ldq1, x1, incx1, zero, work,1_${ik}$ ) end if - call stdlib_sgemv( 'C', m2, n, one, q2, ldq2, x2, incx2, one, work, 1 ) - call stdlib_sgemv( 'N', m1, n, negone, q1, ldq1, work, 1, one, x1,incx1 ) - call stdlib_sgemv( 'N', m2, n, negone, q2, ldq2, work, 1, one, x2,incx2 ) + call stdlib${ii}$_sgemv( 'C', m2, n, one, q2, ldq2, x2, incx2, one, work, 1_${ik}$ ) + call stdlib${ii}$_sgemv( 'N', m1, n, negone, q1, ldq1, work, 1_${ik}$, one, x1,incx1 ) + call stdlib${ii}$_sgemv( 'N', m2, n, negone, q2, ldq2, work, 1_${ik}$, one, x2,incx2 ) scl1 = realzero ssq1 = realone - call stdlib_slassq( m1, x1, incx1, scl1, ssq1 ) + call stdlib${ii}$_slassq( m1, x1, incx1, scl1, ssq1 ) scl2 = realzero ssq2 = realone - call stdlib_slassq( m2, x2, incx2, scl2, ssq2 ) - normsq2 = scl1**2*ssq1 + scl2**2*ssq2 + call stdlib${ii}$_slassq( m2, x2, incx2, scl2, ssq2 ) + normsq2 = scl1**2_${ik}$*ssq1 + scl2**2_${ik}$*ssq2 ! if projection is sufficiently large in norm, then stop. ! if projection is zero, then stop. ! otherwise, project again. @@ -11114,23 +11116,23 @@ module stdlib_linalg_lapack_s do i = 1, n work(i) = zero end do - if( m1 == 0 ) then + if( m1 == 0_${ik}$ ) then do i = 1, n work(i) = zero end do else - call stdlib_sgemv( 'C', m1, n, one, q1, ldq1, x1, incx1, zero, work,1 ) + call stdlib${ii}$_sgemv( 'C', m1, n, one, q1, ldq1, x1, incx1, zero, work,1_${ik}$ ) end if - call stdlib_sgemv( 'C', m2, n, one, q2, ldq2, x2, incx2, one, work, 1 ) - call stdlib_sgemv( 'N', m1, n, negone, q1, ldq1, work, 1, one, x1,incx1 ) - call stdlib_sgemv( 'N', m2, n, negone, q2, ldq2, work, 1, one, x2,incx2 ) + call stdlib${ii}$_sgemv( 'C', m2, n, one, q2, ldq2, x2, incx2, one, work, 1_${ik}$ ) + call stdlib${ii}$_sgemv( 'N', m1, n, negone, q1, ldq1, work, 1_${ik}$, one, x1,incx1 ) + call stdlib${ii}$_sgemv( 'N', m2, n, negone, q2, ldq2, work, 1_${ik}$, one, x2,incx2 ) scl1 = realzero ssq1 = realone - call stdlib_slassq( m1, x1, incx1, scl1, ssq1 ) + call stdlib${ii}$_slassq( m1, x1, incx1, scl1, ssq1 ) scl2 = realzero ssq2 = realone - call stdlib_slassq( m1, x1, incx1, scl1, ssq1 ) - normsq2 = scl1**2*ssq1 + scl2**2*ssq2 + call stdlib${ii}$_slassq( m1, x1, incx1, scl1, ssq1 ) + normsq2 = scl1**2_${ik}$*ssq1 + scl2**2_${ik}$*ssq2 ! if second projection is sufficiently large in norm, then do ! nothing more. alternatively, if it shrunk significantly, then ! truncate it to zero. @@ -11143,21 +11145,21 @@ module stdlib_linalg_lapack_s end do end if return - end subroutine stdlib_sorbdb6 + end subroutine stdlib${ii}$_sorbdb6 - pure subroutine stdlib_sorg2l( m, n, k, a, lda, tau, work, info ) + pure subroutine stdlib${ii}$_sorg2l( m, n, k, a, lda, tau, work, info ) !! SORG2L 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 - !! Q = H(k) . . . H(2) H(1) + !! Q = H(k) . . . H(2_${ik}$) H(1_${ik}$) !! as returned by SGEQLF. ! -- 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 - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: k, lda, m, n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: k, lda, m, n ! Array Arguments real(sp), intent(inout) :: a(lda,*) real(sp), intent(in) :: tau(*) @@ -11165,28 +11167,28 @@ module stdlib_linalg_lapack_s ! ===================================================================== ! Local Scalars - integer(ilp) :: i, ii, j, l + integer(${ik}$) :: i, ii, j, l ! Intrinsic Functions intrinsic :: max ! Executable Statements ! test the input arguments - info = 0 - if( m<0 ) then - info = -1 - else if( n<0 .or. n>m ) then - info = -2 - else if( k<0 .or. k>n ) then - info = -3 - else if( ldam ) then + info = -2_${ik}$ + else if( k<0_${ik}$ .or. k>n ) then + info = -3_${ik}$ + else if( ldam ) then - info = -2 - else if( k<0 .or. k>n ) then - info = -3 - else if( ldam ) then + info = -2_${ik}$ + else if( k<0_${ik}$ .or. k>n ) then + info = -3_${ik}$ + else if( ldam ) then - info = -3 - else if( ldam ) then + info = -3_${ik}$ + else if( ldam ) then - info = -3 - else if( ldam ) then + info = -3_${ik}$ + else if( lda1 .and. nb1_${ik}$ .and. nb0 ) then + if( kk>0_${ik}$ ) then ! use blocked code do i = ki + 1, 1, -nb ib = min( nb, k-i+1 ) 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_slarft( 'FORWARD', 'ROWWISE', n-i+1, ib, a( i, i ),lda, tau( i ), & + call stdlib${ii}$_slarft( '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_slarfb( '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 ) + call stdlib${ii}$_slarfb( 'RIGHT', 'TRANSPOSE', 'FORWARD', 'ROWWISE',m-i-ib+1, n-i+& + 1_${ik}$, 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_sorgl2( ib, n-i+1, ib, a( i, i ), lda, tau( i ), work,iinfo ) - ! set columns 1:i-1 of current block to zero + call stdlib${ii}$_sorgl2( ib, n-i+1, ib, a( i, i ), lda, tau( i ), work,iinfo ) + ! set columns 1_${ik}$:i-1 of current block to zero do j = 1, i - 1 do l = i, i + ib - 1 a( l, j ) = zero @@ -11455,23 +11457,23 @@ module stdlib_linalg_lapack_s end do end do end if - work( 1 ) = iws + work( 1_${ik}$ ) = iws return - end subroutine stdlib_sorglq + end subroutine stdlib${ii}$_sorglq - pure subroutine stdlib_sorgql( m, n, k, a, lda, tau, work, lwork, info ) + pure subroutine stdlib${ii}$_sorgql( m, n, k, a, lda, tau, work, lwork, info ) !! SORGQL 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 - !! Q = H(k) . . . H(2) H(1) + !! Q = H(k) . . . H(2_${ik}$) H(1_${ik}$) !! as returned by SGEQLF. ! -- 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 - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: k, lda, lwork, m, n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: k, lda, lwork, m, n ! Array Arguments real(sp), intent(inout) :: a(lda,*) real(sp), intent(in) :: tau(*) @@ -11480,50 +11482,50 @@ module stdlib_linalg_lapack_s ! Local Scalars logical(lk) :: lquery - integer(ilp) :: i, ib, iinfo, iws, j, kk, l, ldwork, lwkopt, nb, nbmin, nx + integer(${ik}$) :: i, ib, iinfo, iws, j, kk, l, ldwork, lwkopt, nb, nbmin, nx ! Intrinsic Functions intrinsic :: max,min ! Executable Statements ! test the input arguments - info = 0 - lquery = ( lwork==-1 ) - if( m<0 ) then - info = -1 - else if( n<0 .or. n>m ) then - info = -2 - else if( k<0 .or. k>n ) then - info = -3 - else if( ldam ) then + info = -2_${ik}$ + else if( k<0_${ik}$ .or. k>n ) then + info = -3_${ik}$ + else if( lda1 .and. nb1_${ik}$ .and. nb0 ) then + call stdlib${ii}$_sorg2l( m-kk, n-kk, k-kk, a, lda, tau, work, iinfo ) + if( kk>0_${ik}$ ) then ! use blocked code do i = k - kk + 1, k, nb ib = min( nb, k-i+1 ) - if( n-k+i>1 ) then + if( n-k+i>1_${ik}$ ) then ! form the triangular factor of the block reflector ! h = h(i+ib-1) . . . h(i+1) h(i) - call stdlib_slarft( 'BACKWARD', 'COLUMNWISE', m-k+i+ib-1, ib,a( 1, n-k+i ), & + call stdlib${ii}$_slarft( 'BACKWARD', 'COLUMNWISE', m-k+i+ib-1, ib,a( 1_${ik}$, 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_slarfb( '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 ) + ! apply h to a(1_${ik}$:m-k+i+ib-1,1_${ik}$:n-k+i-1) from the left + call stdlib${ii}$_slarfb( 'LEFT', 'NO TRANSPOSE', 'BACKWARD','COLUMNWISE', m-k+i+ib-& + 1_${ik}$, n-k+i-1, ib,a( 1_${ik}$, 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_sorg2l( m-k+i+ib-1, ib, ib, a( 1, n-k+i ), lda,tau( i ), work, iinfo & + ! apply h to rows 1_${ik}$:m-k+i+ib-1 of current block + call stdlib${ii}$_sorg2l( m-k+i+ib-1, ib, ib, a( 1_${ik}$, 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 @@ -11576,23 +11578,23 @@ module stdlib_linalg_lapack_s end do end do end if - work( 1 ) = iws + work( 1_${ik}$ ) = iws return - end subroutine stdlib_sorgql + end subroutine stdlib${ii}$_sorgql - pure subroutine stdlib_sorgqr( m, n, k, a, lda, tau, work, lwork, info ) + pure subroutine stdlib${ii}$_sorgqr( m, n, k, a, lda, tau, work, lwork, info ) !! SORGQR 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 - !! Q = H(1) H(2) . . . H(k) + !! Q = H(1_${ik}$) H(2_${ik}$) . . . H(k) !! as returned by SGEQRF. ! -- 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 - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: k, lda, lwork, m, n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: k, lda, lwork, m, n ! Array Arguments real(sp), intent(inout) :: a(lda,*) real(sp), intent(in) :: tau(*) @@ -11601,44 +11603,44 @@ module stdlib_linalg_lapack_s ! Local Scalars logical(lk) :: lquery - integer(ilp) :: i, ib, iinfo, iws, j, ki, kk, l, ldwork, lwkopt, nb, nbmin, nx + integer(${ik}$) :: i, ib, iinfo, iws, j, ki, kk, l, ldwork, lwkopt, nb, nbmin, nx ! Intrinsic Functions intrinsic :: max,min ! Executable Statements ! test the input arguments - info = 0 - nb = stdlib_ilaenv( 1, 'SORGQR', ' ', m, n, k, -1 ) - lwkopt = max( 1, n )*nb - work( 1 ) = lwkopt - lquery = ( lwork==-1 ) - if( m<0 ) then - info = -1 - else if( n<0 .or. n>m ) then - info = -2 - else if( k<0 .or. k>n ) then - info = -3 - else if( ldam ) then + info = -2_${ik}$ + else if( k<0_${ik}$ .or. k>n ) then + info = -3_${ik}$ + else if( lda1 .and. nb1_${ik}$ .and. nb0 ) then + if( kk>0_${ik}$ ) then ! use blocked code do i = ki + 1, 1, -nb ib = min( nb, k-i+1 ) 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_slarft( 'FORWARD', 'COLUMNWISE', m-i+1, ib,a( i, i ), lda, tau( i & + call stdlib${ii}$_slarft( '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_slarfb( 'LEFT', 'NO TRANSPOSE', 'FORWARD','COLUMNWISE', m-i+1, n-& + call stdlib${ii}$_slarfb( '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_sorg2r( m-i+1, ib, ib, a( i, i ), lda, tau( i ), work,iinfo ) - ! set rows 1:i-1 of current block to zero + call stdlib${ii}$_sorg2r( m-i+1, ib, ib, a( i, i ), lda, tau( i ), work,iinfo ) + ! set rows 1_${ik}$:i-1 of current block to zero do j = i, i + ib - 1 do l = 1, i - 1 a( l, j ) = zero @@ -11692,23 +11694,23 @@ module stdlib_linalg_lapack_s end do end do end if - work( 1 ) = iws + work( 1_${ik}$ ) = iws return - end subroutine stdlib_sorgqr + end subroutine stdlib${ii}$_sorgqr - pure subroutine stdlib_sorgr2( m, n, k, a, lda, tau, work, info ) + pure subroutine stdlib${ii}$_sorgr2( m, n, k, a, lda, tau, work, info ) !! SORGR2 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 - !! Q = H(1) H(2) . . . H(k) + !! Q = H(1_${ik}$) H(2_${ik}$) . . . H(k) !! as returned by SGERQF. ! -- 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 - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: k, lda, m, n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: k, lda, m, n ! Array Arguments real(sp), intent(inout) :: a(lda,*) real(sp), intent(in) :: tau(*) @@ -11716,29 +11718,29 @@ module stdlib_linalg_lapack_s ! ===================================================================== ! Local Scalars - integer(ilp) :: i, ii, j, l + integer(${ik}$) :: i, ii, j, l ! Intrinsic Functions intrinsic :: max ! Executable Statements ! test the input arguments - info = 0 - if( m<0 ) then - info = -1 + info = 0_${ik}$ + if( m<0_${ik}$ ) then + info = -1_${ik}$ else if( nm ) then - info = -3 - else if( ldam ) then + info = -3_${ik}$ + else if( ldam ) then - info = -3 - else if( ldam ) then + info = -3_${ik}$ + else if( lda1 .and. nb1_${ik}$ .and. nb0 ) then + call stdlib${ii}$_sorgr2( m-kk, n-kk, k-kk, a, lda, tau, work, iinfo ) + if( kk>0_${ik}$ ) then ! use blocked code do i = k - kk + 1, k, nb ib = min( nb, k-i+1 ) ii = m - k + i - if( ii>1 ) then + if( ii>1_${ik}$ ) then ! form the triangular factor of the block reflector ! h = h(i+ib-1) . . . h(i+1) h(i) - call stdlib_slarft( 'BACKWARD', 'ROWWISE', n-k+i+ib-1, ib,a( ii, 1 ), lda, & + call stdlib${ii}$_slarft( 'BACKWARD', 'ROWWISE', n-k+i+ib-1, ib,a( ii, 1_${ik}$ ), 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_slarfb( 'RIGHT', 'TRANSPOSE', 'BACKWARD', 'ROWWISE',ii-1, n-k+i+& - ib-1, ib, a( ii, 1 ), lda, work,ldwork, a, lda, work( ib+1 ), ldwork ) + ! apply h**t to a(1_${ik}$:m-k+i-1,1_${ik}$:n-k+i+ib-1) from the right + call stdlib${ii}$_slarfb( 'RIGHT', 'TRANSPOSE', 'BACKWARD', 'ROWWISE',ii-1, n-k+i+& + ib-1, ib, a( ii, 1_${ik}$ ), 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_sorgr2( ib, n-k+i+ib-1, ib, a( ii, 1 ), lda, tau( i ),work, iinfo ) + ! apply h**t to columns 1_${ik}$:n-k+i+ib-1 of current block + call stdlib${ii}$_sorgr2( ib, n-k+i+ib-1, ib, a( ii, 1_${ik}$ ), lda, tau( i ),work, iinfo ) ! set columns n-k+i+ib:n of current block to zero do l = n - k + i + ib, n @@ -11879,18 +11881,18 @@ module stdlib_linalg_lapack_s end do end do end if - work( 1 ) = iws + work( 1_${ik}$ ) = iws return - end subroutine stdlib_sorgrq + end subroutine stdlib${ii}$_sorgrq - pure subroutine stdlib_sorgtsqr_row( m, n, mb, nb, a, lda, t, ldt, work,lwork, info ) + pure subroutine stdlib${ii}$_sorgtsqr_row( m, n, mb, nb, a, lda, t, ldt, work,lwork, info ) !! SORGTSQR_ROW generates an M-by-N real matrix Q_out with !! orthonormal columns from the output of SLATSQR. These N orthonormal !! columns are the first N columns of a product of complex unitary !! matrices Q(k)_in of order M, which are returned by SLATSQR in !! a special format. - !! Q_out = first_N_columns_of( Q(1)_in * Q(2)_in * ... * Q(k)_in ). + !! Q_out = first_N_columns_of( Q(1_${ik}$)_in * Q(2_${ik}$)_in * ... * Q(k)_in ). !! The input matrices Q(k)_in are stored in row and column blocks in A. !! See the documentation of SLATSQR for more details on the format of !! Q(k)_in, where each Q(k)_in is represented by block Householder @@ -11904,8 +11906,8 @@ module stdlib_linalg_lapack_s ! -- 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, ldt, lwork, m, n, mb, nb + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, ldt, lwork, m, n, mb, nb ! Array Arguments real(sp), intent(inout) :: a(lda,*) real(sp), intent(in) :: t(ldt,*) @@ -11914,56 +11916,56 @@ module stdlib_linalg_lapack_s ! Local Scalars logical(lk) :: lquery - integer(ilp) :: nblocal, mb2, m_plus_one, itmp, ib_bottom, lworkopt, & + integer(${ik}$) :: 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(sp) :: dummy(1,1) + real(sp) :: dummy(1_${ik}$,1_${ik}$) ! Intrinsic Functions intrinsic :: real,max,min ! Executable Statements ! test the input parameters - info = 0 - lquery = lwork==-1 - if( m<0 ) then - info = -1 - else if( n<0 .or. m=m, then the loop is never executed. if ( mb=m, then we have only one row block of a of size m ! and we work on the entire matrix a. mb1 = min( mb, m ) @@ -12010,32 +12012,32 @@ module stdlib_linalg_lapack_s do kb = kb_last, 1, -nblocal ! determine the size of the current column block knb in ! the matrices t and v. - knb = min( nblocal, n - kb + 1 ) - if( mb1-kb-knb+1==0 ) then - ! in stdlib_slarfb_gett parameters, when m=0, then the matrix b + knb = min( nblocal, n - kb + 1_${ik}$ ) + if( mb1-kb-knb+1==0_${ik}$ ) then + ! in stdlib${ii}$_slarfb_gett parameters, when m=0_${ik}$, 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_slarfb_gett( 'N', 0, n-kb+1, knb,t( 1, kb ), ldt, a( kb, kb ), lda,& - dummy( 1, 1 ), 1, work, knb ) + ! reference dummy(1_${ik}$,1_${ik}$) to b with lddummy=1. + call stdlib${ii}$_slarfb_gett( 'N', 0_${ik}$, n-kb+1, knb,t( 1_${ik}$, kb ), ldt, a( kb, kb ), lda,& + dummy( 1_${ik}$, 1_${ik}$ ), 1_${ik}$, work, knb ) else - call stdlib_slarfb_gett( 'N', mb1-kb-knb+1, n-kb+1, knb,t( 1, kb ), ldt, a( kb, & + call stdlib${ii}$_slarfb_gett( 'N', mb1-kb-knb+1, n-kb+1, knb,t( 1_${ik}$, kb ), ldt, a( kb, & kb ), lda,a( kb+knb, kb), lda, work, knb ) end if end do - work( 1 ) = real( lworkopt,KIND=sp) + work( 1_${ik}$ ) = real( lworkopt,KIND=sp) return - end subroutine stdlib_sorgtsqr_row + end subroutine stdlib${ii}$_sorgtsqr_row - pure subroutine stdlib_sorm22( side, trans, m, n, n1, n2, q, ldq, c, ldc,work, lwork, info ) + pure subroutine stdlib${ii}$_sorm22( 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, -- ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: side, trans - integer(ilp), intent(in) :: m, n, n1, n2, ldq, ldc, lwork - integer(ilp), intent(out) :: info + integer(${ik}$), intent(in) :: m, n, n1, n2, ldq, ldc, lwork + integer(${ik}$), intent(out) :: info ! Array Arguments real(sp), intent(in) :: q(ldq,*) real(sp), intent(inout) :: c(ldc,*) @@ -12044,15 +12046,15 @@ module stdlib_linalg_lapack_s ! Local Scalars logical(lk) :: left, lquery, notran - integer(ilp) :: i, ldwork, len, lwkopt, nb, nq, nw + integer(${ik}$) :: i, ldwork, len, lwkopt, nb, nq, nw ! Intrinsic Functions intrinsic :: real,max,min ! Executable Statements ! test the input arguments - info = 0 + info = 0_${ik}$ left = stdlib_lsame( side, 'L' ) notran = stdlib_lsame( trans, 'N' ) - lquery = ( lwork==-1 ) + lquery = ( lwork==-1_${ik}$ ) ! nq is the order of q; ! nw is the minimum dimension of work. if( left ) then @@ -12061,100 +12063,100 @@ module stdlib_linalg_lapack_s nq = n end if nw = nq - if( n1==0 .or. n2==0 ) nw = 1 + if( n1==0_${ik}$ .or. n2==0_${ik}$ ) nw = 1_${ik}$ if( .not.left .and. .not.stdlib_lsame( side, 'R' ) ) then - info = -1 + info = -1_${ik}$ else if( .not.stdlib_lsame( trans, 'N' ) .and. .not.stdlib_lsame( trans, 'T' ) )& then - info = -2 - else if( m<0 ) then - info = -3 - else if( n<0 ) then - info = -4 - else if( n1<0 .or. n1+n2/=nq ) then - info = -5 - else if( n2<0 ) then - info = -6 - else if( ldqnq ) then - info = -5 - else if( ldanq ) then + info = -5_${ik}$ + else if( ldanq ) then - info = -5 - else if( ldanq ) then + info = -5_${ik}$ + else if( ldanq ) then - info = -5 - else if( ldanq ) then + info = -5_${ik}$ + else if( ldanq ) then - info = -5 - else if( ldanq ) then + info = -5_${ik}$ + else if( lda1 .and. nb1_${ik}$ .and. nb=k ) then ! use unblocked code - call stdlib_sorml2( side, trans, m, n, k, a, lda, tau, c, ldc, work,iinfo ) + call stdlib${ii}$_sorml2( side, trans, m, n, k, a, lda, tau, c, ldc, work,iinfo ) else ! use blocked code - iwt = 1 + nw*nb + iwt = 1_${ik}$ + nw*nb if( ( left .and. notran ) .or.( .not.left .and. .not.notran ) ) then - i1 = 1 + i1 = 1_${ik}$ i2 = k i3 = nb else - i1 = ( ( k-1 ) / nb )*nb + 1 - i2 = 1 + i1 = ( ( k-1 ) / nb )*nb + 1_${ik}$ + i2 = 1_${ik}$ i3 = -nb end if if( left ) then ni = n - jc = 1 + jc = 1_${ik}$ else mi = m - ic = 1 + ic = 1_${ik}$ end if if( notran ) then transt = 'T' @@ -12623,35 +12625,35 @@ module stdlib_linalg_lapack_s 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_slarft( 'FORWARD', 'ROWWISE', nq-i+1, ib, a( i, i ),lda, tau( i ), & + call stdlib${ii}$_slarft( '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) - mi = m - i + 1 + ! h or h**t is applied to c(i:m,1_${ik}$:n) + mi = m - i + 1_${ik}$ ic = i else - ! h or h**t is applied to c(1:m,i:n) - ni = n - i + 1 + ! h or h**t is applied to c(1_${ik}$:m,i:n) + ni = n - i + 1_${ik}$ jc = i end if ! apply h or h**t - call stdlib_slarfb( side, transt, 'FORWARD', 'ROWWISE', mi, ni, ib,a( i, i ), & + call stdlib${ii}$_slarfb( 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 + work( 1_${ik}$ ) = lwkopt return - end subroutine stdlib_sormlq + end subroutine stdlib${ii}$_sormlq - pure subroutine stdlib_sormql( side, trans, m, n, k, a, lda, tau, c, ldc,work, lwork, info ) + pure subroutine stdlib${ii}$_sormql( side, trans, m, n, k, a, lda, tau, c, ldc,work, lwork, info ) !! SORMQL overwrites the general real M-by-N matrix C with !! SIDE = 'L' SIDE = 'R' !! TRANS = 'N': Q * C C * Q !! TRANS = 'T': Q**T * C C * Q**T !! where Q is a real orthogonal matrix defined as the product of k !! elementary reflectors - !! Q = H(k) . . . H(2) H(1) + !! Q = H(k) . . . H(2_${ik}$) H(1_${ik}$) !! as returned by SGEQLF. Q is of order M if SIDE = 'L' and of order N !! if SIDE = 'R'. @@ -12660,97 +12662,97 @@ module stdlib_linalg_lapack_s ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: side, trans - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: k, lda, ldc, lwork, m, n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: k, lda, ldc, lwork, m, n ! Array Arguments real(sp), intent(inout) :: a(lda,*), c(ldc,*) real(sp), intent(in) :: tau(*) real(sp), intent(out) :: work(*) ! ===================================================================== ! Parameters - integer(ilp), parameter :: nbmax = 64 - integer(ilp), parameter :: ldt = nbmax+1 - integer(ilp), parameter :: tsize = ldt*nbmax + integer(${ik}$), parameter :: nbmax = 64_${ik}$ + integer(${ik}$), parameter :: ldt = nbmax+1 + integer(${ik}$), parameter :: tsize = ldt*nbmax ! Local Scalars logical(lk) :: left, lquery, notran - integer(ilp) :: i, i1, i2, i3, ib, iinfo, iwt, ldwork, lwkopt, mi, nb, nbmin, ni, nq, & + integer(${ik}$) :: i, i1, i2, i3, ib, iinfo, iwt, ldwork, lwkopt, mi, nb, nbmin, ni, nq, & nw ! Intrinsic Functions intrinsic :: max,min ! Executable Statements ! test the input arguments - info = 0 + info = 0_${ik}$ left = stdlib_lsame( side, 'L' ) notran = stdlib_lsame( trans, 'N' ) - lquery = ( lwork==-1 ) + lquery = ( lwork==-1_${ik}$ ) ! nq is the order of q and nw is the minimum dimension of work if( left ) then nq = m - nw = max( 1, n ) + nw = max( 1_${ik}$, n ) else nq = n - nw = max( 1, m ) + nw = max( 1_${ik}$, m ) end if if( .not.left .and. .not.stdlib_lsame( side, 'R' ) ) then - info = -1 + info = -1_${ik}$ else if( .not.notran .and. .not.stdlib_lsame( trans, 'T' ) ) then - info = -2 - else if( m<0 ) then - info = -3 - else if( n<0 ) then - info = -4 - else if( k<0 .or. k>nq ) then - info = -5 - else if( ldanq ) then + info = -5_${ik}$ + else if( lda1 .and. nb1_${ik}$ .and. nb=k ) then ! use unblocked code - call stdlib_sorm2l( side, trans, m, n, k, a, lda, tau, c, ldc, work,iinfo ) + call stdlib${ii}$_sorm2l( side, trans, m, n, k, a, lda, tau, c, ldc, work,iinfo ) else ! use blocked code - iwt = 1 + nw*nb + iwt = 1_${ik}$ + nw*nb if( ( left .and. notran ) .or.( .not.left .and. .not.notran ) ) then - i1 = 1 + i1 = 1_${ik}$ i2 = k i3 = nb else - i1 = ( ( k-1 ) / nb )*nb + 1 - i2 = 1 + i1 = ( ( k-1 ) / nb )*nb + 1_${ik}$ + i2 = 1_${ik}$ i3 = -nb end if if( left ) then @@ -12762,33 +12764,33 @@ module stdlib_linalg_lapack_s 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_slarft( 'BACKWARD', 'COLUMNWISE', nq-k+i+ib-1, ib,a( 1, i ), lda, & + call stdlib${ii}$_slarft( 'BACKWARD', 'COLUMNWISE', nq-k+i+ib-1, ib,a( 1_${ik}$, 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) - mi = m - k + i + ib - 1 + ! h or h**t is applied to c(1_${ik}$:m-k+i+ib-1,1_${ik}$:n) + mi = m - k + i + ib - 1_${ik}$ else - ! h or h**t is applied to c(1:m,1:n-k+i+ib-1) - ni = n - k + i + ib - 1 + ! h or h**t is applied to c(1_${ik}$:m,1_${ik}$:n-k+i+ib-1) + ni = n - k + i + ib - 1_${ik}$ end if ! apply h or h**t - call stdlib_slarfb( side, trans, 'BACKWARD', 'COLUMNWISE', mi, ni,ib, a( 1, i ), & + call stdlib${ii}$_slarfb( side, trans, 'BACKWARD', 'COLUMNWISE', mi, ni,ib, a( 1_${ik}$, i ), & lda, work( iwt ), ldt, c, ldc,work, ldwork ) end do end if - work( 1 ) = lwkopt + work( 1_${ik}$ ) = lwkopt return - end subroutine stdlib_sormql + end subroutine stdlib${ii}$_sormql - pure subroutine stdlib_sormqr( side, trans, m, n, k, a, lda, tau, c, ldc,work, lwork, info ) + pure subroutine stdlib${ii}$_sormqr( side, trans, m, n, k, a, lda, tau, c, ldc,work, lwork, info ) !! SORMQR overwrites the general real M-by-N matrix C with !! SIDE = 'L' SIDE = 'R' !! TRANS = 'N': Q * C C * Q !! TRANS = 'T': Q**T * C C * Q**T !! where Q is a real orthogonal matrix defined as the product of k !! elementary reflectors - !! Q = H(1) H(2) . . . H(k) + !! Q = H(1_${ik}$) H(2_${ik}$) . . . H(k) !! as returned by SGEQRF. Q is of order M if SIDE = 'L' and of order N !! if SIDE = 'R'. @@ -12797,128 +12799,128 @@ module stdlib_linalg_lapack_s ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: side, trans - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: k, lda, ldc, lwork, m, n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: k, lda, ldc, lwork, m, n ! Array Arguments real(sp), intent(inout) :: a(lda,*), c(ldc,*) real(sp), intent(in) :: tau(*) real(sp), intent(out) :: work(*) ! ===================================================================== ! Parameters - integer(ilp), parameter :: nbmax = 64 - integer(ilp), parameter :: ldt = nbmax+1 - integer(ilp), parameter :: tsize = ldt*nbmax + integer(${ik}$), parameter :: nbmax = 64_${ik}$ + integer(${ik}$), parameter :: ldt = nbmax+1 + integer(${ik}$), parameter :: tsize = ldt*nbmax ! Local Scalars logical(lk) :: left, lquery, notran - integer(ilp) :: i, i1, i2, i3, ib, ic, iinfo, iwt, jc, ldwork, lwkopt, mi, nb, nbmin, & + integer(${ik}$) :: i, i1, i2, i3, ib, ic, iinfo, iwt, jc, ldwork, lwkopt, mi, nb, nbmin, & ni, nq, nw ! Intrinsic Functions intrinsic :: max,min ! Executable Statements ! test the input arguments - info = 0 + info = 0_${ik}$ left = stdlib_lsame( side, 'L' ) notran = stdlib_lsame( trans, 'N' ) - lquery = ( lwork==-1 ) + lquery = ( lwork==-1_${ik}$ ) ! nq is the order of q and nw is the minimum dimension of work if( left ) then nq = m - nw = max( 1, n ) + nw = max( 1_${ik}$, n ) else nq = n - nw = max( 1, m ) + nw = max( 1_${ik}$, m ) end if if( .not.left .and. .not.stdlib_lsame( side, 'R' ) ) then - info = -1 + info = -1_${ik}$ else if( .not.notran .and. .not.stdlib_lsame( trans, 'T' ) ) then - info = -2 - else if( m<0 ) then - info = -3 - else if( n<0 ) then - info = -4 - else if( k<0 .or. k>nq ) then - info = -5 - else if( ldanq ) then + info = -5_${ik}$ + else if( lda1 .and. nb1_${ik}$ .and. nb=k ) then ! use unblocked code - call stdlib_sorm2r( side, trans, m, n, k, a, lda, tau, c, ldc, work,iinfo ) + call stdlib${ii}$_sorm2r( side, trans, m, n, k, a, lda, tau, c, ldc, work,iinfo ) else ! use blocked code - iwt = 1 + nw*nb + iwt = 1_${ik}$ + nw*nb if( ( left .and. .not.notran ) .or.( .not.left .and. notran ) ) then - i1 = 1 + i1 = 1_${ik}$ i2 = k i3 = nb else - i1 = ( ( k-1 ) / nb )*nb + 1 - i2 = 1 + i1 = ( ( k-1 ) / nb )*nb + 1_${ik}$ + i2 = 1_${ik}$ i3 = -nb end if if( left ) then ni = n - jc = 1 + jc = 1_${ik}$ else mi = m - ic = 1 + ic = 1_${ik}$ end if do i = i1, i2, i3 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_slarft( 'FORWARD', 'COLUMNWISE', nq-i+1, ib, a( i, i ),lda, tau( i ),& + call stdlib${ii}$_slarft( '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) - mi = m - i + 1 + ! h or h**t is applied to c(i:m,1_${ik}$:n) + mi = m - i + 1_${ik}$ ic = i else - ! h or h**t is applied to c(1:m,i:n) - ni = n - i + 1 + ! h or h**t is applied to c(1_${ik}$:m,i:n) + ni = n - i + 1_${ik}$ jc = i end if ! apply h or h**t - call stdlib_slarfb( side, trans, 'FORWARD', 'COLUMNWISE', mi, ni,ib, a( i, i ), & + call stdlib${ii}$_slarfb( 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 + work( 1_${ik}$ ) = lwkopt return - end subroutine stdlib_sormqr + end subroutine stdlib${ii}$_sormqr - pure subroutine stdlib_sormr2( side, trans, m, n, k, a, lda, tau, c, ldc,work, info ) + pure subroutine stdlib${ii}$_sormr2( side, trans, m, n, k, a, lda, tau, c, ldc,work, info ) !! SORMR2 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 @@ -12926,7 +12928,7 @@ module stdlib_linalg_lapack_s !! C * Q**T if SIDE = 'R' and TRANS = 'T', !! where Q is a real orthogonal matrix defined as the product of k !! elementary reflectors - !! Q = H(1) H(2) . . . H(k) + !! Q = H(1_${ik}$) H(2_${ik}$) . . . H(k) !! as returned by SGERQF. Q is of order m if SIDE = 'L' and of order n !! if SIDE = 'R'. ! -- lapack computational routine -- @@ -12934,8 +12936,8 @@ module stdlib_linalg_lapack_s ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: side, trans - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: k, lda, ldc, m, n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: k, lda, ldc, m, n ! Array Arguments real(sp), intent(inout) :: a(lda,*), c(ldc,*) real(sp), intent(in) :: tau(*) @@ -12944,13 +12946,13 @@ module stdlib_linalg_lapack_s ! Local Scalars logical(lk) :: left, notran - integer(ilp) :: i, i1, i2, i3, mi, ni, nq + integer(${ik}$) :: i, i1, i2, i3, mi, ni, nq real(sp) :: aii ! Intrinsic Functions intrinsic :: max ! Executable Statements ! test the input arguments - info = 0 + info = 0_${ik}$ left = stdlib_lsame( side, 'L' ) notran = stdlib_lsame( trans, 'N' ) ! nq is the order of q @@ -12960,34 +12962,34 @@ module stdlib_linalg_lapack_s nq = n end if if( .not.left .and. .not.stdlib_lsame( side, 'R' ) ) then - info = -1 + info = -1_${ik}$ else if( .not.notran .and. .not.stdlib_lsame( trans, 'T' ) ) then - info = -2 - else if( m<0 ) then - info = -3 - else if( n<0 ) then - info = -4 - else if( k<0 .or. k>nq ) then - info = -5 - else if( ldanq ) then + info = -5_${ik}$ + else if( ldanq ) then - info = -5 - else if( l<0 .or. ( left .and. ( l>m ) ) .or.( .not.left .and. ( l>n ) ) ) then - info = -6 - else if( ldanq ) then + info = -5_${ik}$ + else if( l<0_${ik}$ .or. ( left .and. ( l>m ) ) .or.( .not.left .and. ( l>n ) ) ) then + info = -6_${ik}$ + else if( ldanq ) then - info = -5 - else if( ldanq ) then + info = -5_${ik}$ + else if( lda1 .and. nb1_${ik}$ .and. nb=k ) then ! use unblocked code - call stdlib_sormr2( side, trans, m, n, k, a, lda, tau, c, ldc, work,iinfo ) + call stdlib${ii}$_sormr2( side, trans, m, n, k, a, lda, tau, c, ldc, work,iinfo ) else ! use blocked code - iwt = 1 + nw*nb + iwt = 1_${ik}$ + nw*nb if( ( left .and. .not.notran ) .or.( .not.left .and. notran ) ) then - i1 = 1 + i1 = 1_${ik}$ i2 = k i3 = nb else - i1 = ( ( k-1 ) / nb )*nb + 1 - i2 = 1 + i1 = ( ( k-1 ) / nb )*nb + 1_${ik}$ + i2 = 1_${ik}$ i3 = -nb end if if( left ) then @@ -13235,33 +13237,33 @@ module stdlib_linalg_lapack_s 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_slarft( 'BACKWARD', 'ROWWISE', nq-k+i+ib-1, ib,a( i, 1 ), lda, tau( & + call stdlib${ii}$_slarft( 'BACKWARD', 'ROWWISE', nq-k+i+ib-1, ib,a( i, 1_${ik}$ ), 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) - mi = m - k + i + ib - 1 + ! h or h**t is applied to c(1_${ik}$:m-k+i+ib-1,1_${ik}$:n) + mi = m - k + i + ib - 1_${ik}$ else - ! h or h**t is applied to c(1:m,1:n-k+i+ib-1) - ni = n - k + i + ib - 1 + ! h or h**t is applied to c(1_${ik}$:m,1_${ik}$:n-k+i+ib-1) + ni = n - k + i + ib - 1_${ik}$ end if ! apply h or h**t - call stdlib_slarfb( side, transt, 'BACKWARD', 'ROWWISE', mi, ni,ib, a( i, 1 ), & + call stdlib${ii}$_slarfb( side, transt, 'BACKWARD', 'ROWWISE', mi, ni,ib, a( i, 1_${ik}$ ), & lda, work( iwt ), ldt, c, ldc,work, ldwork ) end do end if - work( 1 ) = lwkopt + work( 1_${ik}$ ) = lwkopt return - end subroutine stdlib_sormrq + end subroutine stdlib${ii}$_sormrq - pure subroutine stdlib_sormrz( side, trans, m, n, k, l, a, lda, tau, c, ldc,work, lwork, & + pure subroutine stdlib${ii}$_sormrz( side, trans, m, n, k, l, a, lda, tau, c, ldc,work, lwork, & !! SORMRZ overwrites the general real M-by-N matrix C with !! SIDE = 'L' SIDE = 'R' !! TRANS = 'N': Q * C C * Q !! TRANS = 'T': Q**T * C C * Q**T !! where Q is a real orthogonal matrix defined as the product of k !! elementary reflectors - !! Q = H(1) H(2) . . . H(k) + !! Q = H(1_${ik}$) H(2_${ik}$) . . . H(k) !! as returned by STZRZF. Q is of order M if SIDE = 'L' and of order N !! if SIDE = 'R'. info ) @@ -13270,111 +13272,111 @@ module stdlib_linalg_lapack_s ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: side, trans - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: k, l, lda, ldc, lwork, m, n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: k, l, lda, ldc, lwork, m, n ! Array Arguments real(sp), intent(inout) :: a(lda,*), c(ldc,*) real(sp), intent(in) :: tau(*) real(sp), intent(out) :: work(*) ! ===================================================================== ! Parameters - integer(ilp), parameter :: nbmax = 64 - integer(ilp), parameter :: ldt = nbmax+1 - integer(ilp), parameter :: tsize = ldt*nbmax + integer(${ik}$), parameter :: nbmax = 64_${ik}$ + integer(${ik}$), parameter :: ldt = nbmax+1 + integer(${ik}$), parameter :: tsize = ldt*nbmax ! Local Scalars logical(lk) :: left, lquery, notran character :: transt - integer(ilp) :: i, i1, i2, i3, ib, ic, iinfo, iwt, ja, jc, ldwork, lwkopt, mi, nb, & + integer(${ik}$) :: i, i1, i2, i3, ib, ic, iinfo, iwt, ja, jc, ldwork, lwkopt, mi, nb, & nbmin, ni, nq, nw ! Intrinsic Functions intrinsic :: max,min ! Executable Statements ! test the input arguments - info = 0 + info = 0_${ik}$ left = stdlib_lsame( side, 'L' ) notran = stdlib_lsame( trans, 'N' ) - lquery = ( lwork==-1 ) + lquery = ( lwork==-1_${ik}$ ) ! nq is the order of q and nw is the minimum dimension of work if( left ) then nq = m - nw = max( 1, n ) + nw = max( 1_${ik}$, n ) else nq = n - nw = max( 1, m ) + nw = max( 1_${ik}$, m ) end if if( .not.left .and. .not.stdlib_lsame( side, 'R' ) ) then - info = -1 + info = -1_${ik}$ else if( .not.notran .and. .not.stdlib_lsame( trans, 'T' ) ) then - info = -2 - else if( m<0 ) then - info = -3 - else if( n<0 ) then - info = -4 - else if( k<0 .or. k>nq ) then - info = -5 - else if( l<0 .or. ( left .and. ( l>m ) ) .or.( .not.left .and. ( l>n ) ) ) then - info = -6 - else if( ldanq ) then + info = -5_${ik}$ + else if( l<0_${ik}$ .or. ( left .and. ( l>m ) ) .or.( .not.left .and. ( l>n ) ) ) then + info = -6_${ik}$ + else if( lda1 .and. nb1_${ik}$ .and. nb=k ) then ! use unblocked code - call stdlib_sormr3( side, trans, m, n, k, l, a, lda, tau, c, ldc,work, iinfo ) + call stdlib${ii}$_sormr3( side, trans, m, n, k, l, a, lda, tau, c, ldc,work, iinfo ) else ! use blocked code - iwt = 1 + nw*nb + iwt = 1_${ik}$ + nw*nb if( ( left .and. .not.notran ) .or.( .not.left .and. notran ) ) then - i1 = 1 + i1 = 1_${ik}$ i2 = k i3 = nb else - i1 = ( ( k-1 ) / nb )*nb + 1 - i2 = 1 + i1 = ( ( k-1 ) / nb )*nb + 1_${ik}$ + i2 = 1_${ik}$ i3 = -nb end if if( left ) then ni = n - jc = 1 - ja = m - l + 1 + jc = 1_${ik}$ + ja = m - l + 1_${ik}$ else mi = m - ic = 1 - ja = n - l + 1 + ic = 1_${ik}$ + ja = n - l + 1_${ik}$ end if if( notran ) then transt = 'T' @@ -13385,32 +13387,32 @@ module stdlib_linalg_lapack_s 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_slarzt( 'BACKWARD', 'ROWWISE', l, ib, a( i, ja ), lda,tau( i ), work(& + call stdlib${ii}$_slarzt( '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) - mi = m - i + 1 + ! h or h**t is applied to c(i:m,1_${ik}$:n) + mi = m - i + 1_${ik}$ ic = i else - ! h or h**t is applied to c(1:m,i:n) - ni = n - i + 1 + ! h or h**t is applied to c(1_${ik}$:m,i:n) + ni = n - i + 1_${ik}$ jc = i end if ! apply h or h**t - call stdlib_slarzb( side, transt, 'BACKWARD', 'ROWWISE', mi, ni,ib, l, a( i, ja )& + call stdlib${ii}$_slarzb( 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 + work( 1_${ik}$ ) = lwkopt return - end subroutine stdlib_sormrz + end subroutine stdlib${ii}$_sormrz - pure subroutine stdlib_spbequ( uplo, n, kd, ab, ldab, s, scond, amax, info ) + pure subroutine stdlib${ii}$_spbequ( uplo, n, kd, ab, ldab, s, scond, amax, info ) !! SPBEQU computes row and column scalings intended to equilibrate a !! symmetric positive definite band matrix A and reduce its condition !! number (with respect to the two-norm). S contains the scale factors, - !! S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with + !! S(i) = 1_${ik}$/sqrt(A(i,i)), chosen so that the scaled matrix B with !! elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This !! choice of S puts the condition number of B within a factor N of the !! smallest possible condition number over all possible diagonal @@ -13420,8 +13422,8 @@ module stdlib_linalg_lapack_s ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: kd, ldab, n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: kd, ldab, n real(sp), intent(out) :: amax, scond ! Array Arguments real(sp), intent(in) :: ab(ldab,*) @@ -13430,42 +13432,42 @@ module stdlib_linalg_lapack_s ! Local Scalars logical(lk) :: upper - integer(ilp) :: i, j + integer(${ik}$) :: i, j real(sp) :: smin ! Intrinsic Functions intrinsic :: max,min,sqrt ! Executable Statements ! test the input parameters. - info = 0 + info = 0_${ik}$ upper = stdlib_lsame( uplo, 'U' ) if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then - info = -1 - else if( n<0 ) then - info = -2 - else if( kd<0 ) then - info = -3 + info = -1_${ik}$ + else if( n<0_${ik}$ ) then + info = -2_${ik}$ + else if( kd<0_${ik}$ ) then + info = -3_${ik}$ else if( ldab0 ) then - call stdlib_sscal( km, one / ajj, ab( kd, j+1 ), kld ) - call stdlib_ssyr( 'UPPER', km, -one, ab( kd, j+1 ), kld,ab( kd+1, j+1 ), kld ) + if( km>0_${ik}$ ) then + call stdlib${ii}$_sscal( km, one / ajj, ab( kd, j+1 ), kld ) + call stdlib${ii}$_ssyr( 'UPPER', km, -one, ab( kd, j+1 ), kld,ab( kd+1, j+1 ), kld ) end if end do else - ! factorize a(m+1:n,m+1:n) as l**t*l, and update a(1:m,1:m). + ! factorize a(m+1:n,m+1:n) as l**t*l, and update a(1_${ik}$:m,1_${ik}$:m). do j = n, m + 1, -1 ! compute s(j,j) and test for non-positive-definiteness. - ajj = ab( 1, j ) + ajj = ab( 1_${ik}$, j ) if( ajj<=zero )go to 50 ajj = sqrt( ajj ) - ab( 1, j ) = ajj + ab( 1_${ik}$, j ) = ajj 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_sscal( km, one / ajj, ab( km+1, j-km ), kld ) - call stdlib_ssyr( 'LOWER', km, -one, ab( km+1, j-km ), kld,ab( 1, j-km ), kld ) + call stdlib${ii}$_sscal( km, one / ajj, ab( km+1, j-km ), kld ) + call stdlib${ii}$_ssyr( 'LOWER', km, -one, ab( km+1, j-km ), kld,ab( 1_${ik}$, j-km ), kld ) end do - ! factorize the updated submatrix a(1:m,1:m) as u**t*u. + ! factorize the updated submatrix a(1_${ik}$:m,1_${ik}$:m) as u**t*u. do j = 1, m ! compute s(j,j) and test for non-positive-definiteness. - ajj = ab( 1, j ) + ajj = ab( 1_${ik}$, j ) if( ajj<=zero )go to 50 ajj = sqrt( ajj ) - ab( 1, j ) = ajj + ab( 1_${ik}$, j ) = ajj km = min( kd, m-j ) ! 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_sscal( km, one / ajj, ab( 2, j ), 1 ) - call stdlib_ssyr( 'LOWER', km, -one, ab( 2, j ), 1,ab( 1, j+1 ), kld ) + if( km>0_${ik}$ ) then + call stdlib${ii}$_sscal( km, one / ajj, ab( 2_${ik}$, j ), 1_${ik}$ ) + call stdlib${ii}$_ssyr( 'LOWER', km, -one, ab( 2_${ik}$, j ), 1_${ik}$,ab( 1_${ik}$, j+1 ), kld ) end if end do end if @@ -13608,10 +13610,10 @@ module stdlib_linalg_lapack_s 50 continue info = j return - end subroutine stdlib_spbstf + end subroutine stdlib${ii}$_spbstf - pure subroutine stdlib_spbtf2( uplo, n, kd, ab, ldab, info ) + pure subroutine stdlib${ii}$_spbtf2( uplo, n, kd, ab, ldab, info ) !! SPBTF2 computes the Cholesky factorization of a real symmetric !! positive definite band matrix A. !! The factorization has the form @@ -13619,44 +13621,44 @@ module stdlib_linalg_lapack_s !! A = L * L**T, if UPLO = 'L', !! where U is an upper triangular matrix, U**T is the transpose of U, and !! L is lower triangular. - !! This is the unblocked version of the algorithm, calling Level 2 BLAS. + !! This is the unblocked version of the algorithm, calling Level 2_${ik}$ BLAS. ! -- lapack computational routine -- ! -- lapack is a software package provided by univ. of tennessee, -- ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: kd, ldab, n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: kd, ldab, n ! Array Arguments real(sp), intent(inout) :: ab(ldab,*) ! ===================================================================== ! Local Scalars logical(lk) :: upper - integer(ilp) :: j, kld, kn + integer(${ik}$) :: j, kld, kn real(sp) :: ajj ! Intrinsic Functions intrinsic :: max,min,sqrt ! Executable Statements ! test the input parameters. - info = 0 + info = 0_${ik}$ upper = stdlib_lsame( uplo, 'U' ) if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then - info = -1 - else if( n<0 ) then - info = -2 - else if( kd<0 ) then - info = -3 + info = -1_${ik}$ + else if( n<0_${ik}$ ) then + info = -2_${ik}$ + else if( kd<0_${ik}$ ) then + info = -3_${ik}$ else if( ldab0 ) then - call stdlib_sscal( kn, one / ajj, ab( kd, j+1 ), kld ) - call stdlib_ssyr( 'UPPER', kn, -one, ab( kd, j+1 ), kld,ab( kd+1, j+1 ), kld ) + if( kn>0_${ik}$ ) then + call stdlib${ii}$_sscal( kn, one / ajj, ab( kd, j+1 ), kld ) + call stdlib${ii}$_ssyr( 'UPPER', kn, -one, ab( kd, j+1 ), kld,ab( kd+1, j+1 ), kld ) end if end do @@ -13678,16 +13680,16 @@ module stdlib_linalg_lapack_s ! compute the cholesky factorization a = l*l**t. do j = 1, n ! compute l(j,j) and test for non-positive-definiteness. - ajj = ab( 1, j ) + ajj = ab( 1_${ik}$, j ) if( ajj<=zero )go to 30 ajj = sqrt( ajj ) - ab( 1, j ) = ajj + ab( 1_${ik}$, j ) = ajj ! compute elements j+1:j+kn of column j and update the ! trailing submatrix within the band. kn = min( kd, n-j ) - if( kn>0 ) then - call stdlib_sscal( kn, one / ajj, ab( 2, j ), 1 ) - call stdlib_ssyr( 'LOWER', kn, -one, ab( 2, j ), 1,ab( 1, j+1 ), kld ) + if( kn>0_${ik}$ ) then + call stdlib${ii}$_sscal( kn, one / ajj, ab( 2_${ik}$, j ), 1_${ik}$ ) + call stdlib${ii}$_ssyr( 'LOWER', kn, -one, ab( 2_${ik}$, j ), 1_${ik}$,ab( 1_${ik}$, j+1 ), kld ) end if end do end if @@ -13695,10 +13697,10 @@ module stdlib_linalg_lapack_s 30 continue info = j return - end subroutine stdlib_spbtf2 + end subroutine stdlib${ii}$_spbtf2 - pure subroutine stdlib_spbtrs( uplo, n, kd, nrhs, ab, ldab, b, ldb, info ) + pure subroutine stdlib${ii}$_spbtrs( uplo, n, kd, nrhs, ab, ldab, b, ldb, info ) !! SPBTRS 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 SPBTRF. @@ -13707,36 +13709,36 @@ module stdlib_linalg_lapack_s ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: kd, ldab, ldb, n, nrhs + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: kd, ldab, ldb, n, nrhs ! Array Arguments real(sp), intent(in) :: ab(ldab,*) real(sp), intent(inout) :: b(ldb,*) ! ===================================================================== ! Local Scalars logical(lk) :: upper - integer(ilp) :: j + integer(${ik}$) :: j ! Intrinsic Functions intrinsic :: max ! Executable Statements ! test the input parameters. - info = 0 + info = 0_${ik}$ upper = stdlib_lsame( uplo, 'U' ) if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then - info = -1 - else if( n<0 ) then - info = -2 - else if( kd<0 ) then - info = -3 - else if( nrhs<0 ) then - info = -4 + info = -1_${ik}$ + else if( n<0_${ik}$ ) then + info = -2_${ik}$ + else if( kd<0_${ik}$ ) then + info = -3_${ik}$ + else if( nrhs<0_${ik}$ ) then + info = -4_${ik}$ else if( ldab1 )call stdlib_stpsv( 'UPPER', 'TRANSPOSE', 'NON-UNIT', j-1, ap,ap( jc ), & - 1 ) + ! compute elements 1_${ik}$:j-1 of column j. + if( j>1_${ik}$ )call stdlib${ii}$_stpsv( 'UPPER', 'TRANSPOSE', 'NON-UNIT', j-1, ap,ap( jc ), & + 1_${ik}$ ) ! compute u(j,j) and test for non-positive-definiteness. - ajj = ap( jj ) - stdlib_sdot( j-1, ap( jc ), 1, ap( jc ), 1 ) + ajj = ap( jj ) - stdlib${ii}$_sdot( j-1, ap( jc ), 1_${ik}$, ap( jc ), 1_${ik}$ ) if( ajj<=zero ) then ap( jj ) = ajj go to 30 @@ -14135,7 +14137,7 @@ module stdlib_linalg_lapack_s end do else ! compute the cholesky factorization a = l*l**t. - jj = 1 + jj = 1_${ik}$ do j = 1, n ! compute l(j,j) and test for non-positive-definiteness. ajj = ap( jj ) @@ -14148,9 +14150,9 @@ module stdlib_linalg_lapack_s ! compute elements j+1:n of column j and update the trailing ! submatrix. if( jka ) then - info = -5 + info = -2_${ik}$ + else if( n<0_${ik}$ ) then + info = -3_${ik}$ + else if( ka<0_${ik}$ ) then + info = -4_${ik}$ + else if( kb<0_${ik}$ .or. kb>ka ) then + info = -5_${ik}$ else if( ldab0 )call stdlib_sger( n-m, kbt, -one, x( m+1, i ), 1,bb( kb1-kbt, i ), & - 1, x( m+1, i-kbt ), ldx ) + call stdlib${ii}$_sscal( n-m, one / bii, x( m+1, i ), 1_${ik}$ ) + if( kbt>0_${ik}$ )call stdlib${ii}$_sger( n-m, kbt, -one, x( m+1, i ), 1_${ik}$,bb( kb1-kbt, i ), & + 1_${ik}$, x( m+1, i-kbt ), ldx ) end if ! store a(i,i1) in ra1 for use in next loop over k ra1 = ab( i-i1+ka1, i1 ) @@ -14650,21 +14652,21 @@ module stdlib_linalg_lapack_s if( update ) then ! determine the rotations which would annihilate the bulge ! which has in theory just been created - if( i-k+ka1 ) then + if( i-k+ka1_${ik}$ ) then ! generate rotation to annihilate a(i,i-k+ka+1) - call stdlib_slartg( ab( k+1, i-k+ka ), ra1,work( n+i-k+ka-m ), work( i-k+& + call stdlib${ii}$_slartg( 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) t = -bb( kb1-k, i )*ra1 - work( i-k ) = work( n+i-k+ka-m )*t -work( i-k+ka-m )*ab( 1, i-k+ka ) + work( i-k ) = work( n+i-k+ka-m )*t -work( i-k+ka-m )*ab( 1_${ik}$, i-k+ka ) - ab( 1, i-k+ka ) = work( i-k+ka-m )*t +work( n+i-k+ka-m )*ab( 1, i-k+ka ) + ab( 1_${ik}$, i-k+ka ) = work( i-k+ka-m )*t +work( n+i-k+ka-m )*ab( 1_${ik}$, i-k+ka ) ra1 = ra end if end if - j2 = i - k - 1 + max( 1, k-i0+2 )*ka1 + j2 = i - k - 1_${ik}$ + max( 1_${ik}$, k-i0+2 )*ka1 nr = ( n-j2+ka ) / ka1 j1 = j2 + ( nr-1 )*ka1 if( update ) then @@ -14676,40 +14678,40 @@ module stdlib_linalg_lapack_s do j = j2t, j1, ka1 ! create nonzero element a(j-ka,j+1) outside the band ! and store it in work(j-m) - work( j-m ) = work( j-m )*ab( 1, j+1 ) - ab( 1, j+1 ) = work( n+j-m )*ab( 1, j+1 ) + work( j-m ) = work( j-m )*ab( 1_${ik}$, j+1 ) + ab( 1_${ik}$, j+1 ) = work( n+j-m )*ab( 1_${ik}$, j+1 ) end do - ! generate rotations in 1st set to annihilate elements which + ! generate rotations in 1_${ik}$st set to annihilate elements which ! have been created outside the band - if( nrt>0 )call stdlib_slargv( nrt, ab( 1, j2t ), inca, work( j2t-m ), ka1,work( & + if( nrt>0_${ik}$ )call stdlib${ii}$_slargv( nrt, ab( 1_${ik}$, j2t ), inca, work( j2t-m ), ka1,work( & n+j2t-m ), ka1 ) - if( nr>0 ) then - ! apply rotations in 1st set from the right + if( nr>0_${ik}$ ) then + ! apply rotations in 1_${ik}$st set from the right do l = 1, ka - 1 - call stdlib_slartv( nr, ab( ka1-l, j2 ), inca,ab( ka-l, j2+1 ), inca, work(& + call stdlib${ii}$_slartv( 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 + ! apply rotations in 1_${ik}$st set from both sides to diagonal ! blocks - call stdlib_slar2v( nr, ab( ka1, j2 ), ab( ka1, j2+1 ),ab( ka, j2+1 ), inca, & + call stdlib${ii}$_slar2v( 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 + ! start applying rotations in 1_${ik}$st set from the left do l = ka - 1, kb - k + 1, -1 nrt = ( n-j2+l ) / ka1 - if( nrt>0 )call stdlib_slartv( nrt, ab( l, j2+ka1-l ), inca,ab( l+1, j2+ka1-l & + if( nrt>0_${ik}$ )call stdlib${ii}$_slartv( 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 + ! post-multiply x by product of rotations in 1_${ik}$st set do j = j2, j1, ka1 - call stdlib_srot( n-m, x( m+1, j ), 1, x( m+1, j+1 ), 1,work( n+j-m ), & + call stdlib${ii}$_srot( n-m, x( m+1, j ), 1_${ik}$, x( m+1, j+1 ), 1_${ik}$,work( n+j-m ), & work( j-m ) ) end do end if end do loop_130 if( update ) then - if( i2<=n .and. kbt>0 ) then + if( i2<=n .and. kbt>0_${ik}$ ) then ! create nonzero element a(i-kbt,i-kbt+ka+1) outside the ! band and store it in work(i-kbt) work( i-kbt ) = -bb( kb1-kbt, i )*ra1 @@ -14717,14 +14719,14 @@ module stdlib_linalg_lapack_s end if loop_170: do k = kb, 1, -1 if( update ) then - j2 = i - k - 1 + max( 2, k-i0+1 )*ka1 + j2 = i - k - 1_${ik}$ + max( 2_${ik}$, k-i0+1 )*ka1 else - j2 = i - k - 1 + max( 1, k-i0+1 )*ka1 + j2 = i - k - 1_${ik}$ + max( 1_${ik}$, k-i0+1 )*ka1 end if - ! finish applying rotations in 2nd set from the left + ! finish applying rotations in 2_${ik}$nd set from the left do l = kb - k, 1, -1 nrt = ( n-j2+ka+l ) / ka1 - if( nrt>0 )call stdlib_slartv( nrt, ab( l, j2-l+1 ), inca,ab( l+1, j2-l+1 ), & + if( nrt>0_${ik}$ )call stdlib${ii}$_slartv( 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 @@ -14736,56 +14738,56 @@ module stdlib_linalg_lapack_s do j = j2, j1, ka1 ! create nonzero element a(j-ka,j+1) outside the band ! and store it in work(j) - work( j ) = work( j )*ab( 1, j+1 ) - ab( 1, j+1 ) = work( n+j )*ab( 1, j+1 ) + work( j ) = work( j )*ab( 1_${ik}$, j+1 ) + ab( 1_${ik}$, j+1 ) = work( n+j )*ab( 1_${ik}$, j+1 ) end do if( update ) then if( i-k0 ) then - ! generate rotations in 2nd set to annihilate elements + if( nr>0_${ik}$ ) then + ! generate rotations in 2_${ik}$nd set to annihilate elements ! which have been created outside the band - call stdlib_slargv( nr, ab( 1, j2 ), inca, work( j2 ), ka1,work( n+j2 ), ka1 ) + call stdlib${ii}$_slargv( nr, ab( 1_${ik}$, j2 ), inca, work( j2 ), ka1,work( n+j2 ), ka1 ) - ! apply rotations in 2nd set from the right + ! apply rotations in 2_${ik}$nd set from the right do l = 1, ka - 1 - call stdlib_slartv( nr, ab( ka1-l, j2 ), inca,ab( ka-l, j2+1 ), inca, work(& + call stdlib${ii}$_slartv( 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 + ! apply rotations in 2_${ik}$nd set from both sides to diagonal ! blocks - call stdlib_slar2v( nr, ab( ka1, j2 ), ab( ka1, j2+1 ),ab( ka, j2+1 ), inca, & + call stdlib${ii}$_slar2v( 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 + ! start applying rotations in 2_${ik}$nd set from the left do l = ka - 1, kb - k + 1, -1 nrt = ( n-j2+l ) / ka1 - if( nrt>0 )call stdlib_slartv( nrt, ab( l, j2+ka1-l ), inca,ab( l+1, j2+ka1-l & + if( nrt>0_${ik}$ )call stdlib${ii}$_slartv( 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 + ! post-multiply x by product of rotations in 2_${ik}$nd set do j = j2, j1, ka1 - call stdlib_srot( n-m, x( m+1, j ), 1, x( m+1, j+1 ), 1,work( n+j ), work( & + call stdlib${ii}$_srot( n-m, x( m+1, j ), 1_${ik}$, x( m+1, j+1 ), 1_${ik}$,work( n+j ), work( & j ) ) end do end if end do loop_210 do k = 1, kb - 1 - j2 = i - k - 1 + max( 1, k-i0+2 )*ka1 - ! finish applying rotations in 1st set from the left + j2 = i - k - 1_${ik}$ + max( 1_${ik}$, k-i0+2 )*ka1 + ! finish applying rotations in 1_${ik}$st set from the left do l = kb - k, 1, -1 nrt = ( n-j2+l ) / ka1 - if( nrt>0 )call stdlib_slartv( nrt, ab( l, j2+ka1-l ), inca,ab( l+1, j2+ka1-l & + if( nrt>0_${ik}$ )call stdlib${ii}$_slartv( 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 - if( kb>1 ) then + if( kb>1_${ik}$ ) then do j = n - 1, i - kb + 2*ka + 1, -1 work( n+j-m ) = work( n+j-ka-m ) work( j-m ) = work( j-ka-m ) @@ -14795,7 +14797,7 @@ module stdlib_linalg_lapack_s ! transform a, working with the lower triangle if( update ) then ! form inv(s(i))**t * a * inv(s(i)) - bii = bb( 1, i ) + bii = bb( 1_${ik}$, i ) do j = i, i1 ab( j-i+1, i ) = ab( j-i+1, i ) / bii end do @@ -14805,7 +14807,7 @@ module stdlib_linalg_lapack_s 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 )*ab( i-k+1, k ) -bb( i-k+1, & - k )*ab( i-j+1, j ) +ab( 1, i )*bb( i-j+1, j )*bb( i-k+1, k ) + k )*ab( i-j+1, j ) +ab( 1_${ik}$, i )*bb( i-j+1, j )*bb( i-k+1, k ) end do do j = max( 1, i-ka ), i - kbt - 1 ab( k-j+1, j ) = ab( k-j+1, j ) -bb( i-k+1, k )*ab( i-j+1, j ) @@ -14818,8 +14820,8 @@ module stdlib_linalg_lapack_s end do if( wantx ) then ! post-multiply x by inv(s(i)) - call stdlib_sscal( n-m, one / bii, x( m+1, i ), 1 ) - if( kbt>0 )call stdlib_sger( n-m, kbt, -one, x( m+1, i ), 1,bb( kbt+1, i-kbt )& + call stdlib${ii}$_sscal( n-m, one / bii, x( m+1, i ), 1_${ik}$ ) + if( kbt>0_${ik}$ )call stdlib${ii}$_sger( n-m, kbt, -one, x( m+1, i ), 1_${ik}$,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 @@ -14832,9 +14834,9 @@ module stdlib_linalg_lapack_s if( update ) then ! determine the rotations which would annihilate the bulge ! which has in theory just been created - if( i-k+ka1 ) then + if( i-k+ka1_${ik}$ ) then ! generate rotation to annihilate a(i-k+ka+1,i) - call stdlib_slartg( ab( ka1-k, i ), ra1, work( n+i-k+ka-m ),work( i-k+ka-m & + call stdlib${ii}$_slartg( 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) @@ -14845,7 +14847,7 @@ module stdlib_linalg_lapack_s ra1 = ra end if end if - j2 = i - k - 1 + max( 1, k-i0+2 )*ka1 + j2 = i - k - 1_${ik}$ + max( 1_${ik}$, k-i0+2 )*ka1 nr = ( n-j2+ka ) / ka1 j1 = j2 + ( nr-1 )*ka1 if( update ) then @@ -14860,37 +14862,37 @@ module stdlib_linalg_lapack_s work( j-m ) = work( j-m )*ab( ka1, j-ka+1 ) ab( ka1, j-ka+1 ) = work( n+j-m )*ab( ka1, j-ka+1 ) end do - ! generate rotations in 1st set to annihilate elements which + ! generate rotations in 1_${ik}$st set to annihilate elements which ! have been created outside the band - if( nrt>0 )call stdlib_slargv( nrt, ab( ka1, j2t-ka ), inca, work( j2t-m ),ka1, & + if( nrt>0_${ik}$ )call stdlib${ii}$_slargv( 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 + if( nr>0_${ik}$ ) then + ! apply rotations in 1_${ik}$st set from the left do l = 1, ka - 1 - call stdlib_slartv( nr, ab( l+1, j2-l ), inca,ab( l+2, j2-l ), inca, work( & + call stdlib${ii}$_slartv( 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 + ! apply rotations in 1_${ik}$st set from both sides to diagonal ! blocks - call stdlib_slar2v( nr, ab( 1, j2 ), ab( 1, j2+1 ), ab( 2, j2 ),inca, work( n+& + call stdlib${ii}$_slar2v( nr, ab( 1_${ik}$, j2 ), ab( 1_${ik}$, j2+1 ), ab( 2_${ik}$, j2 ),inca, work( n+& j2-m ), work( j2-m ), ka1 ) end if - ! start applying rotations in 1st set from the right + ! start applying rotations in 1_${ik}$st set from the right do l = ka - 1, kb - k + 1, -1 nrt = ( n-j2+l ) / ka1 - if( nrt>0 )call stdlib_slartv( nrt, ab( ka1-l+1, j2 ), inca,ab( ka1-l, j2+1 ),& + if( nrt>0_${ik}$ )call stdlib${ii}$_slartv( 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 + ! post-multiply x by product of rotations in 1_${ik}$st set do j = j2, j1, ka1 - call stdlib_srot( n-m, x( m+1, j ), 1, x( m+1, j+1 ), 1,work( n+j-m ), & + call stdlib${ii}$_srot( n-m, x( m+1, j ), 1_${ik}$, x( m+1, j+1 ), 1_${ik}$,work( n+j-m ), & work( j-m ) ) end do end if end do loop_360 if( update ) then - if( i2<=n .and. kbt>0 ) then + if( i2<=n .and. kbt>0_${ik}$ ) then ! create nonzero element a(i-kbt+ka+1,i-kbt) outside the ! band and store it in work(i-kbt) work( i-kbt ) = -bb( kbt+1, i-kbt )*ra1 @@ -14898,14 +14900,14 @@ module stdlib_linalg_lapack_s end if loop_400: do k = kb, 1, -1 if( update ) then - j2 = i - k - 1 + max( 2, k-i0+1 )*ka1 + j2 = i - k - 1_${ik}$ + max( 2_${ik}$, k-i0+1 )*ka1 else - j2 = i - k - 1 + max( 1, k-i0+1 )*ka1 + j2 = i - k - 1_${ik}$ + max( 1_${ik}$, k-i0+1 )*ka1 end if - ! finish applying rotations in 2nd set from the right + ! finish applying rotations in 2_${ik}$nd set from the right do l = kb - k, 1, -1 nrt = ( n-j2+ka+l ) / ka1 - if( nrt>0 )call stdlib_slartv( nrt, ab( ka1-l+1, j2-ka ), inca,ab( ka1-l, j2-& + if( nrt>0_${ik}$ )call stdlib${ii}$_slartv( 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 @@ -14925,48 +14927,48 @@ module stdlib_linalg_lapack_s end if end do loop_400 loop_440: do k = kb, 1, -1 - j2 = i - k - 1 + max( 1, k-i0+1 )*ka1 + j2 = i - k - 1_${ik}$ + max( 1_${ik}$, k-i0+1 )*ka1 nr = ( n-j2+ka ) / ka1 j1 = j2 + ( nr-1 )*ka1 - if( nr>0 ) then - ! generate rotations in 2nd set to annihilate elements + if( nr>0_${ik}$ ) then + ! generate rotations in 2_${ik}$nd set to annihilate elements ! which have been created outside the band - call stdlib_slargv( nr, ab( ka1, j2-ka ), inca, work( j2 ), ka1,work( n+j2 ), & + call stdlib${ii}$_slargv( nr, ab( ka1, j2-ka ), inca, work( j2 ), ka1,work( n+j2 ), & ka1 ) - ! apply rotations in 2nd set from the left + ! apply rotations in 2_${ik}$nd set from the left do l = 1, ka - 1 - call stdlib_slartv( nr, ab( l+1, j2-l ), inca,ab( l+2, j2-l ), inca, work( & + call stdlib${ii}$_slartv( 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 + ! apply rotations in 2_${ik}$nd set from both sides to diagonal ! blocks - call stdlib_slar2v( nr, ab( 1, j2 ), ab( 1, j2+1 ), ab( 2, j2 ),inca, work( n+& + call stdlib${ii}$_slar2v( nr, ab( 1_${ik}$, j2 ), ab( 1_${ik}$, j2+1 ), ab( 2_${ik}$, j2 ),inca, work( n+& j2 ), work( j2 ), ka1 ) end if - ! start applying rotations in 2nd set from the right + ! start applying rotations in 2_${ik}$nd set from the right do l = ka - 1, kb - k + 1, -1 nrt = ( n-j2+l ) / ka1 - if( nrt>0 )call stdlib_slartv( nrt, ab( ka1-l+1, j2 ), inca,ab( ka1-l, j2+1 ),& + if( nrt>0_${ik}$ )call stdlib${ii}$_slartv( 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 + ! post-multiply x by product of rotations in 2_${ik}$nd set do j = j2, j1, ka1 - call stdlib_srot( n-m, x( m+1, j ), 1, x( m+1, j+1 ), 1,work( n+j ), work( & + call stdlib${ii}$_srot( n-m, x( m+1, j ), 1_${ik}$, x( m+1, j+1 ), 1_${ik}$,work( n+j ), work( & j ) ) end do end if end do loop_440 do k = 1, kb - 1 - j2 = i - k - 1 + max( 1, k-i0+2 )*ka1 - ! finish applying rotations in 1st set from the right + j2 = i - k - 1_${ik}$ + max( 1_${ik}$, k-i0+2 )*ka1 + ! finish applying rotations in 1_${ik}$st set from the right do l = kb - k, 1, -1 nrt = ( n-j2+l ) / ka1 - if( nrt>0 )call stdlib_slartv( nrt, ab( ka1-l+1, j2 ), inca,ab( ka1-l, j2+1 ),& + if( nrt>0_${ik}$ )call stdlib${ii}$_slartv( 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 - if( kb>1 ) then + if( kb>1_${ik}$ ) then do j = n - 1, i - kb + 2*ka + 1, -1 work( n+j-m ) = work( n+j-ka-m ) work( j-m ) = work( j-ka-m ) @@ -14975,7 +14977,7 @@ module stdlib_linalg_lapack_s end if go to 10 480 continue - ! **************************** phase 2 ***************************** + ! **************************** phase 2_${ik}$ ***************************** ! the logical structure of this phase is: ! update = .true. ! do i = 1, m @@ -14988,18 +14990,18 @@ module stdlib_linalg_lapack_s ! end do ! to avoid duplicating code, the two loops are merged. update = .true. - i = 0 + i = 0_${ik}$ 490 continue if( update ) then - i = i + 1 + i = i + 1_${ik}$ kbt = min( kb, m-i ) - i0 = i + 1 - i1 = max( 1, i-ka ) + i0 = i + 1_${ik}$ + i1 = max( 1_${ik}$, i-ka ) i2 = i + kbt - ka1 if( i>m ) then update = .false. - i = i - 1 - i0 = m + 1 + i = i - 1_${ik}$ + i0 = m + 1_${ik}$ if( ka==0 )return go to 490 end if @@ -15042,9 +15044,9 @@ module stdlib_linalg_lapack_s end do if( wantx ) then ! post-multiply x by inv(s(i)) - call stdlib_sscal( nx, one / bii, x( 1, i ), 1 ) - if( kbt>0 )call stdlib_sger( nx, kbt, -one, x( 1, i ), 1, bb( kb, i+1 ),ldbb-& - 1, x( 1, i+1 ), ldx ) + call stdlib${ii}$_sscal( nx, one / bii, x( 1_${ik}$, i ), 1_${ik}$ ) + if( kbt>0_${ik}$ )call stdlib${ii}$_sger( nx, kbt, -one, x( 1_${ik}$, i ), 1_${ik}$, bb( kb, i+1 ),ldbb-& + 1_${ik}$, x( 1_${ik}$, i+1 ), ldx ) end if ! store a(i1,i) in ra1 for use in next loop over k ra1 = ab( i1-i+ka1, i ) @@ -15055,19 +15057,19 @@ module stdlib_linalg_lapack_s if( update ) then ! determine the rotations which would annihilate the bulge ! which has in theory just been created - if( i+k-ka1>0 .and. i+k0_${ik}$ .and. i+k0 )call stdlib_slargv( nrt, ab( 1, j1+ka ), inca, work( j1 ), ka1,work( & + if( nrt>0_${ik}$ )call stdlib${ii}$_slargv( nrt, ab( 1_${ik}$, j1+ka ), inca, work( j1 ), ka1,work( & n+j1 ), ka1 ) - if( nr>0 ) then - ! apply rotations in 1st set from the left + if( nr>0_${ik}$ ) then + ! apply rotations in 1_${ik}$st set from the left do l = 1, ka - 1 - call stdlib_slartv( nr, ab( ka1-l, j1+l ), inca,ab( ka-l, j1+l ), inca, & + call stdlib${ii}$_slartv( 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 + ! apply rotations in 1_${ik}$st set from both sides to diagonal ! blocks - call stdlib_slar2v( nr, ab( ka1, j1 ), ab( ka1, j1-1 ),ab( ka, j1 ), inca, & + call stdlib${ii}$_slar2v( 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 + ! start applying rotations in 1_${ik}$st 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_slartv( nrt, ab( l, j1t ), inca,ab( l+1, j1t-1 ), inca,& + if( nrt>0_${ik}$ )call stdlib${ii}$_slartv( 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 + ! post-multiply x by product of rotations in 1_${ik}$st set do j = j1, j2, ka1 - call stdlib_srot( nx, x( 1, j ), 1, x( 1, j-1 ), 1,work( n+j ), work( j ) ) + call stdlib${ii}$_srot( nx, x( 1_${ik}$, j ), 1_${ik}$, x( 1_${ik}$, j-1 ), 1_${ik}$,work( n+j ), work( j ) ) end do end if end do loop_610 if( update ) then - if( i2>0 .and. kbt>0 ) then + if( i2>0_${ik}$ .and. kbt>0_${ik}$ ) then ! create nonzero element a(i+kbt-ka-1,i+kbt) outside the ! band and store it in work(m-kb+i+kbt) work( m-kb+i+kbt ) = -bb( kb1-kbt, i+kbt )*ra1 @@ -15121,15 +15123,15 @@ module stdlib_linalg_lapack_s end if loop_650: do k = kb, 1, -1 if( update ) then - j2 = i + k + 1 - max( 2, k+i0-m )*ka1 + j2 = i + k + 1_${ik}$ - max( 2_${ik}$, k+i0-m )*ka1 else - j2 = i + k + 1 - max( 1, k+i0-m )*ka1 + j2 = i + k + 1_${ik}$ - max( 1_${ik}$, k+i0-m )*ka1 end if - ! finish applying rotations in 2nd set from the right + ! finish applying rotations in 2_${ik}$nd set from the right do l = kb - k, 1, -1 nrt = ( j2+ka+l-1 ) / ka1 j1t = j2 - ( nrt-1 )*ka1 - if( nrt>0 )call stdlib_slartv( nrt, ab( l, j1t+ka ), inca,ab( l+1, j1t+ka-1 ),& + if( nrt>0_${ik}$ )call stdlib${ii}$_slartv( 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 @@ -15141,58 +15143,58 @@ module stdlib_linalg_lapack_s do j = j1, j2, ka1 ! create nonzero element a(j-1,j+ka) outside the band ! and store it in work(m-kb+j) - work( m-kb+j ) = work( m-kb+j )*ab( 1, j+ka-1 ) - ab( 1, j+ka-1 ) = work( n+m-kb+j )*ab( 1, j+ka-1 ) + work( m-kb+j ) = work( m-kb+j )*ab( 1_${ik}$, j+ka-1 ) + ab( 1_${ik}$, j+ka-1 ) = work( n+m-kb+j )*ab( 1_${ik}$, j+ka-1 ) end do if( update ) then if( i+k>ka1 .and. k<=kbt )work( m-kb+i+k-ka ) = work( m-kb+i+k ) end if end do loop_650 loop_690: do k = kb, 1, -1 - j2 = i + k + 1 - max( 1, k+i0-m )*ka1 + j2 = i + k + 1_${ik}$ - max( 1_${ik}$, k+i0-m )*ka1 nr = ( j2+ka-1 ) / ka1 j1 = j2 - ( nr-1 )*ka1 - if( nr>0 ) then - ! generate rotations in 2nd set to annihilate elements + if( nr>0_${ik}$ ) then + ! generate rotations in 2_${ik}$nd set to annihilate elements ! which have been created outside the band - call stdlib_slargv( nr, ab( 1, j1+ka ), inca, work( m-kb+j1 ),ka1, work( n+m-& + call stdlib${ii}$_slargv( nr, ab( 1_${ik}$, j1+ka ), inca, work( m-kb+j1 ),ka1, work( n+m-& kb+j1 ), ka1 ) - ! apply rotations in 2nd set from the left + ! apply rotations in 2_${ik}$nd set from the left do l = 1, ka - 1 - call stdlib_slartv( nr, ab( ka1-l, j1+l ), inca,ab( ka-l, j1+l ), inca,& + call stdlib${ii}$_slartv( 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 + ! apply rotations in 2_${ik}$nd set from both sides to diagonal ! blocks - call stdlib_slar2v( nr, ab( ka1, j1 ), ab( ka1, j1-1 ),ab( ka, j1 ), inca, & + call stdlib${ii}$_slar2v( 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 + ! start applying rotations in 2_${ik}$nd 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_slartv( nrt, ab( l, j1t ), inca,ab( l+1, j1t-1 ), inca,& + if( nrt>0_${ik}$ )call stdlib${ii}$_slartv( 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 + ! post-multiply x by product of rotations in 2_${ik}$nd set do j = j1, j2, ka1 - call stdlib_srot( nx, x( 1, j ), 1, x( 1, j-1 ), 1,work( n+m-kb+j ), work( & + call stdlib${ii}$_srot( nx, x( 1_${ik}$, j ), 1_${ik}$, x( 1_${ik}$, j-1 ), 1_${ik}$,work( n+m-kb+j ), work( & m-kb+j ) ) end do end if end do loop_690 do k = 1, kb - 1 - j2 = i + k + 1 - max( 1, k+i0-m+1 )*ka1 - ! finish applying rotations in 1st set from the right + j2 = i + k + 1_${ik}$ - max( 1_${ik}$, k+i0-m+1 )*ka1 + ! finish applying rotations in 1_${ik}$st set from the right do l = kb - k, 1, -1 nrt = ( j2+l-1 ) / ka1 j1t = j2 - ( nrt-1 )*ka1 - if( nrt>0 )call stdlib_slartv( nrt, ab( l, j1t ), inca,ab( l+1, j1t-1 ), inca,& + if( nrt>0_${ik}$ )call stdlib${ii}$_slartv( nrt, ab( l, j1t ), inca,ab( l+1, j1t-1 ), inca,& work( n+j1t ),work( j1t ), ka1 ) end do end do - if( kb>1 ) then + if( kb>1_${ik}$ ) then do j = 2, min( i+kb, m ) - 2*ka - 1 work( n+j ) = work( n+j+ka ) work( j ) = work( j+ka ) @@ -15202,7 +15204,7 @@ module stdlib_linalg_lapack_s ! transform a, working with the lower triangle if( update ) then ! form inv(s(i))**t * a * inv(s(i)) - bii = bb( 1, i ) + bii = bb( 1_${ik}$, i ) do j = i1, i ab( i-j+1, j ) = ab( i-j+1, j ) / bii end do @@ -15212,7 +15214,7 @@ module stdlib_linalg_lapack_s 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 )*ab( k-i+1, i ) -bb( k-i+1, & - i )*ab( j-i+1, i ) +ab( 1, i )*bb( j-i+1, i )*bb( k-i+1, i ) + i )*ab( j-i+1, i ) +ab( 1_${ik}$, i )*bb( j-i+1, i )*bb( k-i+1, i ) end do do j = i + kbt + 1, min( n, i+ka ) ab( j-k+1, k ) = ab( j-k+1, k ) -bb( k-i+1, i )*ab( j-i+1, i ) @@ -15225,8 +15227,8 @@ module stdlib_linalg_lapack_s end do if( wantx ) then ! post-multiply x by inv(s(i)) - call stdlib_sscal( nx, one / bii, x( 1, i ), 1 ) - if( kbt>0 )call stdlib_sger( nx, kbt, -one, x( 1, i ), 1, bb( 2, i ), 1,x( 1, & + call stdlib${ii}$_sscal( nx, one / bii, x( 1_${ik}$, i ), 1_${ik}$ ) + if( kbt>0_${ik}$ )call stdlib${ii}$_sger( nx, kbt, -one, x( 1_${ik}$, i ), 1_${ik}$, bb( 2_${ik}$, i ), 1_${ik}$,x( 1_${ik}$, & i+1 ), ldx ) end if ! store a(i,i1) in ra1 for use in next loop over k @@ -15238,9 +15240,9 @@ module stdlib_linalg_lapack_s if( update ) then ! determine the rotations which would annihilate the bulge ! which has in theory just been created - if( i+k-ka1>0 .and. i+k0_${ik}$ .and. i+k0 )call stdlib_slargv( nrt, ab( ka1, j1 ), inca, work( j1 ), ka1,work( n+& + if( nrt>0_${ik}$ )call stdlib${ii}$_slargv( nrt, ab( ka1, j1 ), inca, work( j1 ), ka1,work( n+& j1 ), ka1 ) - if( nr>0 ) then - ! apply rotations in 1st set from the right + if( nr>0_${ik}$ ) then + ! apply rotations in 1_${ik}$st set from the right do l = 1, ka - 1 - call stdlib_slartv( nr, ab( l+1, j1 ), inca, ab( l+2, j1-1 ),inca, work( n+& + call stdlib${ii}$_slartv( 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 + ! apply rotations in 1_${ik}$st set from both sides to diagonal ! blocks - call stdlib_slar2v( nr, ab( 1, j1 ), ab( 1, j1-1 ),ab( 2, j1-1 ), inca, work( & + call stdlib${ii}$_slar2v( nr, ab( 1_${ik}$, j1 ), ab( 1_${ik}$, j1-1 ),ab( 2_${ik}$, j1-1 ), inca, work( & n+j1 ),work( j1 ), ka1 ) end if - ! start applying rotations in 1st set from the left + ! start applying rotations in 1_${ik}$st 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_slartv( nrt, ab( ka1-l+1, j1t-ka1+l ), inca,ab( ka1-l, & + if( nrt>0_${ik}$ )call stdlib${ii}$_slartv( 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 + ! post-multiply x by product of rotations in 1_${ik}$st set do j = j1, j2, ka1 - call stdlib_srot( nx, x( 1, j ), 1, x( 1, j-1 ), 1,work( n+j ), work( j ) ) + call stdlib${ii}$_srot( nx, x( 1_${ik}$, j ), 1_${ik}$, x( 1_${ik}$, j-1 ), 1_${ik}$,work( n+j ), work( j ) ) end do end if end do loop_840 if( update ) then - if( i2>0 .and. kbt>0 ) then + if( i2>0_${ik}$ .and. kbt>0_${ik}$ ) then ! create nonzero element a(i+kbt,i+kbt-ka-1) outside the ! band and store it in work(m-kb+i+kbt) work( m-kb+i+kbt ) = -bb( kbt+1, i )*ra1 @@ -15306,15 +15308,15 @@ module stdlib_linalg_lapack_s end if loop_880: do k = kb, 1, -1 if( update ) then - j2 = i + k + 1 - max( 2, k+i0-m )*ka1 + j2 = i + k + 1_${ik}$ - max( 2_${ik}$, k+i0-m )*ka1 else - j2 = i + k + 1 - max( 1, k+i0-m )*ka1 + j2 = i + k + 1_${ik}$ - max( 1_${ik}$, k+i0-m )*ka1 end if - ! finish applying rotations in 2nd set from the left + ! finish applying rotations in 2_${ik}$nd set from the left do l = kb - k, 1, -1 nrt = ( j2+ka+l-1 ) / ka1 j1t = j2 - ( nrt-1 )*ka1 - if( nrt>0 )call stdlib_slartv( nrt, ab( ka1-l+1, j1t+l-1 ), inca,ab( ka1-l, & + if( nrt>0_${ik}$ )call stdlib${ii}$_slartv( 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 @@ -15334,50 +15336,50 @@ module stdlib_linalg_lapack_s end if end do loop_880 loop_920: do k = kb, 1, -1 - j2 = i + k + 1 - max( 1, k+i0-m )*ka1 + j2 = i + k + 1_${ik}$ - max( 1_${ik}$, k+i0-m )*ka1 nr = ( j2+ka-1 ) / ka1 j1 = j2 - ( nr-1 )*ka1 - if( nr>0 ) then - ! generate rotations in 2nd set to annihilate elements + if( nr>0_${ik}$ ) then + ! generate rotations in 2_${ik}$nd set to annihilate elements ! which have been created outside the band - call stdlib_slargv( nr, ab( ka1, j1 ), inca, work( m-kb+j1 ),ka1, work( n+m-& + call stdlib${ii}$_slargv( nr, ab( ka1, j1 ), inca, work( m-kb+j1 ),ka1, work( n+m-& kb+j1 ), ka1 ) - ! apply rotations in 2nd set from the right + ! apply rotations in 2_${ik}$nd set from the right do l = 1, ka - 1 - call stdlib_slartv( nr, ab( l+1, j1 ), inca, ab( l+2, j1-1 ),inca, work( n+& + call stdlib${ii}$_slartv( 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 + ! apply rotations in 2_${ik}$nd set from both sides to diagonal ! blocks - call stdlib_slar2v( nr, ab( 1, j1 ), ab( 1, j1-1 ),ab( 2, j1-1 ), inca, work( & + call stdlib${ii}$_slar2v( nr, ab( 1_${ik}$, j1 ), ab( 1_${ik}$, j1-1 ),ab( 2_${ik}$, j1-1 ), inca, work( & n+m-kb+j1 ),work( m-kb+j1 ), ka1 ) end if - ! start applying rotations in 2nd set from the left + ! start applying rotations in 2_${ik}$nd 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_slartv( nrt, ab( ka1-l+1, j1t-ka1+l ), inca,ab( ka1-l, & + if( nrt>0_${ik}$ )call stdlib${ii}$_slartv( 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 + ! post-multiply x by product of rotations in 2_${ik}$nd set do j = j1, j2, ka1 - call stdlib_srot( nx, x( 1, j ), 1, x( 1, j-1 ), 1,work( n+m-kb+j ), work( & + call stdlib${ii}$_srot( nx, x( 1_${ik}$, j ), 1_${ik}$, x( 1_${ik}$, j-1 ), 1_${ik}$,work( n+m-kb+j ), work( & m-kb+j ) ) end do end if end do loop_920 do k = 1, kb - 1 - j2 = i + k + 1 - max( 1, k+i0-m+1 )*ka1 - ! finish applying rotations in 1st set from the left + j2 = i + k + 1_${ik}$ - max( 1_${ik}$, k+i0-m+1 )*ka1 + ! finish applying rotations in 1_${ik}$st set from the left do l = kb - k, 1, -1 nrt = ( j2+l-1 ) / ka1 j1t = j2 - ( nrt-1 )*ka1 - if( nrt>0 )call stdlib_slartv( nrt, ab( ka1-l+1, j1t-ka1+l ), inca,ab( ka1-l, & + if( nrt>0_${ik}$ )call stdlib${ii}$_slartv( 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 - if( kb>1 ) then + if( kb>1_${ik}$ ) then do j = 2, min( i+kb, m ) - 2*ka - 1 work( n+j ) = work( n+j+ka ) work( j ) = work( j+ka ) @@ -15385,10 +15387,10 @@ module stdlib_linalg_lapack_s end if end if go to 490 - end subroutine stdlib_ssbgst + end subroutine stdlib${ii}$_ssbgst - pure subroutine stdlib_ssbtrd( vect, uplo, n, kd, ab, ldab, d, e, q, ldq,work, info ) + pure subroutine stdlib${ii}$_ssbtrd( vect, uplo, n, kd, ab, ldab, d, e, q, ldq,work, info ) !! SSBTRD reduces a real symmetric band matrix A to symmetric !! tridiagonal form T by an orthogonal similarity transformation: !! Q**T * A * Q = T. @@ -15397,8 +15399,8 @@ module stdlib_linalg_lapack_s ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: uplo, vect - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: kd, ldab, ldq, n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: kd, ldab, ldq, n ! Array Arguments real(sp), intent(inout) :: ab(ldab,*), q(ldq,*) real(sp), intent(out) :: d(*), e(*), work(*) @@ -15406,7 +15408,7 @@ module stdlib_linalg_lapack_s ! Local Scalars logical(lk) :: initq, upper, wantq - integer(ilp) :: i, i2, ibl, inca, incx, iqaend, iqb, iqend, j, j1, j1end, j1inc, j2, & + integer(${ik}$) :: 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(sp) :: temp ! Intrinsic Functions @@ -15416,32 +15418,32 @@ module stdlib_linalg_lapack_s initq = stdlib_lsame( vect, 'V' ) wantq = initq .or. stdlib_lsame( vect, 'U' ) upper = stdlib_lsame( uplo, 'U' ) - kd1 = kd + 1 - kdm1 = kd - 1 - incx = ldab - 1 - iqend = 1 - info = 0 + kd1 = kd + 1_${ik}$ + kdm1 = kd - 1_${ik}$ + incx = ldab - 1_${ik}$ + iqend = 1_${ik}$ + info = 0_${ik}$ if( .not.wantq .and. .not.stdlib_lsame( vect, 'N' ) ) then - info = -1 + info = -1_${ik}$ else if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then - info = -2 - else if( n<0 ) then - info = -3 - else if( kd<0 ) then - info = -4 + info = -2_${ik}$ + else if( n<0_${ik}$ ) then + info = -3_${ik}$ + else if( kd<0_${ik}$ ) then + info = -4_${ik}$ else if( ldab1 ) then + if( kd>1_${ik}$ ) then ! reduce to tridiagonal form, working with upper triangle - nr = 0 - j1 = kdn + 2 - j2 = 1 + nr = 0_${ik}$ + j1 = kdn + 2_${ik}$ + j2 = 1_${ik}$ loop_90: do i = 1, n - 2 ! reduce i-th row of matrix to tridiagonal form loop_80: do k = kdn + 1, 2, -1 j1 = j1 + kdn j2 = j2 + kdn - if( nr>0 ) then + if( nr>0_${ik}$ ) then ! generate plane rotations to annihilate nonzero ! elements which have been created outside the band - call stdlib_slargv( nr, ab( 1, j1-1 ), inca, work( j1 ),kd1, d( j1 ), & + call stdlib${ii}$_slargv( nr, ab( 1_${ik}$, j1-1 ), inca, work( j1 ),kd1, d( j1 ), & kd1 ) ! apply rotations from the right ! dependent on the the number of diagonals either - ! stdlib_slartv or stdlib_srot is used - if( nr>=2*kd-1 ) then + ! stdlib${ii}$_slartv or stdlib${ii}$_srot is used + if( nr>=2_${ik}$*kd-1 ) then do l = 1, kd - 1 - call stdlib_slartv( nr, ab( l+1, j1-1 ), inca,ab( l, j1 ), inca, & + call stdlib${ii}$_slartv( 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_srot( kdm1, ab( 2, jinc-1 ), 1,ab( 1, jinc ), 1, d( & + call stdlib${ii}$_srot( kdm1, ab( 2_${ik}$, jinc-1 ), 1_${ik}$,ab( 1_${ik}$, jinc ), 1_${ik}$, d( & jinc ),work( jinc ) ) end do end if end if - if( k>2 ) then + if( k>2_${ik}$ ) then if( k<=n-i+1 ) then ! generate plane rotation to annihilate a(i,i+k-1) ! within the band - call stdlib_slartg( ab( kd-k+3, i+k-2 ),ab( kd-k+2, i+k-1 ), d( i+k-& - 1 ),work( i+k-1 ), temp ) + call stdlib${ii}$_slartg( ab( kd-k+3, i+k-2 ),ab( kd-k+2, i+k-1 ), d( i+k-& + 1_${ik}$ ),work( i+k-1 ), temp ) ab( kd-k+3, i+k-2 ) = temp ! apply rotation from the right - call stdlib_srot( k-3, ab( kd-k+4, i+k-2 ), 1,ab( kd-k+3, i+k-1 ), 1,& + call stdlib${ii}$_srot( k-3, ab( kd-k+4, i+k-2 ), 1_${ik}$,ab( kd-k+3, i+k-1 ), 1_${ik}$,& d( i+k-1 ),work( i+k-1 ) ) end if - nr = nr + 1 - j1 = j1 - kdn - 1 + nr = nr + 1_${ik}$ + j1 = j1 - kdn - 1_${ik}$ end if ! apply plane rotations from both sides to diagonal ! blocks - if( nr>0 )call stdlib_slar2v( nr, ab( kd1, j1-1 ), ab( kd1, j1 ),ab( kd, & + if( nr>0_${ik}$ )call stdlib${ii}$_slar2v( 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-10_${ik}$ ) then + if( 2_${ik}$*kd-1n ) then - nrt = nr - 1 + nrt = nr - 1_${ik}$ else nrt = nr end if - if( nrt>0 )call stdlib_slartv( nrt, ab( kd-l, j1+l ), inca,ab( kd-& + if( nrt>0_${ik}$ )call stdlib${ii}$_slartv( 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_srot( kd-1, ab( kd-1, jin+1 ), incx,ab( kd, jin+1 )& + call stdlib${ii}$_srot( 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_srot( lend, ab( kd-1, last+1 ), incx,ab( kd, & + if( lend>0_${ik}$ )call stdlib${ii}$_srot( lend, ab( kd-1, last+1 ), incx,ab( kd, & last+1 ), incx, d( last ),work( last ) ) end if end if @@ -15532,41 +15534,41 @@ module stdlib_linalg_lapack_s ! take advantage of the fact that q was ! initially the identity matrix iqend = max( iqend, j2 ) - i2 = max( 0, k-3 ) - iqaend = 1 + i*kd - if( k==2 )iqaend = iqaend + kd + i2 = max( 0_${ik}$, k-3 ) + iqaend = 1_${ik}$ + i*kd + if( k==2_${ik}$ )iqaend = iqaend + kd iqaend = min( iqaend, iqend ) do j = j1, j2, kd1 ibl = i - i2 / kdm1 - i2 = i2 + 1 - iqb = max( 1, j-ibl ) - nq = 1 + iqaend - iqb + i2 = i2 + 1_${ik}$ + iqb = max( 1_${ik}$, j-ibl ) + nq = 1_${ik}$ + iqaend - iqb iqaend = min( iqaend+kd, iqend ) - call stdlib_srot( nq, q( iqb, j-1 ), 1, q( iqb, j ),1, d( j ), & + call stdlib${ii}$_srot( nq, q( iqb, j-1 ), 1_${ik}$, q( iqb, j ),1_${ik}$, d( j ), & work( j ) ) end do else do j = j1, j2, kd1 - call stdlib_srot( n, q( 1, j-1 ), 1, q( 1, j ), 1,d( j ), work( j & + call stdlib${ii}$_srot( n, q( 1_${ik}$, j-1 ), 1_${ik}$, q( 1_${ik}$, j ), 1_${ik}$,d( j ), work( j & ) ) end do end if end if if( j2+kdn>n ) then ! adjust j2 to keep within the bounds of the matrix - nr = nr - 1 - j2 = j2 - kdn - 1 + nr = nr - 1_${ik}$ + j2 = j2 - kdn - 1_${ik}$ end if do j = j1, j2, kd1 ! create nonzero element a(j-1,j+kd) outside the band ! and store it in work - work( j+kd ) = work( j )*ab( 1, j+kd ) - ab( 1, j+kd ) = d( j )*ab( 1, j+kd ) + work( j+kd ) = work( j )*ab( 1_${ik}$, j+kd ) + ab( 1_${ik}$, j+kd ) = d( j )*ab( 1_${ik}$, j+kd ) end do end do loop_80 end do loop_90 end if - if( kd>0 ) then + if( kd>0_${ik}$ ) then ! copy off-diagonal elements to e do i = 1, n - 1 e( i ) = ab( kd, i+1 ) @@ -15582,81 +15584,81 @@ module stdlib_linalg_lapack_s d( i ) = ab( kd1, i ) end do else - if( kd>1 ) then + if( kd>1_${ik}$ ) then ! reduce to tridiagonal form, working with lower triangle - nr = 0 - j1 = kdn + 2 - j2 = 1 + nr = 0_${ik}$ + j1 = kdn + 2_${ik}$ + j2 = 1_${ik}$ loop_210: do i = 1, n - 2 ! reduce i-th column of matrix to tridiagonal form loop_200: do k = kdn + 1, 2, -1 j1 = j1 + kdn j2 = j2 + kdn - if( nr>0 ) then + if( nr>0_${ik}$ ) then ! generate plane rotations to annihilate nonzero ! elements which have been created outside the band - call stdlib_slargv( nr, ab( kd1, j1-kd1 ), inca,work( j1 ), kd1, d( j1 )& + call stdlib${ii}$_slargv( 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_slartv or stdlib_srot is used - if( nr>2*kd-1 ) then + ! stdlib${ii}$_slartv or stdlib${ii}$_srot is used + if( nr>2_${ik}$*kd-1 ) then do l = 1, kd - 1 - call stdlib_slartv( nr, ab( kd1-l, j1-kd1+l ), inca,ab( kd1-l+1, & + call stdlib${ii}$_slartv( 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_srot( kdm1, ab( kd, jinc-kd ), incx,ab( kd1, jinc-kd )& + call stdlib${ii}$_srot( kdm1, ab( kd, jinc-kd ), incx,ab( kd1, jinc-kd )& , incx,d( jinc ), work( jinc ) ) end do end if end if - if( k>2 ) then + if( k>2_${ik}$ ) then if( k<=n-i+1 ) then ! generate plane rotation to annihilate a(i+k-1,i) ! within the band - call stdlib_slartg( ab( k-1, i ), ab( k, i ),d( i+k-1 ), work( i+k-1 & + call stdlib${ii}$_slartg( 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_srot( k-3, ab( k-2, i+1 ), ldab-1,ab( k-1, i+1 ), ldab-1,& + call stdlib${ii}$_srot( 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 - j1 = j1 - kdn - 1 + nr = nr + 1_${ik}$ + j1 = j1 - kdn - 1_${ik}$ end if ! apply plane rotations from both sides to diagonal ! blocks - if( nr>0 )call stdlib_slar2v( nr, ab( 1, j1-1 ), ab( 1, j1 ),ab( 2, j1-1 ),& + if( nr>0_${ik}$ )call stdlib${ii}$_slar2v( nr, ab( 1_${ik}$, j1-1 ), ab( 1_${ik}$, j1 ),ab( 2_${ik}$, j1-1 ),& inca, d( j1 ),work( j1 ), kd1 ) ! apply plane rotations from the right ! dependent on the the number of diagonals either - ! stdlib_slartv or stdlib_srot is used - if( nr>0 ) then - if( nr>2*kd-1 ) then + ! stdlib${ii}$_slartv or stdlib${ii}$_srot is used + if( nr>0_${ik}$ ) then + if( nr>2_${ik}$*kd-1 ) then do l = 1, kd - 1 if( j2+l>n ) then - nrt = nr - 1 + nrt = nr - 1_${ik}$ else nrt = nr end if - if( nrt>0 )call stdlib_slartv( nrt, ab( l+2, j1-1 ), inca,ab( l+1,& + if( nrt>0_${ik}$ )call stdlib${ii}$_slartv( 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_srot( kdm1, ab( 3, j1inc-1 ), 1,ab( 2, j1inc ), 1, & + call stdlib${ii}$_srot( kdm1, ab( 3_${ik}$, j1inc-1 ), 1_${ik}$,ab( 2_${ik}$, j1inc ), 1_${ik}$, & d( j1inc ),work( j1inc ) ) end do end if lend = min( kdm1, n-j2 ) last = j1end + kd1 - if( lend>0 )call stdlib_srot( lend, ab( 3, last-1 ), 1,ab( 2, last ),& - 1, d( last ),work( last ) ) + if( lend>0_${ik}$ )call stdlib${ii}$_srot( lend, ab( 3_${ik}$, last-1 ), 1_${ik}$,ab( 2_${ik}$, last ),& + 1_${ik}$, d( last ),work( last ) ) end if end if if( wantq ) then @@ -15665,30 +15667,30 @@ module stdlib_linalg_lapack_s ! take advantage of the fact that q was ! initially the identity matrix iqend = max( iqend, j2 ) - i2 = max( 0, k-3 ) - iqaend = 1 + i*kd - if( k==2 )iqaend = iqaend + kd + i2 = max( 0_${ik}$, k-3 ) + iqaend = 1_${ik}$ + i*kd + if( k==2_${ik}$ )iqaend = iqaend + kd iqaend = min( iqaend, iqend ) do j = j1, j2, kd1 ibl = i - i2 / kdm1 - i2 = i2 + 1 - iqb = max( 1, j-ibl ) - nq = 1 + iqaend - iqb + i2 = i2 + 1_${ik}$ + iqb = max( 1_${ik}$, j-ibl ) + nq = 1_${ik}$ + iqaend - iqb iqaend = min( iqaend+kd, iqend ) - call stdlib_srot( nq, q( iqb, j-1 ), 1, q( iqb, j ),1, d( j ), & + call stdlib${ii}$_srot( nq, q( iqb, j-1 ), 1_${ik}$, q( iqb, j ),1_${ik}$, d( j ), & work( j ) ) end do else do j = j1, j2, kd1 - call stdlib_srot( n, q( 1, j-1 ), 1, q( 1, j ), 1,d( j ), work( j & + call stdlib${ii}$_srot( n, q( 1_${ik}$, j-1 ), 1_${ik}$, q( 1_${ik}$, j ), 1_${ik}$,d( j ), work( j & ) ) end do end if end if if( j2+kdn>n ) then ! adjust j2 to keep within the bounds of the matrix - nr = nr - 1 - j2 = j2 - kdn - 1 + nr = nr - 1_${ik}$ + j2 = j2 - kdn - 1_${ik}$ end if do j = j1, j2, kd1 ! create nonzero element a(j+kd,j-1) outside the @@ -15699,10 +15701,10 @@ module stdlib_linalg_lapack_s end do loop_200 end do loop_210 end if - if( kd>0 ) then + if( kd>0_${ik}$ ) then ! copy off-diagonal elements to e do i = 1, n - 1 - e( i ) = ab( 2, i ) + e( i ) = ab( 2_${ik}$, i ) end do else ! set e to zero if original matrix was diagonal @@ -15712,15 +15714,15 @@ module stdlib_linalg_lapack_s end if ! copy diagonal elements to d do i = 1, n - d( i ) = ab( 1, i ) + d( i ) = ab( 1_${ik}$, i ) end do end if return - end subroutine stdlib_ssbtrd + end subroutine stdlib${ii}$_ssbtrd - pure subroutine stdlib_ssfrk( transr, uplo, trans, n, k, alpha, a, lda, beta,c ) - !! Level 3 BLAS like routine for C in RFP Format. + pure subroutine stdlib${ii}$_ssfrk( transr, uplo, trans, n, k, alpha, a, lda, beta,c ) + !! Level 3_${ik}$ BLAS like routine for C in RFP Format. !! SSFRK performs one of the symmetric rank--k operations !! C := alpha*A*A**T + beta*C, !! or @@ -15733,7 +15735,7 @@ module stdlib_linalg_lapack_s ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments real(sp), intent(in) :: alpha, beta - integer(ilp), intent(in) :: k, lda, n + integer(${ik}$), intent(in) :: k, lda, n character, intent(in) :: trans, transr, uplo ! Array Arguments real(sp), intent(in) :: a(lda,*) @@ -15742,12 +15744,12 @@ module stdlib_linalg_lapack_s ! Local Scalars logical(lk) :: lower, normaltransr, nisodd, notrans - integer(ilp) :: info, nrowa, j, nk, n1, n2 + integer(${ik}$) :: info, nrowa, j, nk, n1, n2 ! Intrinsic Functions intrinsic :: max ! Executable Statements ! test the input parameters. - info = 0 + info = 0_${ik}$ normaltransr = stdlib_lsame( transr, 'N' ) lower = stdlib_lsame( uplo, 'L' ) notrans = stdlib_lsame( trans, 'N' ) @@ -15757,26 +15759,26 @@ module stdlib_linalg_lapack_s nrowa = k end if if( .not.normaltransr .and. .not.stdlib_lsame( transr, 'T' ) ) then - info = -1 + info = -1_${ik}$ else if( .not.lower .and. .not.stdlib_lsame( uplo, 'U' ) ) then - info = -2 + info = -2_${ik}$ else if( .not.notrans .and. .not.stdlib_lsame( trans, 'T' ) ) then - info = -3 - else if( n<0 ) then - info = -4 - else if( k<0 ) then - info = -5 - else if( lda3 ) then - info = -1 + if( itype<1_${ik}$ .or. itype>3_${ik}$ ) then + info = -1_${ik}$ else if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then - info = -2 - else if( n<0 ) then - info = -3 + info = -2_${ik}$ + else if( n<0_${ik}$ ) then + info = -3_${ik}$ end if - if( info/=0 ) then - call stdlib_xerbla( 'SSPGST', -info ) + if( info/=0_${ik}$ ) then + call stdlib${ii}$_xerbla( 'SSPGST', -info ) return end if - if( itype==1 ) then + if( itype==1_${ik}$ ) then if( upper ) then ! compute inv(u**t)*a*inv(u) - ! j1 and jj are the indices of a(1,j) and a(j,j) - jj = 0 + ! j1 and jj are the indices of a(1_${ik}$,j) and a(j,j) + jj = 0_${ik}$ do j = 1, n - j1 = jj + 1 + j1 = jj + 1_${ik}$ jj = jj + j ! compute the j-th column of the upper triangle of a bjj = bp( jj ) - call stdlib_stpsv( uplo, 'TRANSPOSE', 'NONUNIT', j, bp,ap( j1 ), 1 ) - call stdlib_sspmv( uplo, j-1, -one, ap, bp( j1 ), 1, one,ap( j1 ), 1 ) - call stdlib_sscal( j-1, one / bjj, ap( j1 ), 1 ) - ap( jj ) = ( ap( jj )-stdlib_sdot( j-1, ap( j1 ), 1, bp( j1 ),1 ) ) / & + call stdlib${ii}$_stpsv( uplo, 'TRANSPOSE', 'NONUNIT', j, bp,ap( j1 ), 1_${ik}$ ) + call stdlib${ii}$_sspmv( uplo, j-1, -one, ap, bp( j1 ), 1_${ik}$, one,ap( j1 ), 1_${ik}$ ) + call stdlib${ii}$_sscal( j-1, one / bjj, ap( j1 ), 1_${ik}$ ) + ap( jj ) = ( ap( jj )-stdlib${ii}$_sdot( j-1, ap( j1 ), 1_${ik}$, bp( j1 ),1_${ik}$ ) ) / & bjj end do else ! compute inv(l)*a*inv(l**t) ! kk and k1k1 are the indices of a(k,k) and a(k+1,k+1) - kk = 1 + kk = 1_${ik}$ do k = 1, n - k1k1 = kk + n - k + 1 + k1k1 = kk + n - k + 1_${ik}$ ! update the lower triangle of a(k:n,k:n) akk = ap( kk ) bkk = bp( kk ) - akk = akk / bkk**2 + akk = akk / bkk**2_${ik}$ ap( kk ) = akk if( k1 ) then - imax = stdlib_isamax( k-1, ap( kc ), 1 ) + if( k>1_${ik}$ ) then + imax = stdlib${ii}$_isamax( k-1, ap( kc ), 1_${ik}$ ) colmax = abs( ap( kc+imax-1 ) ) else colmax = zero end if if( max( absakk, colmax )==zero ) then ! column k is zero: set info and continue - if( info==0 )info = k + if( info==0_${ik}$ )info = k kp = k else if( absakk>=alpha*colmax ) then - ! no interchange, use 1-by-1 pivot block + ! no interchange, use 1_${ik}$-by-1 pivot block kp = k else rowmax = zero jmax = imax - kx = imax*( imax+1 ) / 2 + imax + kx = imax*( imax+1 ) / 2_${ik}$ + imax do j = imax + 1, k if( abs( ap( kx ) )>rowmax ) then rowmax = abs( ap( kx ) ) @@ -16182,34 +16184,34 @@ module stdlib_linalg_lapack_s end if kx = kx + j end do - kpc = ( imax-1 )*imax / 2 + 1 - if( imax>1 ) then - jmax = stdlib_isamax( imax-1, ap( kpc ), 1 ) + kpc = ( imax-1 )*imax / 2_${ik}$ + 1_${ik}$ + if( imax>1_${ik}$ ) then + jmax = stdlib${ii}$_isamax( imax-1, ap( kpc ), 1_${ik}$ ) rowmax = max( rowmax, abs( ap( kpc+jmax-1 ) ) ) end if if( absakk>=alpha*colmax*( colmax / rowmax ) ) then - ! no interchange, use 1-by-1 pivot block + ! no interchange, use 1_${ik}$-by-1 pivot block kp = k else if( abs( ap( kpc+imax-1 ) )>=alpha*rowmax ) then - ! interchange rows and columns k and imax, use 1-by-1 + ! interchange rows and columns k and imax, use 1_${ik}$-by-1 ! pivot block kp = imax else - ! interchange rows and columns k-1 and imax, use 2-by-2 + ! interchange rows and columns k-1 and imax, use 2_${ik}$-by-2 ! pivot block kp = imax - kstep = 2 + kstep = 2_${ik}$ end if end if - kk = k - kstep + 1 - if( kstep==2 )knc = knc - k + 1 + kk = k - kstep + 1_${ik}$ + if( kstep==2_${ik}$ )knc = knc - k + 1_${ik}$ if( kp/=kk ) then ! interchange rows and columns kk and kp in the leading - ! submatrix a(1:k,1:k) - call stdlib_sswap( kp-1, ap( knc ), 1, ap( kpc ), 1 ) - kx = kpc + kp - 1 + ! submatrix a(1_${ik}$:k,1_${ik}$:k) + call stdlib${ii}$_sswap( kp-1, ap( knc ), 1_${ik}$, ap( kpc ), 1_${ik}$ ) + kx = kpc + kp - 1_${ik}$ do j = kp + 1, kk - 1 - kx = kx + j - 1 + kx = kx + j - 1_${ik}$ t = ap( knc+j-1 ) ap( knc+j-1 ) = ap( kx ) ap( kx ) = t @@ -16217,54 +16219,54 @@ module stdlib_linalg_lapack_s t = ap( knc+kk-1 ) ap( knc+kk-1 ) = ap( kpc+kp-1 ) ap( kpc+kp-1 ) = t - if( kstep==2 ) then + if( kstep==2_${ik}$ ) then t = ap( kc+k-2 ) ap( kc+k-2 ) = ap( kc+kp-1 ) ap( kc+kp-1 ) = t end if end if ! update the leading submatrix - if( kstep==1 ) then - ! 1-by-1 pivot block d(k): column k now holds + if( kstep==1_${ik}$ ) then + ! 1_${ik}$-by-1 pivot block d(k): column k now holds ! w(k) = u(k)*d(k) ! where u(k) is the k-th column of u - ! 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 + ! perform a rank-1 update of a(1_${ik}$:k-1,1_${ik}$:k-1) as + ! a := a - u(k)*d(k)*u(k)**t = a - w(k)*1_${ik}$/d(k)*w(k)**t r1 = one / ap( kc+k-1 ) - call stdlib_sspr( uplo, k-1, -r1, ap( kc ), 1, ap ) + call stdlib${ii}$_sspr( uplo, k-1, -r1, ap( kc ), 1_${ik}$, ap ) ! store u(k) in column k - call stdlib_sscal( k-1, r1, ap( kc ), 1 ) + call stdlib${ii}$_sscal( k-1, r1, ap( kc ), 1_${ik}$ ) else - ! 2-by-2 pivot block d(k): columns k and k-1 now hold + ! 2_${ik}$-by-2 pivot block d(k): columns k and k-1 now hold ! ( w(k-1) w(k) ) = ( u(k-1) u(k) )*d(k) ! where u(k) and u(k-1) are the k-th and (k-1)-th columns ! of u - ! perform a rank-2 update of a(1:k-2,1:k-2) as + ! perform a rank-2 update of a(1_${ik}$:k-2,1_${ik}$:k-2) as ! a := a - ( u(k-1) u(k) )*d(k)*( u(k-1) u(k) )**t ! = a - ( w(k-1) w(k) )*inv(d(k))*( w(k-1) w(k) )**t - if( k>2 ) then - d12 = ap( k-1+( k-1 )*k / 2 ) - d22 = ap( k-1+( k-2 )*( k-1 ) / 2 ) / d12 - d11 = ap( k+( k-1 )*k / 2 ) / d12 + if( k>2_${ik}$ ) then + d12 = ap( k-1+( k-1 )*k / 2_${ik}$ ) + d22 = ap( k-1+( k-2 )*( k-1 ) / 2_${ik}$ ) / d12 + d11 = ap( k+( k-1 )*k / 2_${ik}$ ) / d12 t = one / ( d11*d22-one ) d12 = t / d12 do j = k - 2, 1, -1 - wkm1 = d12*( d11*ap( j+( k-2 )*( k-1 ) / 2 )-ap( j+( k-1 )*k / 2 ) ) + wkm1 = d12*( d11*ap( j+( k-2 )*( k-1 ) / 2_${ik}$ )-ap( j+( k-1 )*k / 2_${ik}$ ) ) - wk = d12*( d22*ap( j+( k-1 )*k / 2 )-ap( j+( k-2 )*( k-1 ) / 2 ) ) + wk = d12*( d22*ap( j+( k-1 )*k / 2_${ik}$ )-ap( j+( k-2 )*( k-1 ) / 2_${ik}$ ) ) do i = j, 1, -1 - ap( i+( j-1 )*j / 2 ) = ap( i+( j-1 )*j / 2 ) -ap( i+( k-1 )*k / 2 )& - *wk -ap( i+( k-2 )*( k-1 ) / 2 )*wkm1 + ap( i+( j-1 )*j / 2_${ik}$ ) = ap( i+( j-1 )*j / 2_${ik}$ ) -ap( i+( k-1 )*k / 2_${ik}$ )& + *wk -ap( i+( k-2 )*( k-1 ) / 2_${ik}$ )*wkm1 end do - ap( j+( k-1 )*k / 2 ) = wk - ap( j+( k-2 )*( k-1 ) / 2 ) = wkm1 + ap( j+( k-1 )*k / 2_${ik}$ ) = wk + ap( j+( k-2 )*( k-1 ) / 2_${ik}$ ) = wkm1 end do end if end if end if ! store details of the interchanges in ipiv - if( kstep==1 ) then + if( kstep==1_${ik}$ ) then ipiv( k ) = kp else ipiv( k ) = -kp @@ -16276,34 +16278,34 @@ module stdlib_linalg_lapack_s go to 10 else ! factorize a as l*d*l**t using the lower triangle of a - ! k is the main loop index, increasing from 1 to n in steps of - ! 1 or 2 - k = 1 - kc = 1 - npp = n*( n+1 ) / 2 + ! k is the main loop index, increasing from 1_${ik}$ to n in steps of + ! 1_${ik}$ or 2_${ik}$ + k = 1_${ik}$ + kc = 1_${ik}$ + npp = n*( n+1 ) / 2_${ik}$ 60 continue knc = kc ! if k > n, exit from loop if( k>n )go to 110 - kstep = 1 + kstep = 1_${ik}$ ! determine rows and columns to be interchanged and whether - ! a 1-by-1 or 2-by-2 pivot block will be used + ! a 1_${ik}$-by-1 or 2_${ik}$-by-2 pivot block will be used absakk = abs( ap( kc ) ) ! 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 + ! no interchange, use 1_${ik}$-by-1 pivot block kp = k else ! jmax is the column-index of the largest off-diagonal @@ -16317,35 +16319,35 @@ module stdlib_linalg_lapack_s end if kx = kx + n - j end do - kpc = npp - ( n-imax+1 )*( n-imax+2 ) / 2 + 1 + kpc = npp - ( n-imax+1 )*( n-imax+2 ) / 2_${ik}$ + 1_${ik}$ if( imax=alpha*colmax*( colmax / rowmax ) ) then - ! no interchange, use 1-by-1 pivot block + ! no interchange, use 1_${ik}$-by-1 pivot block kp = k else if( abs( ap( kpc ) )>=alpha*rowmax ) then - ! interchange rows and columns k and imax, use 1-by-1 + ! interchange rows and columns k and imax, use 1_${ik}$-by-1 ! pivot block kp = imax else - ! interchange rows and columns k+1 and imax, use 2-by-2 + ! interchange rows and columns k+1 and imax, use 2_${ik}$-by-2 ! pivot block kp = imax - kstep = 2 + kstep = 2_${ik}$ end if end if - kk = k + kstep - 1 - if( kstep==2 )knc = knc + n - k + 1 + kk = k + kstep - 1_${ik}$ + if( kstep==2_${ik}$ )knc = knc + n - k + 1_${ik}$ if( kp/=kk ) then ! interchange rows and columns kk and kp in the trailing ! submatrix a(k:n,k:n) - if( kp0 .and. ap( kp )==zero )return kp = kp - info end do else ! lower triangular storage: examine d from top to bottom. - kp = 1 + kp = 1_${ik}$ do info = 1, n if( ipiv( info )>0 .and. ap( kp )==zero )return - kp = kp + n - info + 1 + kp = kp + n - info + 1_${ik}$ end do end if - info = 0 + info = 0_${ik}$ if( upper ) then ! compute inv(a) from the factorization a = u*d*u**t. - ! k is the main loop index, increasing from 1 to n in steps of - ! 1 or 2, depending on the size of the diagonal blocks. - k = 1 - kc = 1 + ! k is the main loop index, increasing from 1_${ik}$ to n in steps of + ! 1_${ik}$ or 2_${ik}$, depending on the size of the diagonal blocks. + k = 1_${ik}$ + kc = 1_${ik}$ 30 continue ! if k > n, exit from loop. if( k>n )go to 50 kcnext = kc + k - if( ipiv( k )>0 ) then - ! 1 x 1 diagonal block + if( ipiv( k )>0_${ik}$ ) then + ! 1_${ik}$ x 1_${ik}$ diagonal block ! invert the diagonal block. ap( kc+k-1 ) = one / ap( kc+k-1 ) ! compute column k of the inverse. - if( k>1 ) then - call stdlib_scopy( k-1, ap( kc ), 1, work, 1 ) - call stdlib_sspmv( uplo, k-1, -one, ap, work, 1, zero, ap( kc ),1 ) - ap( kc+k-1 ) = ap( kc+k-1 ) -stdlib_sdot( k-1, work, 1, ap( kc ), 1 ) + if( k>1_${ik}$ ) then + call stdlib${ii}$_scopy( k-1, ap( kc ), 1_${ik}$, work, 1_${ik}$ ) + call stdlib${ii}$_sspmv( uplo, k-1, -one, ap, work, 1_${ik}$, zero, ap( kc ),1_${ik}$ ) + ap( kc+k-1 ) = ap( kc+k-1 ) -stdlib${ii}$_sdot( k-1, work, 1_${ik}$, ap( kc ), 1_${ik}$ ) end if - kstep = 1 + kstep = 1_${ik}$ else - ! 2 x 2 diagonal block + ! 2_${ik}$ x 2_${ik}$ diagonal block ! invert the diagonal block. t = abs( ap( kcnext+k-1 ) ) ak = ap( kc+k-1 ) / t @@ -16508,30 +16510,30 @@ module stdlib_linalg_lapack_s ap( kcnext+k ) = ak / d ap( kcnext+k-1 ) = -akkp1 / d ! compute columns k and k+1 of the inverse. - if( k>1 ) then - call stdlib_scopy( k-1, ap( kc ), 1, work, 1 ) - call stdlib_sspmv( uplo, k-1, -one, ap, work, 1, zero, ap( kc ),1 ) - ap( kc+k-1 ) = ap( kc+k-1 ) -stdlib_sdot( k-1, work, 1, ap( kc ), 1 ) - ap( kcnext+k-1 ) = ap( kcnext+k-1 ) -stdlib_sdot( k-1, ap( kc ), 1, ap( & - kcnext ),1 ) - call stdlib_scopy( k-1, ap( kcnext ), 1, work, 1 ) - call stdlib_sspmv( uplo, k-1, -one, ap, work, 1, zero,ap( kcnext ), 1 ) + if( k>1_${ik}$ ) then + call stdlib${ii}$_scopy( k-1, ap( kc ), 1_${ik}$, work, 1_${ik}$ ) + call stdlib${ii}$_sspmv( uplo, k-1, -one, ap, work, 1_${ik}$, zero, ap( kc ),1_${ik}$ ) + ap( kc+k-1 ) = ap( kc+k-1 ) -stdlib${ii}$_sdot( k-1, work, 1_${ik}$, ap( kc ), 1_${ik}$ ) + ap( kcnext+k-1 ) = ap( kcnext+k-1 ) -stdlib${ii}$_sdot( k-1, ap( kc ), 1_${ik}$, ap( & + kcnext ),1_${ik}$ ) + call stdlib${ii}$_scopy( k-1, ap( kcnext ), 1_${ik}$, work, 1_${ik}$ ) + call stdlib${ii}$_sspmv( uplo, k-1, -one, ap, work, 1_${ik}$, zero,ap( kcnext ), 1_${ik}$ ) - ap( kcnext+k ) = ap( kcnext+k ) -stdlib_sdot( k-1, work, 1, ap( kcnext ), 1 ) + ap( kcnext+k ) = ap( kcnext+k ) -stdlib${ii}$_sdot( k-1, work, 1_${ik}$, ap( kcnext ), 1_${ik}$ ) end if - kstep = 2 - kcnext = kcnext + k + 1 + kstep = 2_${ik}$ + kcnext = kcnext + k + 1_${ik}$ end if kp = abs( ipiv( k ) ) if( kp/=k ) then ! interchange rows and columns k and kp in the leading - ! submatrix a(1:k+1,1:k+1) - kpc = ( kp-1 )*kp / 2 + 1 - call stdlib_sswap( kp-1, ap( kc ), 1, ap( kpc ), 1 ) - kx = kpc + kp - 1 + ! submatrix a(1_${ik}$:k+1,1_${ik}$:k+1) + kpc = ( kp-1 )*kp / 2_${ik}$ + 1_${ik}$ + call stdlib${ii}$_sswap( kp-1, ap( kc ), 1_${ik}$, ap( kpc ), 1_${ik}$ ) + kx = kpc + kp - 1_${ik}$ do j = kp + 1, k - 1 - kx = kx + j - 1 + kx = kx + j - 1_${ik}$ temp = ap( kc+j-1 ) ap( kc+j-1 ) = ap( kx ) ap( kx ) = temp @@ -16539,7 +16541,7 @@ module stdlib_linalg_lapack_s temp = ap( kc+k-1 ) ap( kc+k-1 ) = ap( kpc+kp-1 ) ap( kpc+kp-1 ) = temp - if( kstep==2 ) then + if( kstep==2_${ik}$ ) then temp = ap( kc+k+k-1 ) ap( kc+k+k-1 ) = ap( kc+k+kp-1 ) ap( kc+k+kp-1 ) = temp @@ -16551,29 +16553,29 @@ module stdlib_linalg_lapack_s 50 continue else ! compute inv(a) from the factorization a = l*d*l**t. - ! k is the main loop index, increasing from 1 to n in steps of - ! 1 or 2, depending on the size of the diagonal blocks. - npp = n*( n+1 ) / 2 + ! k is the main loop index, increasing from 1_${ik}$ to n in steps of + ! 1_${ik}$ or 2_${ik}$, depending on the size of the diagonal blocks. + npp = n*( n+1 ) / 2_${ik}$ k = n kc = npp 60 continue ! if k < 1, exit from loop. if( k<1 )go to 80 kcnext = kc - ( n-k+2 ) - if( ipiv( k )>0 ) then - ! 1 x 1 diagonal block + if( ipiv( k )>0_${ik}$ ) then + ! 1_${ik}$ x 1_${ik}$ diagonal block ! invert the diagonal block. ap( kc ) = one / ap( kc ) ! compute column k of the inverse. if( k0 ) then - ! 1 x 1 diagonal block + if( ipiv( k )>0_${ik}$ ) then + ! 1_${ik}$ x 1_${ik}$ diagonal block ! interchange rows k and ipiv(k). kp = ipiv( k ) - if( kp/=k )call stdlib_sswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib${ii}$_sswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) ! multiply by inv(u(k)), where u(k) is the transformation ! stored in column k of a. - call stdlib_sger( k-1, nrhs, -one, ap( kc ), 1, b( k, 1 ), ldb,b( 1, 1 ), ldb ) + call stdlib${ii}$_sger( k-1, nrhs, -one, ap( kc ), 1_${ik}$, b( k, 1_${ik}$ ), ldb,b( 1_${ik}$, 1_${ik}$ ), ldb ) ! multiply by the inverse of the diagonal block. - call stdlib_sscal( nrhs, one / ap( kc+k-1 ), b( k, 1 ), ldb ) - k = k - 1 + call stdlib${ii}$_sscal( nrhs, one / ap( kc+k-1 ), b( k, 1_${ik}$ ), ldb ) + k = k - 1_${ik}$ else - ! 2 x 2 diagonal block + ! 2_${ik}$ x 2_${ik}$ diagonal block ! interchange rows k-1 and -ipiv(k). kp = -ipiv( k ) - if( kp/=k-1 )call stdlib_sswap( nrhs, b( k-1, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k-1 )call stdlib${ii}$_sswap( nrhs, b( k-1, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) ! multiply by inv(u(k)), where u(k) is the transformation ! stored in columns k-1 and k of a. - call stdlib_sger( k-2, nrhs, -one, ap( kc ), 1, b( k, 1 ), ldb,b( 1, 1 ), ldb ) + call stdlib${ii}$_sger( k-2, nrhs, -one, ap( kc ), 1_${ik}$, b( k, 1_${ik}$ ), ldb,b( 1_${ik}$, 1_${ik}$ ), ldb ) - call stdlib_sger( k-2, nrhs, -one, ap( kc-( k-1 ) ), 1,b( k-1, 1 ), ldb, b( 1, 1 & + call stdlib${ii}$_sger( k-2, nrhs, -one, ap( kc-( k-1 ) ), 1_${ik}$,b( k-1, 1_${ik}$ ), ldb, b( 1_${ik}$, 1_${ik}$ & ), ldb ) ! multiply by the inverse of the diagonal block. akm1k = ap( kc+k-2 ) @@ -16717,81 +16719,81 @@ module stdlib_linalg_lapack_s b( k-1, j ) = ( ak*bkm1-bk ) / denom b( k, j ) = ( akm1*bk-bkm1 ) / denom end do - kc = kc - k + 1 - k = k - 2 + kc = kc - k + 1_${ik}$ + k = k - 2_${ik}$ end if go to 10 30 continue ! next solve u**t*x = b, overwriting b with x. - ! k is the main loop index, increasing from 1 to n in steps of - ! 1 or 2, depending on the size of the diagonal blocks. - k = 1 - kc = 1 + ! k is the main loop index, increasing from 1_${ik}$ to n in steps of + ! 1_${ik}$ or 2_${ik}$, depending on the size of the diagonal blocks. + k = 1_${ik}$ + kc = 1_${ik}$ 40 continue ! if k > n, exit from loop. if( k>n )go to 50 - if( ipiv( k )>0 ) then - ! 1 x 1 diagonal block + if( ipiv( k )>0_${ik}$ ) then + ! 1_${ik}$ x 1_${ik}$ diagonal block ! multiply by inv(u**t(k)), where u(k) is the transformation ! stored in column k of a. - call stdlib_sgemv( 'TRANSPOSE', k-1, nrhs, -one, b, ldb, ap( kc ),1, one, b( k, & - 1 ), ldb ) + call stdlib${ii}$_sgemv( 'TRANSPOSE', k-1, nrhs, -one, b, ldb, ap( kc ),1_${ik}$, one, b( k, & + 1_${ik}$ ), ldb ) ! interchange rows k and ipiv(k). kp = ipiv( k ) - if( kp/=k )call stdlib_sswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib${ii}$_sswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) kc = kc + k - k = k + 1 + k = k + 1_${ik}$ else - ! 2 x 2 diagonal block + ! 2_${ik}$ x 2_${ik}$ diagonal block ! multiply by inv(u**t(k+1)), where u(k+1) is the transformation ! stored in columns k and k+1 of a. - call stdlib_sgemv( 'TRANSPOSE', k-1, nrhs, -one, b, ldb, ap( kc ),1, one, b( k, & - 1 ), ldb ) - call stdlib_sgemv( 'TRANSPOSE', k-1, nrhs, -one, b, ldb,ap( kc+k ), 1, one, b( k+& - 1, 1 ), ldb ) + call stdlib${ii}$_sgemv( 'TRANSPOSE', k-1, nrhs, -one, b, ldb, ap( kc ),1_${ik}$, one, b( k, & + 1_${ik}$ ), ldb ) + call stdlib${ii}$_sgemv( 'TRANSPOSE', k-1, nrhs, -one, b, ldb,ap( kc+k ), 1_${ik}$, one, b( k+& + 1_${ik}$, 1_${ik}$ ), ldb ) ! interchange rows k and -ipiv(k). kp = -ipiv( k ) - if( kp/=k )call stdlib_sswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) - kc = kc + 2*k + 1 - k = k + 2 + if( kp/=k )call stdlib${ii}$_sswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) + kc = kc + 2_${ik}$*k + 1_${ik}$ + k = k + 2_${ik}$ end if go to 40 50 continue else ! solve a*x = b, where a = l*d*l**t. ! first solve l*d*x = b, overwriting b with x. - ! k is the main loop index, increasing from 1 to n in steps of - ! 1 or 2, depending on the size of the diagonal blocks. - k = 1 - kc = 1 + ! k is the main loop index, increasing from 1_${ik}$ to n in steps of + ! 1_${ik}$ or 2_${ik}$, depending on the size of the diagonal blocks. + k = 1_${ik}$ + kc = 1_${ik}$ 60 continue ! if k > n, exit from loop. if( k>n )go to 80 - if( ipiv( k )>0 ) then - ! 1 x 1 diagonal block + if( ipiv( k )>0_${ik}$ ) then + ! 1_${ik}$ x 1_${ik}$ diagonal block ! interchange rows k and ipiv(k). kp = ipiv( k ) - if( kp/=k )call stdlib_sswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib${ii}$_sswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) ! multiply by inv(l(k)), where l(k) is the transformation ! stored in column k of a. - if( k0 ) then - ! 1 x 1 diagonal block + if( ipiv( k )>0_${ik}$ ) then + ! 1_${ik}$ x 1_${ik}$ diagonal block ! multiply by inv(l**t(k)), where l(k) is the transformation ! stored in column k of a. - if( k=vu ) info = -5 - else if( irange==3 .and. ( il<1 .or. il>max( 1, n ) ) )then - info = -6 - else if( irange==3 .and. ( iun ) )then - info = -7 - end if - if( info/=0 ) then - call stdlib_xerbla( 'SSTEBZ', -info ) + if( irange<=0_${ik}$ ) then + info = -1_${ik}$ + else if( iorder<=0_${ik}$ ) then + info = -2_${ik}$ + else if( n<0_${ik}$ ) then + info = -3_${ik}$ + else if( irange==2_${ik}$ ) then + if( vl>=vu ) info = -5_${ik}$ + else if( irange==3_${ik}$ .and. ( il<1_${ik}$ .or. il>max( 1_${ik}$, n ) ) )then + info = -6_${ik}$ + else if( irange==3_${ik}$ .and. ( iun ) )then + info = -7_${ik}$ + end if + if( info/=0_${ik}$ ) then + call stdlib${ii}$_xerbla( 'SSTEBZ', -info ) return end if ! initialize error flags - info = 0 + info = 0_${ik}$ ncnvrg = .false. toofew = .false. ! quick return if possible - m = 0 + m = 0_${ik}$ if( n==0 )return ! simplifications: - if( irange==3 .and. il==1 .and. iu==n )irange = 1 + if( irange==3_${ik}$ .and. il==1_${ik}$ .and. iu==n )irange = 1_${ik}$ ! get machine constants - ! nb is the minimum vector length for vector bisection, or 0 + ! nb is the minimum vector length for vector bisection, or 0_${ik}$ ! if only scalar is to be done. - safemn = stdlib_slamch( 'S' ) - ulp = stdlib_slamch( 'P' ) + safemn = stdlib${ii}$_slamch( 'S' ) + ulp = stdlib${ii}$_slamch( 'P' ) rtoli = ulp*relfac - nb = stdlib_ilaenv( 1, 'SSTEBZ', ' ', n, -1, -1, -1 ) - if( nb<=1 )nb = 0 - ! special case when n=1 - if( n==1 ) then - nsplit = 1 - isplit( 1 ) = 1 - if( irange==2 .and. ( vl>=d( 1 ) .or. vu=d( 1_${ik}$ ) .or. vutmp1 ) then - isplit( nsplit ) = j - 1 - nsplit = nsplit + 1 + tmp1 = e( j-1 )**2_${ik}$ + if( abs( d( j )*d( j-1 ) )*ulp**2_${ik}$+safemn>tmp1 ) then + isplit( nsplit ) = j - 1_${ik}$ + nsplit = nsplit + 1_${ik}$ work( j-1 ) = zero else work( j-1 ) = tmp1 @@ -16977,13 +16979,13 @@ module stdlib_linalg_lapack_s isplit( nsplit ) = n pivmin = pivmin*safemn ! compute interval and atoli - if( irange==3 ) then + if( irange==3_${ik}$ ) then ! range='i': compute the interval containing eigenvalues ! il through iu. ! compute gershgorin interval for entire (split) matrix ! and use it as the initial interval - gu = d( 1 ) - gl = d( 1 ) + gu = d( 1_${ik}$ ) + gl = d( 1_${ik}$ ) tmp1 = zero do j = 1, n - 1 tmp2 = sqrt( work( j ) ) @@ -16997,7 +16999,7 @@ module stdlib_linalg_lapack_s gl = gl - fudge*tnorm*ulp*n - fudge*two*pivmin gu = gu + fudge*tnorm*ulp*n + fudge*pivmin ! compute iteration parameters - itmax = int( ( log( tnorm+pivmin )-log( pivmin ) ) /log( two ),KIND=ilp) + 2 + itmax = int( ( log( tnorm+pivmin )-log( pivmin ) ) /log( two ),KIND=${ik}$) + 2_${ik}$ if( abstol<=zero ) then atoli = ulp*tnorm else @@ -17009,36 +17011,36 @@ module stdlib_linalg_lapack_s work( n+4 ) = gu work( n+5 ) = gl work( n+6 ) = gu - iwork( 1 ) = -1 - iwork( 2 ) = -1 - iwork( 3 ) = n + 1 - iwork( 4 ) = n + 1 - iwork( 5 ) = il - 1 - iwork( 6 ) = iu - call stdlib_slaebz( 3, itmax, n, 2, 2, nb, atoli, rtoli, pivmin, d, e,work, iwork( & - 5 ), work( n+1 ), work( n+5 ), iout,iwork, w, iblock, iinfo ) - if( iwork( 6 )==iu ) then + iwork( 1_${ik}$ ) = -1_${ik}$ + iwork( 2_${ik}$ ) = -1_${ik}$ + iwork( 3_${ik}$ ) = n + 1_${ik}$ + iwork( 4_${ik}$ ) = n + 1_${ik}$ + iwork( 5_${ik}$ ) = il - 1_${ik}$ + iwork( 6_${ik}$ ) = iu + call stdlib${ii}$_slaebz( 3_${ik}$, itmax, n, 2_${ik}$, 2_${ik}$, nb, atoli, rtoli, pivmin, d, e,work, iwork( & + 5_${ik}$ ), work( n+1 ), work( n+5 ), iout,iwork, w, iblock, iinfo ) + if( iwork( 6_${ik}$ )==iu ) then wl = work( n+1 ) wlu = work( n+3 ) - nwl = iwork( 1 ) + nwl = iwork( 1_${ik}$ ) wu = work( n+4 ) wul = work( n+2 ) - nwu = iwork( 4 ) + nwu = iwork( 4_${ik}$ ) else wl = work( n+2 ) wlu = work( n+4 ) - nwl = iwork( 2 ) + nwl = iwork( 2_${ik}$ ) wu = work( n+3 ) wul = work( n+1 ) - nwu = iwork( 3 ) + nwu = iwork( 3_${ik}$ ) end if - if( nwl<0 .or. nwl>=n .or. nwu<1 .or. nwu>n ) then - info = 4 + if( nwl<0_${ik}$ .or. nwl>=n .or. nwu<1_${ik}$ .or. nwu>n ) then + info = 4_${ik}$ return end if else ! range='a' or 'v' -- set atoli - tnorm = max( abs( d( 1 ) )+abs( e( 1 ) ),abs( d( n ) )+abs( e( n-1 ) ) ) + tnorm = max( abs( d( 1_${ik}$ ) )+abs( e( 1_${ik}$ ) ),abs( d( n ) )+abs( e( n-1 ) ) ) do j = 2, n - 1 tnorm = max( tnorm, abs( d( j ) )+abs( e( j-1 ) )+abs( e( j ) ) ) end do @@ -17047,7 +17049,7 @@ module stdlib_linalg_lapack_s else atoli = abstol end if - if( irange==2 ) then + if( irange==2_${ik}$ ) then wl = vl wu = vu else @@ -17058,28 +17060,28 @@ module stdlib_linalg_lapack_s ! find eigenvalues -- loop over blocks and recompute nwl and nwu. ! nwl accumulates the number of eigenvalues .le. wl, ! nwu accumulates the number of eigenvalues .le. wu - m = 0 - iend = 0 - info = 0 - nwl = 0 - nwu = 0 + m = 0_${ik}$ + iend = 0_${ik}$ + info = 0_${ik}$ + nwl = 0_${ik}$ + nwu = 0_${ik}$ loop_70: do jb = 1, nsplit ioff = iend - ibegin = ioff + 1 + ibegin = ioff + 1_${ik}$ iend = isplit( jb ) in = iend - ioff - if( in==1 ) then - ! special case -- in=1 - if( irange==1 .or. wl>=d( ibegin )-pivmin )nwl = nwl + 1 - if( irange==1 .or. wu>=d( ibegin )-pivmin )nwu = nwu + 1 - if( irange==1 .or. ( wl=d( ibegin )-pivmin ) ) & + if( in==1_${ik}$ ) then + ! special case -- in=1_${ik}$ + if( irange==1_${ik}$ .or. wl>=d( ibegin )-pivmin )nwl = nwl + 1_${ik}$ + if( irange==1_${ik}$ .or. wu>=d( ibegin )-pivmin )nwu = nwu + 1_${ik}$ + if( irange==1_${ik}$ .or. ( wl=d( ibegin )-pivmin ) ) & then - m = m + 1 + m = m + 1_${ik}$ w( m ) = d( ibegin ) iblock( m ) = jb end if else - ! general case -- in > 1 + ! general case -- in > 1_${ik}$ ! compute gershgorin interval ! and use it as the initial interval gu = d( ibegin ) @@ -17102,7 +17104,7 @@ module stdlib_linalg_lapack_s else atoli = abstol end if - if( irange>1 ) then + if( irange>1_${ik}$ ) then if( gu iu, discard extra eigenvalues. - if( irange==3 ) then - im = 0 - idiscl = il - 1 - nwl + if( irange==3_${ik}$ ) then + im = 0_${ik}$ + idiscl = il - 1_${ik}$ - nwl idiscu = nwu - iu - if( idiscl>0 .or. idiscu>0 ) then + if( idiscl>0_${ik}$ .or. idiscu>0_${ik}$ ) then do je = 1, m - if( w( je )<=wlu .and. idiscl>0 ) then - idiscl = idiscl - 1 - else if( w( je )>=wul .and. idiscu>0 ) then - idiscu = idiscu - 1 + if( w( je )<=wlu .and. idiscl>0_${ik}$ ) then + idiscl = idiscl - 1_${ik}$ + else if( w( je )>=wul .and. idiscu>0_${ik}$ ) then + idiscu = idiscu - 1_${ik}$ else - im = im + 1 + im = im + 1_${ik}$ w( im ) = w( je ) iblock( im ) = iblock( je ) end if end do m = im end if - if( idiscl>0 .or. idiscu>0 ) then + if( idiscl>0_${ik}$ .or. idiscu>0_${ik}$ ) then ! code to deal with effects of bad arithmetic: ! some low eigenvalues to be discarded are not in (wl,wlu], ! or high eigenvalues to be discarded are not in (wul,wu] @@ -17175,52 +17177,52 @@ module stdlib_linalg_lapack_s ! eigenvalue(s). ! (if n(w) is monotone non-decreasing, this should never ! happen.) - if( idiscl>0 ) then + if( idiscl>0_${ik}$ ) then wkill = wu do jdisc = 1, idiscl - iw = 0 + iw = 0_${ik}$ do je = 1, m - if( iblock( je )/=0 .and.( w( je )0 ) then + if( idiscu>0_${ik}$ ) then wkill = wl do jdisc = 1, idiscu - iw = 0 + iw = 0_${ik}$ do je = 1, m - if( iblock( je )/=0 .and.( w( je )>wkill .or. iw==0 ) ) then + if( iblock( je )/=0_${ik}$ .and.( w( je )>wkill .or. iw==0_${ik}$ ) ) then iw = je wkill = w( je ) end if end do - iblock( iw ) = 0 + iblock( iw ) = 0_${ik}$ end do end if - im = 0 + im = 0_${ik}$ do je = 1, m - if( iblock( je )/=0 ) then - im = im + 1 + if( iblock( je )/=0_${ik}$ ) then + im = im + 1_${ik}$ w( im ) = w( je ) iblock( im ) = iblock( je ) end if end do m = im end if - if( idiscl<0 .or. idiscu<0 ) then + if( idiscl<0_${ik}$ .or. idiscu<0_${ik}$ ) then toofew = .true. end if end if ! if order='b', do nothing -- the eigenvalues are already sorted ! by block. ! if order='e', sort the eigenvalues from smallest to largest - if( iorder==1 .and. nsplit>1 ) then + if( iorder==1_${ik}$ .and. nsplit>1_${ik}$ ) then do je = 1, m - 1 - ie = 0 + ie = 0_${ik}$ tmp1 = w( je ) do j = je + 1, m if( w( j ) 1 ) - if( ipiv(i) < 0 ) then + if( ipiv(i) < 0_${ik}$ ) then e(i)=a(i-1,i) e(i-1)=zero a(i-1,i)=zero @@ -17305,7 +17307,7 @@ module stdlib_linalg_lapack_s ! convert permutations i=n do while ( i >= 1 ) - if( ipiv(i) > 0) then + if( ipiv(i) > 0_${ik}$) then ip=ipiv(i) if( i < n) then do j= i+1,n @@ -17330,9 +17332,9 @@ module stdlib_linalg_lapack_s else ! revert a (a is upper) ! revert permutations - i=1 + i=1_${ik}$ do while ( i <= n ) - if( ipiv(i) > 0 ) then + if( ipiv(i) > 0_${ik}$ ) then ip=ipiv(i) if( i < n) then do j= i+1,n @@ -17357,7 +17359,7 @@ module stdlib_linalg_lapack_s ! revert value i=n do while ( i > 1 ) - if( ipiv(i) < 0 ) then + if( ipiv(i) < 0_${ik}$ ) then a(i-1,i)=e(i) i=i-1 endif @@ -17369,10 +17371,10 @@ module stdlib_linalg_lapack_s if ( convert ) then ! convert a (a is lower) ! convert value - i=1 + i=1_${ik}$ e(n)=zero do while ( i <= n ) - if( i 0 ) then + if( ipiv(i) > 0_${ik}$ ) then ip=ipiv(i) - if (i > 1) then + if (i > 1_${ik}$) then do j= 1,i-1 temp=a(ip,j) a(ip,j)=a(i,j) @@ -17396,7 +17398,7 @@ module stdlib_linalg_lapack_s endif else ip=-ipiv(i) - if (i > 1) then + if (i > 1_${ik}$) then do j= 1,i-1 temp=a(ip,j) a(ip,j)=a(i+1,j) @@ -17412,9 +17414,9 @@ module stdlib_linalg_lapack_s ! revert permutations i=n do while ( i >= 1 ) - if( ipiv(i) > 0 ) then + if( ipiv(i) > 0_${ik}$ ) then ip=ipiv(i) - if (i > 1) then + if (i > 1_${ik}$) then do j= 1,i-1 temp=a(i,j) a(i,j)=a(ip,j) @@ -17424,7 +17426,7 @@ module stdlib_linalg_lapack_s else ip=-ipiv(i) i=i-1 - if (i > 1) then + if (i > 1_${ik}$) then do j= 1,i-1 temp=a(i+1,j) a(i+1,j)=a(ip,j) @@ -17435,9 +17437,9 @@ module stdlib_linalg_lapack_s i=i-1 end do ! revert value - i=1 + i=1_${ik}$ do while ( i <= n-1 ) - if( ipiv(i) < 0 ) then + if( ipiv(i) < 0_${ik}$ ) then a(i+1,i)=e(i) i=i+1 endif @@ -17446,10 +17448,10 @@ module stdlib_linalg_lapack_s end if end if return - end subroutine stdlib_ssyconv + end subroutine stdlib${ii}$_ssyconv - pure subroutine stdlib_ssyconvf( uplo, way, n, a, lda, e, ipiv, info ) + pure subroutine stdlib${ii}$_ssyconvf( uplo, way, n, a, lda, e, ipiv, info ) !! If parameter WAY = 'C': !! SSYCONVF converts the factorization output format used in !! SSYTRF provided on entry in parameter A into the factorization @@ -17470,31 +17472,31 @@ module stdlib_linalg_lapack_s ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: uplo, way - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda, n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, n ! Array Arguments - integer(ilp), intent(inout) :: ipiv(*) + integer(${ik}$), intent(inout) :: ipiv(*) real(sp), intent(inout) :: a(lda,*), e(*) ! ===================================================================== ! External Subroutines logical(lk) :: upper, convert - integer(ilp) :: i, ip + integer(${ik}$) :: i, ip ! Executable Statements - info = 0 + info = 0_${ik}$ upper = stdlib_lsame( uplo, 'U' ) convert = stdlib_lsame( way, 'C' ) if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then - info = -1 + info = -1_${ik}$ else if( .not.convert .and. .not.stdlib_lsame( way, 'R' ) ) then - info = -2 - else if( n<0 ) then - info = -3 - else if( lda1 ) - if( ipiv( i )<0 ) then + if( ipiv( i )<0_${ik}$ ) then e( i ) = a( i-1, i ) e( i-1 ) = zero a( i-1, i ) = zero - i = i - 1 + i = i - 1_${ik}$ else e( i ) = zero end if - i = i - 1 + i = i - 1_${ik}$ end do ! convert permutations and ipiv ! apply permutations to submatrices of upper part of a - ! in factorization order where i decreases from n to 1 + ! in factorization order where i decreases from n to 1_${ik}$ i = n do while ( i>=1 ) - if( ipiv( i )>0 ) then - ! 1-by-1 pivot interchange - ! swap rows i and ipiv(i) in a(1:i,n-i:n) + if( ipiv( i )>0_${ik}$ ) then + ! 1_${ik}$-by-1 pivot interchange + ! swap rows i and ipiv(i) in a(1_${ik}$:i,n-i:n) ip = ipiv( i ) if( i0 ) then - ! 1-by-1 pivot interchange - ! swap rows i and ipiv(i) in a(1:i,n-i:n) + if( ipiv( i )>0_${ik}$ ) then + ! 1_${ik}$-by-1 pivot interchange + ! swap rows i and ipiv(i) in a(1_${ik}$:i,n-i:n) ip = ipiv( i ) if( i1 ) - if( ipiv( i )<0 ) then + if( ipiv( i )<0_${ik}$ ) then a( i-1, i ) = e( i ) - i = i - 1 + i = i - 1_${ik}$ end if - i = i - 1 + i = i - 1_${ik}$ end do ! end a is upper end if @@ -17607,40 +17609,40 @@ module stdlib_linalg_lapack_s ! convert value ! assign subdiagonal entries of d to array e and zero out ! corresponding entries in input storage a - i = 1 + i = 1_${ik}$ e( n ) = zero do while ( i<=n ) - if( i0 ) then - ! 1-by-1 pivot interchange - ! swap rows i and ipiv(i) in a(i:n,1:i-1) + if( ipiv( i )>0_${ik}$ ) then + ! 1_${ik}$-by-1 pivot interchange + ! swap rows i and ipiv(i) in a(i:n,1_${ik}$:i-1) ip = ipiv( i ) - if ( i>1 ) then + if ( i>1_${ik}$ ) then if( ip/=i ) then - call stdlib_sswap( i-1, a( i, 1 ), lda,a( ip, 1 ), lda ) + call stdlib${ii}$_sswap( i-1, a( i, 1_${ik}$ ), lda,a( ip, 1_${ik}$ ), lda ) end if end if else - ! 2-by-2 pivot interchange - ! swap rows i+1 and ipiv(i) in a(i:n,1:i-1) + ! 2_${ik}$-by-2 pivot interchange + ! swap rows i+1 and ipiv(i) in a(i:n,1_${ik}$:i-1) ip = -ipiv( i ) - if ( i>1 ) then + if ( i>1_${ik}$ ) then if( ip/=(i+1) ) then - call stdlib_sswap( i-1, a( i+1, 1 ), lda,a( ip, 1 ), lda ) + call stdlib${ii}$_sswap( i-1, a( i+1, 1_${ik}$ ), lda,a( ip, 1_${ik}$ ), lda ) end if end if ! convert ipiv @@ -17648,34 +17650,34 @@ module stdlib_linalg_lapack_s ! so this should be reflected in ipiv format for ! *sytrf_rk ( or *sytrf_bk) ipiv( i ) = i - i = i + 1 + i = i + 1_${ik}$ end if - i = i + 1 + i = i + 1_${ik}$ end do else ! revert a (a is lower) ! revert permutations and ipiv ! apply permutations to submatrices of lower part of a - ! in reverse factorization order where i decreases from n to 1 + ! in reverse factorization order where i decreases from n to 1_${ik}$ i = n do while ( i>=1 ) - if( ipiv( i )>0 ) then - ! 1-by-1 pivot interchange - ! swap rows i and ipiv(i) in a(i:n,1:i-1) + if( ipiv( i )>0_${ik}$ ) then + ! 1_${ik}$-by-1 pivot interchange + ! swap rows i and ipiv(i) in a(i:n,1_${ik}$:i-1) ip = ipiv( i ) - if ( i>1 ) then + if ( i>1_${ik}$ ) then if( ip/=i ) then - call stdlib_sswap( i-1, a( ip, 1 ), lda,a( i, 1 ), lda ) + call stdlib${ii}$_sswap( i-1, a( ip, 1_${ik}$ ), lda,a( i, 1_${ik}$ ), lda ) end if end if else - ! 2-by-2 pivot interchange - ! swap rows i+1 and ipiv(i) in a(i:n,1:i-1) - i = i - 1 + ! 2_${ik}$-by-2 pivot interchange + ! swap rows i+1 and ipiv(i) in a(i:n,1_${ik}$:i-1) + i = i - 1_${ik}$ ip = -ipiv( i ) - if ( i>1 ) then + if ( i>1_${ik}$ ) then if( ip/=(i+1) ) then - call stdlib_sswap( i-1, a( ip, 1 ), lda,a( i+1, 1 ), lda ) + call stdlib${ii}$_sswap( i-1, a( ip, 1_${ik}$ ), lda,a( i+1, 1_${ik}$ ), lda ) end if end if ! convert ipiv @@ -17684,27 +17686,27 @@ module stdlib_linalg_lapack_s ! in ipiv format for *sytrf ipiv( i ) = ipiv( i+1 ) end if - i = i - 1 + i = i - 1_${ik}$ end do ! revert value ! assign subdiagonal entries of d from array e to ! subgiagonal entries of a. - i = 1 + i = 1_${ik}$ do while ( i<=n-1 ) - if( ipiv( i )<0 ) then - a( i + 1, i ) = e( i ) - i = i + 1 + if( ipiv( i )<0_${ik}$ ) then + a( i + 1_${ik}$, i ) = e( i ) + i = i + 1_${ik}$ end if - i = i + 1 + i = i + 1_${ik}$ end do end if ! end a is lower end if return - end subroutine stdlib_ssyconvf + end subroutine stdlib${ii}$_ssyconvf - pure subroutine stdlib_ssyconvf_rook( uplo, way, n, a, lda, e, ipiv, info ) + pure subroutine stdlib${ii}$_ssyconvf_rook( uplo, way, n, a, lda, e, ipiv, info ) !! If parameter WAY = 'C': !! SSYCONVF_ROOK converts the factorization output format used in !! SSYTRF_ROOK provided on entry in parameter A into the factorization @@ -17723,31 +17725,31 @@ module stdlib_linalg_lapack_s ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: uplo, way - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda, n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, n ! Array Arguments - integer(ilp), intent(in) :: ipiv(*) + integer(${ik}$), intent(in) :: ipiv(*) real(sp), intent(inout) :: a(lda,*), e(*) ! ===================================================================== ! External Subroutines logical(lk) :: upper, convert - integer(ilp) :: i, ip, ip2 + integer(${ik}$) :: i, ip, ip2 ! Executable Statements - info = 0 + info = 0_${ik}$ upper = stdlib_lsame( uplo, 'U' ) convert = stdlib_lsame( way, 'C' ) if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then - info = -1 + info = -1_${ik}$ else if( .not.convert .and. .not.stdlib_lsame( way, 'R' ) ) then - info = -2 - else if( n<0 ) then - info = -3 - else if( lda1 ) - if( ipiv( i )<0 ) then + if( ipiv( i )<0_${ik}$ ) then e( i ) = a( i-1, i ) e( i-1 ) = zero a( i-1, i ) = zero - i = i - 1 + i = i - 1_${ik}$ else e( i ) = zero end if - i = i - 1 + i = i - 1_${ik}$ end do ! convert permutations ! apply permutations to submatrices of upper part of a - ! in factorization order where i decreases from n to 1 + ! in factorization order where i decreases from n to 1_${ik}$ i = n do while ( i>=1 ) - if( ipiv( i )>0 ) then - ! 1-by-1 pivot interchange - ! swap rows i and ipiv(i) in a(1:i,n-i:n) + if( ipiv( i )>0_${ik}$ ) then + ! 1_${ik}$-by-1 pivot interchange + ! swap rows i and ipiv(i) in a(1_${ik}$:i,n-i:n) ip = ipiv( i ) if( i0 ) then - ! 1-by-1 pivot interchange - ! swap rows i and ipiv(i) in a(1:i,n-i:n) + if( ipiv( i )>0_${ik}$ ) then + ! 1_${ik}$-by-1 pivot interchange + ! swap rows i and ipiv(i) in a(1_${ik}$:i,n-i:n) ip = ipiv( i ) if( i1 ) - if( ipiv( i )<0 ) then + if( ipiv( i )<0_${ik}$ ) then a( i-1, i ) = e( i ) - i = i - 1 + i = i - 1_${ik}$ end if - i = i - 1 + i = i - 1_${ik}$ end do ! end a is upper end if @@ -17860,104 +17862,104 @@ module stdlib_linalg_lapack_s ! convert value ! assign subdiagonal entries of d to array e and zero out ! corresponding entries in input storage a - i = 1 + i = 1_${ik}$ e( n ) = zero do while ( i<=n ) - if( i0 ) then - ! 1-by-1 pivot interchange - ! swap rows i and ipiv(i) in a(i:n,1:i-1) + if( ipiv( i )>0_${ik}$ ) then + ! 1_${ik}$-by-1 pivot interchange + ! swap rows i and ipiv(i) in a(i:n,1_${ik}$:i-1) ip = ipiv( i ) - if ( i>1 ) then + if ( i>1_${ik}$ ) then if( ip/=i ) then - call stdlib_sswap( i-1, a( i, 1 ), lda,a( ip, 1 ), lda ) + call stdlib${ii}$_sswap( i-1, a( i, 1_${ik}$ ), lda,a( ip, 1_${ik}$ ), lda ) end if end if else - ! 2-by-2 pivot interchange + ! 2_${ik}$-by-2 pivot interchange ! swap rows i and ipiv(i) and i+1 and ipiv(i+1) - ! in a(i:n,1:i-1) + ! in a(i:n,1_${ik}$:i-1) ip = -ipiv( i ) ip2 = -ipiv( i+1 ) - if ( i>1 ) then + if ( i>1_${ik}$ ) then if( ip/=i ) then - call stdlib_sswap( i-1, a( i, 1 ), lda,a( ip, 1 ), lda ) + call stdlib${ii}$_sswap( i-1, a( i, 1_${ik}$ ), lda,a( ip, 1_${ik}$ ), lda ) end if if( ip2/=(i+1) ) then - call stdlib_sswap( i-1, a( i+1, 1 ), lda,a( ip2, 1 ), lda ) + call stdlib${ii}$_sswap( i-1, a( i+1, 1_${ik}$ ), lda,a( ip2, 1_${ik}$ ), lda ) end if end if - i = i + 1 + i = i + 1_${ik}$ end if - i = i + 1 + i = i + 1_${ik}$ end do else ! revert a (a is lower) ! revert permutations ! apply permutations to submatrices of lower part of a - ! in reverse factorization order where i decreases from n to 1 + ! in reverse factorization order where i decreases from n to 1_${ik}$ i = n do while ( i>=1 ) - if( ipiv( i )>0 ) then - ! 1-by-1 pivot interchange - ! swap rows i and ipiv(i) in a(i:n,1:i-1) + if( ipiv( i )>0_${ik}$ ) then + ! 1_${ik}$-by-1 pivot interchange + ! swap rows i and ipiv(i) in a(i:n,1_${ik}$:i-1) ip = ipiv( i ) - if ( i>1 ) then + if ( i>1_${ik}$ ) then if( ip/=i ) then - call stdlib_sswap( i-1, a( ip, 1 ), lda,a( i, 1 ), lda ) + call stdlib${ii}$_sswap( i-1, a( ip, 1_${ik}$ ), lda,a( i, 1_${ik}$ ), lda ) end if end if else - ! 2-by-2 pivot interchange + ! 2_${ik}$-by-2 pivot interchange ! swap rows i+1 and ipiv(i+1) and i and ipiv(i) - ! in a(i:n,1:i-1) - i = i - 1 + ! in a(i:n,1_${ik}$:i-1) + i = i - 1_${ik}$ ip = -ipiv( i ) ip2 = -ipiv( i+1 ) - if ( i>1 ) then + if ( i>1_${ik}$ ) then if( ip2/=(i+1) ) then - call stdlib_sswap( i-1, a( ip2, 1 ), lda,a( i+1, 1 ), lda ) + call stdlib${ii}$_sswap( i-1, a( ip2, 1_${ik}$ ), lda,a( i+1, 1_${ik}$ ), lda ) end if if( ip/=i ) then - call stdlib_sswap( i-1, a( ip, 1 ), lda,a( i, 1 ), lda ) + call stdlib${ii}$_sswap( i-1, a( ip, 1_${ik}$ ), lda,a( i, 1_${ik}$ ), lda ) end if end if end if - i = i - 1 + i = i - 1_${ik}$ end do ! revert value ! assign subdiagonal entries of d from array e to ! subgiagonal entries of a. - i = 1 + i = 1_${ik}$ do while ( i<=n-1 ) - if( ipiv( i )<0 ) then - a( i + 1, i ) = e( i ) - i = i + 1 + if( ipiv( i )<0_${ik}$ ) then + a( i + 1_${ik}$, i ) = e( i ) + i = i + 1_${ik}$ end if - i = i + 1 + i = i + 1_${ik}$ end do end if ! end a is lower end if return - end subroutine stdlib_ssyconvf_rook + end subroutine stdlib${ii}$_ssyconvf_rook - pure subroutine stdlib_ssyequb( uplo, n, a, lda, s, scond, amax, work, info ) + pure subroutine stdlib${ii}$_ssyequb( uplo, n, a, lda, s, scond, amax, work, info ) !! SSYEQUB 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 @@ -17969,8 +17971,8 @@ module stdlib_linalg_lapack_s ! -- 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, n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, n real(sp), intent(out) :: amax, scond character, intent(in) :: uplo ! Array Arguments @@ -17978,11 +17980,11 @@ module stdlib_linalg_lapack_s real(sp), intent(out) :: s(*), work(*) ! ===================================================================== ! Parameters - integer(ilp), parameter :: max_iter = 100 + integer(${ik}$), parameter :: max_iter = 100_${ik}$ ! Local Scalars - integer(ilp) :: i, j, iter + integer(${ik}$) :: i, j, iter real(sp) :: avg, std, tol, c0, c1, c2, t, u, si, d, base, smin, smax, smlnum, bignum, & scale, sumsq logical(lk) :: up @@ -17990,22 +17992,22 @@ module stdlib_linalg_lapack_s intrinsic :: abs,int,log,max,min,sqrt ! Executable Statements ! test the input parameters. - info = 0 + info = 0_${ik}$ if ( .not. ( stdlib_lsame( uplo, 'U' ) .or. stdlib_lsame( uplo, 'L' ) ) ) then - info = -1 - else if ( n < 0 ) then - info = -2 - else if ( lda < max( 1, n ) ) then - info = -4 + info = -1_${ik}$ + else if ( n < 0_${ik}$ ) then + info = -2_${ik}$ + else if ( lda < max( 1_${ik}$, n ) ) then + info = -4_${ik}$ end if - if ( info /= 0 ) then - call stdlib_xerbla( 'SSYEQUB', -info ) + if ( info /= 0_${ik}$ ) then + call stdlib${ii}$_xerbla( 'SSYEQUB', -info ) return end if up = stdlib_lsame( uplo, 'U' ) amax = zero ! quick return if possible. - if ( n == 0 ) then + if ( n == 0_${ik}$ ) then scond = one return end if @@ -18072,7 +18074,7 @@ module stdlib_linalg_lapack_s do i = n+1, 2*n work( i ) = s( i-n ) * work( i-n ) - avg end do - call stdlib_slassq( n, work( n+1 ), 1, scale, sumsq ) + call stdlib${ii}$_slassq( n, work( n+1 ), 1_${ik}$, scale, sumsq ) std = scale * sqrt( sumsq / n ) if ( std < tol * avg ) goto 999 do i = 1, n @@ -18080,13 +18082,13 @@ module stdlib_linalg_lapack_s si = s( i ) c2 = ( n-1 ) * t c1 = ( n-2 ) * ( work( i ) - t*si ) - c0 = -(t*si)*si + 2*work( i )*si - n*avg - d = c1*c1 - 4*c0*c2 - if ( d <= 0 ) then - info = -1 + c0 = -(t*si)*si + 2_${ik}$*work( i )*si - n*avg + d = c1*c1 - 4_${ik}$*c0*c2 + if ( d <= 0_${ik}$ ) then + info = -1_${ik}$ return end if - si = -2*c0 / ( c1 + sqrt( d ) ) + si = -2_${ik}$*c0 / ( c1 + sqrt( d ) ) d = si - s( i ) u = zero if ( up ) then @@ -18117,28 +18119,28 @@ module stdlib_linalg_lapack_s end do end do 999 continue - smlnum = stdlib_slamch( 'SAFEMIN' ) + smlnum = stdlib${ii}$_slamch( 'SAFEMIN' ) bignum = one / smlnum smin = bignum smax = zero t = one / sqrt( avg ) - base = stdlib_slamch( 'B' ) + base = stdlib${ii}$_slamch( 'B' ) u = one / log( base ) do i = 1, n - s( i ) = base ** int( u * log( s( i ) * t ),KIND=ilp) + s( i ) = base ** int( u * log( s( i ) * t ),KIND=${ik}$) smin = min( smin, s( i ) ) smax = max( smax, s( i ) ) end do scond = max( smin, smlnum ) / min( smax, bignum ) - end subroutine stdlib_ssyequb + end subroutine stdlib${ii}$_ssyequb - pure subroutine stdlib_ssygs2( itype, uplo, n, a, lda, b, ldb, info ) + pure subroutine stdlib${ii}$_ssygs2( itype, uplo, n, a, lda, b, ldb, info ) !! SSYGS2 reduces a real symmetric-definite generalized eigenproblem !! to standard form. - !! If ITYPE = 1, the problem is A*x = lambda*B*x, + !! If ITYPE = 1_${ik}$, the problem is A*x = lambda*B*x, !! and A is overwritten by inv(U**T)*A*inv(U) or inv(L)*A*inv(L**T) - !! If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or + !! If ITYPE = 2_${ik}$ or 3_${ik}$, the problem is A*B*x = lambda*x or !! B*A*x = lambda*x, and A is overwritten by U*A*U**T or L**T *A*L. !! B must have been previously factorized as U**T *U or L*L**T by SPOTRF. ! -- lapack computational routine -- @@ -18146,8 +18148,8 @@ module stdlib_linalg_lapack_s ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: itype, lda, ldb, n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: itype, lda, ldb, n ! Array Arguments real(sp), intent(inout) :: a(lda,*) real(sp), intent(in) :: b(ldb,*) @@ -18155,46 +18157,46 @@ module stdlib_linalg_lapack_s ! Local Scalars logical(lk) :: upper - integer(ilp) :: k + integer(${ik}$) :: k real(sp) :: akk, bkk, ct ! Intrinsic Functions intrinsic :: max ! Executable Statements ! test the input parameters. - info = 0 + info = 0_${ik}$ upper = stdlib_lsame( uplo, 'U' ) - if( itype<1 .or. itype>3 ) then - info = -1 + if( itype<1_${ik}$ .or. itype>3_${ik}$ ) then + info = -1_${ik}$ else if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then - info = -2 - else if( n<0 ) then - info = -3 - else if( lda3 ) then - info = -1 + if( itype<1_${ik}$ .or. itype>3_${ik}$ ) then + info = -1_${ik}$ else if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then - info = -2 - else if( n<0 ) then - info = -3 - else if( lda=n ) then + nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'SSYGST', uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ ) + if( nb<=1_${ik}$ .or. nb>=n ) then ! use unblocked code - call stdlib_ssygs2( itype, uplo, n, a, lda, b, ldb, info ) + call stdlib${ii}$_ssygs2( itype, uplo, n, a, lda, b, ldb, info ) else ! use blocked code - if( itype==1 ) then + if( itype==1_${ik}$ ) then if( upper ) then ! compute inv(u**t)*a*inv(u) do k = 1, n, nb kb = min( n-k+1, nb ) ! update the upper triangle of a(k:n,k:n) - call stdlib_ssygs2( itype, uplo, kb, a( k, k ), lda,b( k, k ), ldb, info ) + call stdlib${ii}$_ssygs2( itype, uplo, kb, a( k, k ), lda,b( k, k ), ldb, info ) if( k+kb<=n ) then - call stdlib_strsm( 'LEFT', uplo, 'TRANSPOSE', 'NON-UNIT',kb, n-k-kb+1, & + call stdlib${ii}$_strsm( 'LEFT', uplo, 'TRANSPOSE', 'NON-UNIT',kb, n-k-kb+1, & one, b( k, k ), ldb,a( k, k+kb ), lda ) - call stdlib_ssymm( 'LEFT', uplo, kb, n-k-kb+1, -half,a( k, k ), lda, b( & + call stdlib${ii}$_ssymm( '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_ssyr2k( uplo, 'TRANSPOSE', n-k-kb+1, kb, -one,a( k, k+kb ), & + call stdlib${ii}$_ssyr2k( 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_ssymm( 'LEFT', uplo, kb, n-k-kb+1, -half,a( k, k ), lda, b( & + call stdlib${ii}$_ssymm( '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_strsm( 'RIGHT', uplo, 'NO TRANSPOSE','NON-UNIT', kb, n-k-kb+& - 1, one,b( k+kb, k+kb ), ldb, a( k, k+kb ),lda ) + call stdlib${ii}$_strsm( 'RIGHT', uplo, 'NO TRANSPOSE','NON-UNIT', kb, n-k-kb+& + 1_${ik}$, one,b( k+kb, k+kb ), ldb, a( k, k+kb ),lda ) end if end do else @@ -18335,18 +18337,18 @@ module stdlib_linalg_lapack_s do k = 1, n, nb kb = min( n-k+1, nb ) ! update the lower triangle of a(k:n,k:n) - call stdlib_ssygs2( itype, uplo, kb, a( k, k ), lda,b( k, k ), ldb, info ) + call stdlib${ii}$_ssygs2( itype, uplo, kb, a( k, k ), lda,b( k, k ), ldb, info ) if( k+kb<=n ) then - call stdlib_strsm( 'RIGHT', uplo, 'TRANSPOSE', 'NON-UNIT',n-k-kb+1, kb, & + call stdlib${ii}$_strsm( 'RIGHT', uplo, 'TRANSPOSE', 'NON-UNIT',n-k-kb+1, kb, & one, b( k, k ), ldb,a( k+kb, k ), lda ) - call stdlib_ssymm( 'RIGHT', uplo, n-k-kb+1, kb, -half,a( k, k ), lda, b(& + call stdlib${ii}$_ssymm( '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_ssyr2k( uplo, 'NO TRANSPOSE', n-k-kb+1, kb,-one, a( k+kb, k & + call stdlib${ii}$_ssyr2k( 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_ssymm( 'RIGHT', uplo, n-k-kb+1, kb, -half,a( k, k ), lda, b(& + call stdlib${ii}$_ssymm( '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_strsm( 'LEFT', uplo, 'NO TRANSPOSE','NON-UNIT', n-k-kb+1, & + call stdlib${ii}$_strsm( '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 @@ -18356,46 +18358,46 @@ module stdlib_linalg_lapack_s ! compute u*a*u**t 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_strmm( 'LEFT', uplo, 'NO TRANSPOSE', 'NON-UNIT',k-1, kb, one, & - b, ldb, a( 1, k ), lda ) - call stdlib_ssymm( 'RIGHT', uplo, k-1, kb, half, a( k, k ),lda, b( 1, k ), & - ldb, one, a( 1, k ), lda ) - call stdlib_ssyr2k( uplo, 'NO TRANSPOSE', k-1, kb, one,a( 1, k ), lda, b( & - 1, k ), ldb, one, a,lda ) - call stdlib_ssymm( 'RIGHT', uplo, k-1, kb, half, a( k, k ),lda, b( 1, k ), & - ldb, one, a( 1, k ), lda ) - call stdlib_strmm( 'RIGHT', uplo, 'TRANSPOSE', 'NON-UNIT',k-1, kb, one, b( & - k, k ), ldb, a( 1, k ),lda ) - call stdlib_ssygs2( itype, uplo, kb, a( k, k ), lda,b( k, k ), ldb, info ) + ! update the upper triangle of a(1_${ik}$:k+kb-1,1_${ik}$:k+kb-1) + call stdlib${ii}$_strmm( 'LEFT', uplo, 'NO TRANSPOSE', 'NON-UNIT',k-1, kb, one, & + b, ldb, a( 1_${ik}$, k ), lda ) + call stdlib${ii}$_ssymm( 'RIGHT', uplo, k-1, kb, half, a( k, k ),lda, b( 1_${ik}$, k ), & + ldb, one, a( 1_${ik}$, k ), lda ) + call stdlib${ii}$_ssyr2k( uplo, 'NO TRANSPOSE', k-1, kb, one,a( 1_${ik}$, k ), lda, b( & + 1_${ik}$, k ), ldb, one, a,lda ) + call stdlib${ii}$_ssymm( 'RIGHT', uplo, k-1, kb, half, a( k, k ),lda, b( 1_${ik}$, k ), & + ldb, one, a( 1_${ik}$, k ), lda ) + call stdlib${ii}$_strmm( 'RIGHT', uplo, 'TRANSPOSE', 'NON-UNIT',k-1, kb, one, b( & + k, k ), ldb, a( 1_${ik}$, k ),lda ) + call stdlib${ii}$_ssygs2( itype, uplo, kb, a( k, k ), lda,b( k, k ), ldb, info ) end do else ! compute l**t*a*l 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_strmm( 'RIGHT', uplo, 'NO TRANSPOSE', 'NON-UNIT',kb, k-1, one, & - b, ldb, a( k, 1 ), lda ) - call stdlib_ssymm( 'LEFT', uplo, kb, k-1, half, a( k, k ),lda, b( k, 1 ), & - ldb, one, a( k, 1 ), lda ) - call stdlib_ssyr2k( uplo, 'TRANSPOSE', k-1, kb, one,a( k, 1 ), lda, b( k, & - 1 ), ldb, one, a,lda ) - call stdlib_ssymm( 'LEFT', uplo, kb, k-1, half, a( k, k ),lda, b( k, 1 ), & - ldb, one, a( k, 1 ), lda ) - call stdlib_strmm( 'LEFT', uplo, 'TRANSPOSE', 'NON-UNIT', kb,k-1, one, b( & - k, k ), ldb, a( k, 1 ), lda ) - call stdlib_ssygs2( itype, uplo, kb, a( k, k ), lda,b( k, k ), ldb, info ) + ! update the lower triangle of a(1_${ik}$:k+kb-1,1_${ik}$:k+kb-1) + call stdlib${ii}$_strmm( 'RIGHT', uplo, 'NO TRANSPOSE', 'NON-UNIT',kb, k-1, one, & + b, ldb, a( k, 1_${ik}$ ), lda ) + call stdlib${ii}$_ssymm( 'LEFT', uplo, kb, k-1, half, a( k, k ),lda, b( k, 1_${ik}$ ), & + ldb, one, a( k, 1_${ik}$ ), lda ) + call stdlib${ii}$_ssyr2k( uplo, 'TRANSPOSE', k-1, kb, one,a( k, 1_${ik}$ ), lda, b( k, & + 1_${ik}$ ), ldb, one, a,lda ) + call stdlib${ii}$_ssymm( 'LEFT', uplo, kb, k-1, half, a( k, k ),lda, b( k, 1_${ik}$ ), & + ldb, one, a( k, 1_${ik}$ ), lda ) + call stdlib${ii}$_strmm( 'LEFT', uplo, 'TRANSPOSE', 'NON-UNIT', kb,k-1, one, b( & + k, k ), ldb, a( k, 1_${ik}$ ), lda ) + call stdlib${ii}$_ssygs2( itype, uplo, kb, a( k, k ), lda,b( k, k ), ldb, info ) end do end if end if end if return - end subroutine stdlib_ssygst + end subroutine stdlib${ii}$_ssygst - pure subroutine stdlib_ssyswapr( uplo, n, a, lda, i1, i2) + pure subroutine stdlib${ii}$_ssyswapr( uplo, n, a, lda, i1, i2) !! SSYSWAPR applies an elementary permutation on the rows and the columns of !! a symmetric matrix. ! -- lapack auxiliary routine -- @@ -18403,13 +18405,13 @@ module stdlib_linalg_lapack_s ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: uplo - integer(ilp), intent(in) :: i1, i2, lda, n + integer(${ik}$), intent(in) :: i1, i2, lda, n ! Array Arguments real(sp), intent(inout) :: a(lda,n) ! ===================================================================== ! Local Scalars logical(lk) :: upper - integer(ilp) :: i + integer(${ik}$) :: i real(sp) :: tmp ! Executable Statements upper = stdlib_lsame( uplo, 'U' ) @@ -18417,7 +18419,7 @@ module stdlib_linalg_lapack_s ! upper ! first swap ! - swap column i1 and i2 from i1 to i1-1 - call stdlib_sswap( i1-1, a(1,i1), 1, a(1,i2), 1 ) + call stdlib${ii}$_sswap( i1-1, a(1_${ik}$,i1), 1_${ik}$, a(1_${ik}$,i2), 1_${ik}$ ) ! second swap : ! - swap a(i1,i1) and a(i2,i2) ! - swap row i1 from i1+1 to i2-1 with col i2 from i1+1 to i2-1 @@ -18440,7 +18442,7 @@ module stdlib_linalg_lapack_s ! lower ! first swap ! - swap row i1 and i2 from i1 to i1-1 - call stdlib_sswap( i1-1, a(i1,1), lda, a(i2,1), lda ) + call stdlib${ii}$_sswap( i1-1, a(i1,1_${ik}$), lda, a(i2,1_${ik}$), lda ) ! second swap : ! - swap a(i1,i1) and a(i2,i2) ! - swap col i1 from i1+1 to i2-1 with row i2 from i1+1 to i2-1 @@ -18460,28 +18462,28 @@ module stdlib_linalg_lapack_s a(i,i2)=tmp end do endif - end subroutine stdlib_ssyswapr + end subroutine stdlib${ii}$_ssyswapr - pure subroutine stdlib_ssytf2_rk( uplo, n, a, lda, e, ipiv, info ) + pure subroutine stdlib${ii}$_ssytf2_rk( uplo, n, a, lda, e, ipiv, info ) !! SSYTF2_RK computes the factorization of a real symmetric matrix A !! using the bounded Bunch-Kaufman (rook) diagonal pivoting method: !! A = P*U*D*(U**T)*(P**T) or A = P*L*D*(L**T)*(P**T), !! where U (or L) is unit upper (or lower) triangular matrix, !! U**T (or L**T) is the transpose of U (or L), P is a permutation !! matrix, P**T is the transpose of P, and D is symmetric and block - !! diagonal with 1-by-1 and 2-by-2 diagonal blocks. - !! This is the unblocked version of the algorithm, calling Level 2 BLAS. + !! diagonal with 1_${ik}$-by-1 and 2_${ik}$-by-2 diagonal blocks. + !! This is the unblocked version of the algorithm, calling Level 2_${ik}$ BLAS. !! For more information see Further Details section. ! -- lapack computational routine -- ! -- lapack is a software package provided by univ. of tennessee, -- ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda, n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, n ! Array Arguments - integer(ilp), intent(out) :: ipiv(*) + integer(${ik}$), intent(out) :: ipiv(*) real(sp), intent(inout) :: a(lda,*) real(sp), intent(out) :: e(*) ! ===================================================================== @@ -18491,68 +18493,68 @@ module stdlib_linalg_lapack_s ! Local Scalars logical(lk) :: upper, done - integer(ilp) :: i, imax, j, jmax, itemp, k, kk, kp, kstep, p, ii + integer(${ik}$) :: i, imax, j, jmax, itemp, k, kk, kp, kstep, p, ii real(sp) :: absakk, alpha, colmax, d11, d12, d21, d22, rowmax, stemp, t, wk, wkm1, & wkp1, sfmin ! Intrinsic Functions intrinsic :: abs,max,sqrt ! Executable Statements ! test the input parameters. - info = 0 + info = 0_${ik}$ upper = stdlib_lsame( uplo, 'U' ) if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then - info = -1 - else if( n<0 ) then - info = -2 - else if( lda1 ) then - imax = stdlib_isamax( k-1, a( 1, k ), 1 ) + if( k>1_${ik}$ ) then + imax = stdlib${ii}$_isamax( k-1, a( 1_${ik}$, k ), 1_${ik}$ ) colmax = abs( a( imax, k ) ) else colmax = zero end if if( (max( absakk, colmax )==zero) ) then ! column k is zero or underflow: set info and continue - if( info==0 )info = k + if( info==0_${ik}$ )info = k kp = k ! set e( k ) to zero - if( k>1 )e( k ) = zero + if( k>1_${ik}$ )e( k ) = zero else ! test for interchange ! equivalent to testing for (used to handle nan and inf) ! absakk>=alpha*colmax if( .not.( absakk1 ) then - itemp = stdlib_isamax( imax-1, a( 1, imax ), 1 ) + if( imax>1_${ik}$ ) then + itemp = stdlib${ii}$_isamax( imax-1, a( 1_${ik}$, imax ), 1_${ik}$ ) stemp = abs( a( itemp, imax ) ) if( stemp>rowmax ) then rowmax = stemp @@ -18580,16 +18582,16 @@ module stdlib_linalg_lapack_s ! abs( a( imax, imax ) )>=alpha*rowmax if( .not.( abs( a( imax, imax ) )1 )call stdlib_sswap( p-1, a( 1, k ), 1, a( 1, p ), 1 ) - if( p<(k-1) )call stdlib_sswap( k-p-1, a( p+1, k ), 1, a( p, p+1 ),lda ) + ! submatrix a(1_${ik}$:k,1_${ik}$:k) if we have a 2_${ik}$-by-2 pivot + if( p>1_${ik}$ )call stdlib${ii}$_sswap( p-1, a( 1_${ik}$, k ), 1_${ik}$, a( 1_${ik}$, p ), 1_${ik}$ ) + if( p<(k-1) )call stdlib${ii}$_sswap( k-p-1, a( p+1, k ), 1_${ik}$, a( p, p+1 ),lda ) t = a( k, k ) a( k, k ) = a( p, p ) a( p, p ) = t ! convert upper triangle of a into u form by applying ! the interchanges in columns k+1:n. - if( k1 )call stdlib_sswap( kp-1, a( 1, kk ), 1, a( 1, kp ), 1 ) - if( ( kk>1 ) .and. ( kp<(kk-1) ) )call stdlib_sswap( kk-kp-1, a( kp+1, kk ), & - 1, a( kp, kp+1 ),lda ) + ! submatrix a(1_${ik}$:k,1_${ik}$:k) + if( kp>1_${ik}$ )call stdlib${ii}$_sswap( kp-1, a( 1_${ik}$, kk ), 1_${ik}$, a( 1_${ik}$, kp ), 1_${ik}$ ) + if( ( kk>1_${ik}$ ) .and. ( kp<(kk-1) ) )call stdlib${ii}$_sswap( kk-kp-1, a( kp+1, kk ), & + 1_${ik}$, a( kp, kp+1 ),lda ) t = a( kk, kk ) a( kk, kk ) = a( kp, kp ) a( kp, kp ) = t - if( kstep==2 ) then + if( kstep==2_${ik}$ ) then t = a( k-1, k ) a( k-1, k ) = a( kp, k ) a( kp, k ) = t 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 + if( k>1_${ik}$ ) then + ! perform a rank-1 update of a(1_${ik}$:k-1,1_${ik}$:k-1) and ! store u(k) in column k if( abs( a( k, k ) )>=sfmin ) then - ! perform a rank-1 update of a(1:k-1,1:k-1) as + ! perform a rank-1 update of a(1_${ik}$:k-1,1_${ik}$:k-1) as ! a := a - u(k)*d(k)*u(k)**t - ! = a - w(k)*1/d(k)*w(k)**t + ! = a - w(k)*1_${ik}$/d(k)*w(k)**t d11 = one / a( k, k ) - call stdlib_ssyr( uplo, k-1, -d11, a( 1, k ), 1, a, lda ) + call stdlib${ii}$_ssyr( uplo, k-1, -d11, a( 1_${ik}$, k ), 1_${ik}$, a, lda ) ! store u(k) in column k - call stdlib_sscal( k-1, d11, a( 1, k ), 1 ) + call stdlib${ii}$_sscal( k-1, d11, a( 1_${ik}$, k ), 1_${ik}$ ) else ! store l(k) in column k d11 = a( k, k ) @@ -18659,23 +18661,23 @@ module stdlib_linalg_lapack_s end do ! perform a rank-1 update of a(k+1:n,k+1:n) as ! a := a - u(k)*d(k)*u(k)**t - ! = a - w(k)*(1/d(k))*w(k)**t + ! = a - w(k)*(1_${ik}$/d(k))*w(k)**t ! = a - (w(k)/d(k))*(d(k))*(w(k)/d(k))**t - call stdlib_ssyr( uplo, k-1, -d11, a( 1, k ), 1, a, lda ) + call stdlib${ii}$_ssyr( uplo, k-1, -d11, a( 1_${ik}$, k ), 1_${ik}$, a, lda ) end if ! store the superdiagonal element of d in array e e( k ) = zero end if else - ! 2-by-2 pivot block d(k): columns k and k-1 now hold + ! 2_${ik}$-by-2 pivot block d(k): columns k and k-1 now hold ! ( w(k-1) w(k) ) = ( u(k-1) u(k) )*d(k) ! where u(k) and u(k-1) are the k-th and (k-1)-th columns ! of u - ! perform a rank-2 update of a(1:k-2,1:k-2) as + ! perform a rank-2 update of a(1_${ik}$:k-2,1_${ik}$:k-2) as ! a := a - ( u(k-1) u(k) )*d(k)*( u(k-1) u(k) )**t ! = a - ( ( a(k-1)a(k) )*inv(d(k)) ) * ( a(k-1)a(k) )**t ! and store l(k) and l(k+1) in columns k and k+1 - if( k>2 ) then + if( k>2_${ik}$ ) then d12 = a( k-1, k ) d22 = a( k-1, k-1 ) / d12 d11 = a( k, k ) / d12 @@ -18701,7 +18703,7 @@ module stdlib_linalg_lapack_s ! end column k is nonsingular end if ! store details of the interchanges in ipiv - if( kstep==1 ) then + if( kstep==1_${ik}$ ) then ipiv( k ) = kp else ipiv( k ) = -p @@ -18715,29 +18717,29 @@ module stdlib_linalg_lapack_s ! factorize a as l*d*l**t using the lower triangle of a ! initialize the unused last entry of the subdiagonal array e. e( n ) = zero - ! k is the main loop index, increasing from 1 to n in steps of - ! 1 or 2 - k = 1 + ! k is the main loop index, increasing from 1_${ik}$ to n in steps of + ! 1_${ik}$ or 2_${ik}$ + k = 1_${ik}$ 40 continue ! if k > n, exit from loop if( k>n )go to 64 - kstep = 1 + kstep = 1_${ik}$ p = k ! determine rows and columns to be interchanged and whether - ! a 1-by-1 or 2-by-2 pivot block will be used + ! a 1_${ik}$-by-1 or 2_${ik}$-by-2 pivot block will be used absakk = abs( a( k, k ) ) ! imax is the row-index of the largest off-diagonal element in ! column k, and colmax is its absolute value. ! determine both colmax and imax. if( k=alpha*colmax if( .not.( absakkrowmax ) then rowmax = stemp @@ -18774,16 +18776,16 @@ module stdlib_linalg_lapack_s ! abs( a( imax, imax ) )>=alpha*rowmax if( .not.( abs( a( imax, imax ) )(k+1) )call stdlib_sswap( p-k-1, a( k+1, k ), 1, a( p, k+1 ), lda ) + ! submatrix a(k:n,k:n) if we have a 2_${ik}$-by-2 pivot + if( p(k+1) )call stdlib${ii}$_sswap( p-k-1, a( k+1, k ), 1_${ik}$, a( p, k+1 ), lda ) t = a( k, k ) a( k, k ) = a( p, p ) a( p, p ) = t ! convert lower triangle of a into l form by applying - ! the interchanges in columns 1:k-1. - if ( k>1 )call stdlib_sswap( k-1, a( k, 1 ), lda, a( p, 1 ), lda ) + ! the interchanges in columns 1_${ik}$:k-1. + if ( k>1_${ik}$ )call stdlib${ii}$_sswap( k-1, a( k, 1_${ik}$ ), lda, a( p, 1_${ik}$ ), lda ) end if ! second swap - kk = k + kstep - 1 + kk = k + kstep - 1_${ik}$ if( kp/=kk ) then ! interchange rows and columns kk and kp in the trailing ! submatrix a(k:n,k:n) - if( kp(kk+1) ) )call stdlib_sswap( kp-kk-1, a( kk+1, kk ), & - 1, a( kp, kk+1 ),lda ) + if( ( kk(kk+1) ) )call stdlib${ii}$_sswap( kp-kk-1, a( kk+1, kk ), & + 1_${ik}$, a( kp, kk+1 ),lda ) t = a( kk, kk ) a( kk, kk ) = a( kp, kp ) a( kp, kp ) = t - if( kstep==2 ) then + if( kstep==2_${ik}$ ) then t = a( k+1, k ) a( k+1, k ) = a( kp, k ) a( kp, k ) = t end if ! convert lower triangle of a into l form by applying - ! the interchanges in columns 1:k-1. - if ( k>1 )call stdlib_sswap( k-1, a( kk, 1 ), lda, a( kp, 1 ), lda ) + ! the interchanges in columns 1_${ik}$:k-1. + if ( k>1_${ik}$ )call stdlib${ii}$_sswap( k-1, a( kk, 1_${ik}$ ), lda, a( kp, 1_${ik}$ ), lda ) end if ! update the trailing submatrix - if( kstep==1 ) then - ! 1-by-1 pivot block d(k): column k now holds + if( kstep==1_${ik}$ ) then + ! 1_${ik}$-by-1 pivot block d(k): column k now holds ! w(k) = l(k)*d(k) ! where l(k) is the k-th column of l if( k=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 + ! = a - w(k)*(1_${ik}$/d(k))*w(k)**t d11 = one / a( k, k ) - call stdlib_ssyr( uplo, n-k, -d11, a( k+1, k ), 1,a( k+1, k+1 ), lda ) + call stdlib${ii}$_ssyr( uplo, n-k, -d11, a( k+1, k ), 1_${ik}$,a( k+1, k+1 ), lda ) ! store l(k) in column k - call stdlib_sscal( n-k, d11, a( k+1, k ), 1 ) + call stdlib${ii}$_sscal( n-k, d11, a( k+1, k ), 1_${ik}$ ) else ! store l(k) in column k d11 = a( k, k ) @@ -18855,16 +18857,16 @@ module stdlib_linalg_lapack_s end do ! perform a rank-1 update of a(k+1:n,k+1:n) as ! a := a - l(k)*d(k)*l(k)**t - ! = a - w(k)*(1/d(k))*w(k)**t + ! = a - w(k)*(1_${ik}$/d(k))*w(k)**t ! = a - (w(k)/d(k))*(d(k))*(w(k)/d(k))**t - call stdlib_ssyr( uplo, n-k, -d11, a( k+1, k ), 1,a( k+1, k+1 ), lda ) + call stdlib${ii}$_ssyr( uplo, n-k, -d11, a( k+1, k ), 1_${ik}$,a( k+1, k+1 ), lda ) end if ! store the subdiagonal element of d in array e e( k ) = zero end if else - ! 2-by-2 pivot block d(k): columns k and k+1 now hold + ! 2_${ik}$-by-2 pivot block d(k): columns k and k+1 now hold ! ( w(k) w(k+1) ) = ( l(k) l(k+1) )*d(k) ! where l(k) and l(k+1) are the k-th and (k+1)-th columns ! of l @@ -18900,7 +18902,7 @@ module stdlib_linalg_lapack_s ! end column k is nonsingular end if ! store details of the interchanges in ipiv - if( kstep==1 ) then + if( kstep==1_${ik}$ ) then ipiv( k ) = kp else ipiv( k ) = -p @@ -18912,26 +18914,26 @@ module stdlib_linalg_lapack_s 64 continue end if return - end subroutine stdlib_ssytf2_rk + end subroutine stdlib${ii}$_ssytf2_rk - pure subroutine stdlib_ssytf2_rook( uplo, n, a, lda, ipiv, info ) + pure subroutine stdlib${ii}$_ssytf2_rook( uplo, n, a, lda, ipiv, info ) !! SSYTF2_ROOK computes the factorization of a real symmetric matrix A !! using the bounded Bunch-Kaufman ("rook") diagonal pivoting method: !! A = U*D*U**T or A = L*D*L**T !! where U (or L) is a product of permutation and unit upper (lower) !! triangular matrices, U**T is the transpose of U, and D is symmetric and - !! block diagonal with 1-by-1 and 2-by-2 diagonal blocks. - !! This is the unblocked version of the algorithm, calling Level 2 BLAS. + !! block diagonal with 1_${ik}$-by-1 and 2_${ik}$-by-2 diagonal blocks. + !! This is the unblocked version of the algorithm, calling Level 2_${ik}$ BLAS. ! -- lapack computational routine -- ! -- lapack is a software package provided by univ. of tennessee, -- ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda, n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, n ! Array Arguments - integer(ilp), intent(out) :: ipiv(*) + integer(${ik}$), intent(out) :: ipiv(*) real(sp), intent(inout) :: a(lda,*) ! ===================================================================== ! Parameters @@ -18940,55 +18942,55 @@ module stdlib_linalg_lapack_s ! Local Scalars logical(lk) :: upper, done - integer(ilp) :: i, imax, j, jmax, itemp, k, kk, kp, kstep, p, ii + integer(${ik}$) :: i, imax, j, jmax, itemp, k, kk, kp, kstep, p, ii real(sp) :: absakk, alpha, colmax, d11, d12, d21, d22, rowmax, stemp, t, wk, wkm1, & wkp1, sfmin ! Intrinsic Functions intrinsic :: abs,max,sqrt ! Executable Statements ! test the input parameters. - info = 0 + info = 0_${ik}$ upper = stdlib_lsame( uplo, 'U' ) if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then - info = -1 - else if( n<0 ) then - info = -2 - else if( lda1 ) then - imax = stdlib_isamax( k-1, a( 1, k ), 1 ) + if( k>1_${ik}$ ) then + imax = stdlib${ii}$_isamax( k-1, a( 1_${ik}$, k ), 1_${ik}$ ) colmax = abs( a( imax, k ) ) else colmax = zero end if if( (max( absakk, colmax )==zero) ) then ! column k is zero or underflow: set info and continue - if( info==0 )info = k + if( info==0_${ik}$ )info = k kp = k else ! test for interchange @@ -18996,7 +18998,7 @@ module stdlib_linalg_lapack_s ! absakk>=alpha*colmax if( .not.( absakk1 ) then - itemp = stdlib_isamax( imax-1, a( 1, imax ), 1 ) + if( imax>1_${ik}$ ) then + itemp = stdlib${ii}$_isamax( imax-1, a( 1_${ik}$, imax ), 1_${ik}$ ) stemp = abs( a( itemp, imax ) ) if( stemp>rowmax ) then rowmax = stemp @@ -19024,16 +19026,16 @@ module stdlib_linalg_lapack_s ! abs( a( imax, imax ) )>=alpha*rowmax if( .not.( abs( a( imax, imax ) )1 )call stdlib_sswap( p-1, a( 1, k ), 1, a( 1, p ), 1 ) - if( p<(k-1) )call stdlib_sswap( k-p-1, a( p+1, k ), 1, a( p, p+1 ),lda ) + ! submatrix a(1_${ik}$:k,1_${ik}$:k) if we have a 2_${ik}$-by-2 pivot + if( p>1_${ik}$ )call stdlib${ii}$_sswap( p-1, a( 1_${ik}$, k ), 1_${ik}$, a( 1_${ik}$, p ), 1_${ik}$ ) + if( p<(k-1) )call stdlib${ii}$_sswap( k-p-1, a( p+1, k ), 1_${ik}$, a( p, p+1 ),lda ) t = a( k, k ) a( k, k ) = a( p, p ) a( p, p ) = t end if ! second swap - kk = k - kstep + 1 + kk = k - kstep + 1_${ik}$ if( kp/=kk ) then ! interchange rows and columns kk and kp in the leading - ! submatrix a(1:k,1:k) - if( kp>1 )call stdlib_sswap( kp-1, a( 1, kk ), 1, a( 1, kp ), 1 ) - if( ( kk>1 ) .and. ( kp<(kk-1) ) )call stdlib_sswap( kk-kp-1, a( kp+1, kk ), & - 1, a( kp, kp+1 ),lda ) + ! submatrix a(1_${ik}$:k,1_${ik}$:k) + if( kp>1_${ik}$ )call stdlib${ii}$_sswap( kp-1, a( 1_${ik}$, kk ), 1_${ik}$, a( 1_${ik}$, kp ), 1_${ik}$ ) + if( ( kk>1_${ik}$ ) .and. ( kp<(kk-1) ) )call stdlib${ii}$_sswap( kk-kp-1, a( kp+1, kk ), & + 1_${ik}$, a( kp, kp+1 ),lda ) t = a( kk, kk ) a( kk, kk ) = a( kp, kp ) a( kp, kp ) = t - if( kstep==2 ) then + if( kstep==2_${ik}$ ) then t = a( k-1, k ) a( k-1, k ) = a( kp, k ) a( kp, k ) = t end if end if ! update the leading submatrix - if( kstep==1 ) then - ! 1-by-1 pivot block d(k): column k now holds + if( kstep==1_${ik}$ ) then + ! 1_${ik}$-by-1 pivot block d(k): column k now holds ! w(k) = u(k)*d(k) ! where u(k) is the k-th column of u - if( k>1 ) then - ! perform a rank-1 update of a(1:k-1,1:k-1) and + if( k>1_${ik}$ ) then + ! perform a rank-1 update of a(1_${ik}$:k-1,1_${ik}$:k-1) and ! store u(k) in column k if( abs( a( k, k ) )>=sfmin ) then - ! perform a rank-1 update of a(1:k-1,1:k-1) as + ! perform a rank-1 update of a(1_${ik}$:k-1,1_${ik}$:k-1) as ! a := a - u(k)*d(k)*u(k)**t - ! = a - w(k)*1/d(k)*w(k)**t + ! = a - w(k)*1_${ik}$/d(k)*w(k)**t d11 = one / a( k, k ) - call stdlib_ssyr( uplo, k-1, -d11, a( 1, k ), 1, a, lda ) + call stdlib${ii}$_ssyr( uplo, k-1, -d11, a( 1_${ik}$, k ), 1_${ik}$, a, lda ) ! store u(k) in column k - call stdlib_sscal( k-1, d11, a( 1, k ), 1 ) + call stdlib${ii}$_sscal( k-1, d11, a( 1_${ik}$, k ), 1_${ik}$ ) else ! store l(k) in column k d11 = a( k, k ) @@ -19097,21 +19099,21 @@ module stdlib_linalg_lapack_s end do ! perform a rank-1 update of a(k+1:n,k+1:n) as ! a := a - u(k)*d(k)*u(k)**t - ! = a - w(k)*(1/d(k))*w(k)**t + ! = a - w(k)*(1_${ik}$/d(k))*w(k)**t ! = a - (w(k)/d(k))*(d(k))*(w(k)/d(k))**t - call stdlib_ssyr( uplo, k-1, -d11, a( 1, k ), 1, a, lda ) + call stdlib${ii}$_ssyr( uplo, k-1, -d11, a( 1_${ik}$, k ), 1_${ik}$, a, lda ) end if end if else - ! 2-by-2 pivot block d(k): columns k and k-1 now hold + ! 2_${ik}$-by-2 pivot block d(k): columns k and k-1 now hold ! ( w(k-1) w(k) ) = ( u(k-1) u(k) )*d(k) ! where u(k) and u(k-1) are the k-th and (k-1)-th columns ! of u - ! perform a rank-2 update of a(1:k-2,1:k-2) as + ! perform a rank-2 update of a(1_${ik}$:k-2,1_${ik}$:k-2) as ! a := a - ( u(k-1) u(k) )*d(k)*( u(k-1) u(k) )**t ! = a - ( ( a(k-1)a(k) )*inv(d(k)) ) * ( a(k-1)a(k) )**t ! and store l(k) and l(k+1) in columns k and k+1 - if( k>2 ) then + if( k>2_${ik}$ ) then d12 = a( k-1, k ) d22 = a( k-1, k-1 ) / d12 d11 = a( k, k ) / d12 @@ -19131,7 +19133,7 @@ module stdlib_linalg_lapack_s end if end if ! store details of the interchanges in ipiv - if( kstep==1 ) then + if( kstep==1_${ik}$ ) then ipiv( k ) = kp else ipiv( k ) = -p @@ -19142,36 +19144,36 @@ module stdlib_linalg_lapack_s go to 10 else ! factorize a as l*d*l**t using the lower triangle of a - ! k is the main loop index, increasing from 1 to n in steps of - ! 1 or 2 - k = 1 + ! k is the main loop index, increasing from 1_${ik}$ to n in steps of + ! 1_${ik}$ or 2_${ik}$ + k = 1_${ik}$ 40 continue ! if k > n, exit from loop if( k>n )go to 70 - kstep = 1 + kstep = 1_${ik}$ p = k ! determine rows and columns to be interchanged and whether - ! a 1-by-1 or 2-by-2 pivot block will be used + ! a 1_${ik}$-by-1 or 2_${ik}$-by-2 pivot block will be used absakk = abs( a( k, k ) ) ! imax is the row-index of the largest off-diagonal element in ! column k, and colmax is its absolute value. ! determine both colmax and imax. if( k=alpha*colmax if( .not.( absakkrowmax ) then rowmax = stemp @@ -19199,16 +19201,16 @@ module stdlib_linalg_lapack_s ! abs( a( imax, imax ) )>=alpha*rowmax if( .not.( abs( a( imax, imax ) )(k+1) )call stdlib_sswap( p-k-1, a( k+1, k ), 1, a( p, k+1 ), lda ) + ! submatrix a(k:n,k:n) if we have a 2_${ik}$-by-2 pivot + if( p(k+1) )call stdlib${ii}$_sswap( p-k-1, a( k+1, k ), 1_${ik}$, a( p, k+1 ), lda ) t = a( k, k ) a( k, k ) = a( p, p ) a( p, p ) = t end if ! second swap - kk = k + kstep - 1 + kk = k + kstep - 1_${ik}$ if( kp/=kk ) then ! interchange rows and columns kk and kp in the trailing ! submatrix a(k:n,k:n) - if( kp(kk+1) ) )call stdlib_sswap( kp-kk-1, a( kk+1, kk ), & - 1, a( kp, kk+1 ),lda ) + if( ( kk(kk+1) ) )call stdlib${ii}$_sswap( kp-kk-1, a( kk+1, kk ), & + 1_${ik}$, a( kp, kk+1 ),lda ) t = a( kk, kk ) a( kk, kk ) = a( kp, kp ) a( kp, kp ) = t - if( kstep==2 ) then + if( kstep==2_${ik}$ ) then t = a( k+1, k ) a( k+1, k ) = a( kp, k ) a( kp, k ) = t end if end if ! update the trailing submatrix - if( kstep==1 ) then - ! 1-by-1 pivot block d(k): column k now holds + if( kstep==1_${ik}$ ) then + ! 1_${ik}$-by-1 pivot block d(k): column k now holds ! w(k) = l(k)*d(k) ! where l(k) is the k-th column of l if( k=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 + ! = a - w(k)*(1_${ik}$/d(k))*w(k)**t d11 = one / a( k, k ) - call stdlib_ssyr( uplo, n-k, -d11, a( k+1, k ), 1,a( k+1, k+1 ), lda ) + call stdlib${ii}$_ssyr( uplo, n-k, -d11, a( k+1, k ), 1_${ik}$,a( k+1, k+1 ), lda ) ! store l(k) in column k - call stdlib_sscal( n-k, d11, a( k+1, k ), 1 ) + call stdlib${ii}$_sscal( n-k, d11, a( k+1, k ), 1_${ik}$ ) else ! store l(k) in column k d11 = a( k, k ) @@ -19274,14 +19276,14 @@ module stdlib_linalg_lapack_s end do ! perform a rank-1 update of a(k+1:n,k+1:n) as ! a := a - l(k)*d(k)*l(k)**t - ! = a - w(k)*(1/d(k))*w(k)**t + ! = a - w(k)*(1_${ik}$/d(k))*w(k)**t ! = a - (w(k)/d(k))*(d(k))*(w(k)/d(k))**t - call stdlib_ssyr( uplo, n-k, -d11, a( k+1, k ), 1,a( k+1, k+1 ), lda ) + call stdlib${ii}$_ssyr( uplo, n-k, -d11, a( k+1, k ), 1_${ik}$,a( k+1, k+1 ), lda ) end if end if else - ! 2-by-2 pivot block d(k): columns k and k+1 now hold + ! 2_${ik}$-by-2 pivot block d(k): columns k and k+1 now hold ! ( w(k) w(k+1) ) = ( l(k) l(k+1) )*d(k) ! where l(k) and l(k+1) are the k-th and (k+1)-th columns ! of l @@ -19311,7 +19313,7 @@ module stdlib_linalg_lapack_s end if end if ! store details of the interchanges in ipiv - if( kstep==1 ) then + if( kstep==1_${ik}$ ) then ipiv( k ) = kp else ipiv( k ) = -p @@ -19323,78 +19325,78 @@ module stdlib_linalg_lapack_s end if 70 continue return - end subroutine stdlib_ssytf2_rook + end subroutine stdlib${ii}$_ssytf2_rook - pure subroutine stdlib_ssytrf_rk( uplo, n, a, lda, e, ipiv, work, lwork,info ) + pure subroutine stdlib${ii}$_ssytrf_rk( uplo, n, a, lda, e, ipiv, work, lwork,info ) !! SSYTRF_RK computes the factorization of a real symmetric matrix A !! using the bounded Bunch-Kaufman (rook) diagonal pivoting method: !! A = P*U*D*(U**T)*(P**T) or A = P*L*D*(L**T)*(P**T), !! where U (or L) is unit upper (or lower) triangular matrix, !! U**T (or L**T) is the transpose of U (or L), P is a permutation !! matrix, P**T is the transpose of P, and D is symmetric and block - !! diagonal with 1-by-1 and 2-by-2 diagonal blocks. - !! This is the blocked version of the algorithm, calling Level 3 BLAS. + !! diagonal with 1_${ik}$-by-1 and 2_${ik}$-by-2 diagonal blocks. + !! This is the blocked version of the algorithm, calling Level 3_${ik}$ BLAS. !! For more information see Further Details section. ! -- lapack computational routine -- ! -- lapack is a software package provided by univ. of tennessee, -- ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda, lwork, n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, lwork, n ! Array Arguments - integer(ilp), intent(out) :: ipiv(*) + integer(${ik}$), intent(out) :: ipiv(*) real(sp), intent(inout) :: a(lda,*) real(sp), intent(out) :: e(*), work(*) ! ===================================================================== ! Local Scalars logical(lk) :: lquery, upper - integer(ilp) :: i, iinfo, ip, iws, k, kb, ldwork, lwkopt, nb, nbmin + integer(${ik}$) :: i, iinfo, ip, iws, k, kb, ldwork, lwkopt, nb, nbmin ! Intrinsic Functions intrinsic :: abs,max ! Executable Statements ! test the input parameters. - info = 0 + info = 0_${ik}$ upper = stdlib_lsame( uplo, 'U' ) - lquery = ( lwork==-1 ) + lquery = ( lwork==-1_${ik}$ ) if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then - info = -1 - else if( n<0 ) then - info = -2 - else if( lda1 .and. nb1_${ik}$ .and. nbnb ) then ! factorize columns k-kb+1:k of a and use blocked code to - ! update columns 1:k-kb - call stdlib_slasyf_rk( uplo, k, nb, kb, a, lda, e,ipiv, work, ldwork, iinfo ) + ! update columns 1_${ik}$:k-kb + call stdlib${ii}$_slasyf_rk( uplo, k, nb, kb, a, lda, e,ipiv, work, ldwork, iinfo ) else - ! use unblocked code to factorize columns 1:k of a - call stdlib_ssytf2_rk( uplo, k, a, lda, e, ipiv, iinfo ) + ! use unblocked code to factorize columns 1_${ik}$:k of a + call stdlib${ii}$_ssytf2_rk( uplo, k, a, lda, e, ipiv, iinfo ) kb = k end if ! set info on the first occurrence of a zero pivot - if( info==0 .and. iinfo>0 )info = iinfo + if( info==0_${ik}$ .and. iinfo>0_${ik}$ )info = iinfo ! no need to adjust ipiv - ! apply permutations to the leading panel 1:k-1 + ! apply permutations to the leading panel 1_${ik}$:k-1 ! read ipiv from the last block factored, i.e. ! indices k-kb+1:k and apply row permutations to the ! last k+1 colunms k+1:n after that block ! (we can do the simple loop over ipiv with decrement -1, ! since the abs value of ipiv( i ) represents the row index - ! of the interchange with row i in both 1x1 and 2x2 pivot cases) + ! of the interchange with row i in both 1_${ik}$x1 and 2_${ik}$x2 pivot cases) if( k n, exit from loop if( k>n )go to 35 if( k<=n-nb ) then ! factorize columns k:k+kb-1 of a and use blocked code to ! update columns k+kb:n - call stdlib_slasyf_rk( uplo, n-k+1, nb, kb, a( k, k ), lda, e( k ),ipiv( k ), & + call stdlib${ii}$_slasyf_rk( uplo, n-k+1, nb, kb, a( k, k ), lda, e( k ),ipiv( k ), & work, ldwork, iinfo ) else ! use unblocked code to factorize columns k:n of a - call stdlib_ssytf2_rk( uplo, n-k+1, a( k, k ), lda, e( k ),ipiv( k ), iinfo ) + call stdlib${ii}$_ssytf2_rk( uplo, n-k+1, a( k, k ), lda, e( k ),ipiv( k ), iinfo ) - kb = n - k + 1 + kb = n - k + 1_${ik}$ end if ! set info on the first occurrence of a zero pivot - if( info==0 .and. iinfo>0 )info = iinfo + k - 1 + if( info==0_${ik}$ .and. iinfo>0_${ik}$ )info = iinfo + k - 1_${ik}$ ! adjust ipiv do i = k, k + kb - 1 - if( ipiv( i )>0 ) then - ipiv( i ) = ipiv( i ) + k - 1 + if( ipiv( i )>0_${ik}$ ) then + ipiv( i ) = ipiv( i ) + k - 1_${ik}$ else - ipiv( i ) = ipiv( i ) - k + 1 + ipiv( i ) = ipiv( i ) - k + 1_${ik}$ end if end do - ! apply permutations to the leading panel 1:k-1 + ! apply permutations to the leading panel 1_${ik}$:k-1 ! read ipiv from the last block factored, i.e. ! indices k:k+kb-1 and apply row permutations to the - ! first k-1 colunms 1:k-1 before that block + ! first k-1 colunms 1_${ik}$:k-1 before that block ! (we can do the simple loop over ipiv with increment 1, ! since the abs value of ipiv( i ) represents the row index - ! of the interchange with row i in both 1x1 and 2x2 pivot cases) - if( k>1 ) then + ! of the interchange with row i in both 1_${ik}$x1 and 2_${ik}$x2 pivot cases) + if( k>1_${ik}$ ) then do i = k, ( k + kb - 1 ), 1 ip = abs( ipiv( i ) ) if( ip/=i ) then - call stdlib_sswap( k-1, a( i, 1 ), lda,a( ip, 1 ), lda ) + call stdlib${ii}$_sswap( k-1, a( i, 1_${ik}$ ), lda,a( ip, 1_${ik}$ ), lda ) end if end do end if @@ -19483,83 +19485,83 @@ module stdlib_linalg_lapack_s k = k + kb go to 20 ! this label is the exit from main loop over k increasing - ! from 1 to n in steps of kb + ! from 1_${ik}$ to n in steps of kb 35 continue ! end lower end if - work( 1 ) = lwkopt + work( 1_${ik}$ ) = lwkopt return - end subroutine stdlib_ssytrf_rk + end subroutine stdlib${ii}$_ssytrf_rk - pure subroutine stdlib_ssytrf_rook( uplo, n, a, lda, ipiv, work, lwork, info ) + pure subroutine stdlib${ii}$_ssytrf_rook( uplo, n, a, lda, ipiv, work, lwork, info ) !! SSYTRF_ROOK computes the factorization of a real symmetric matrix A !! using the bounded Bunch-Kaufman ("rook") diagonal pivoting method. !! The form of the factorization is !! A = U*D*U**T or A = L*D*L**T !! where U (or L) is a product of permutation and unit upper (lower) !! triangular matrices, and D is symmetric and block diagonal with - !! 1-by-1 and 2-by-2 diagonal blocks. - !! This is the blocked version of the algorithm, calling Level 3 BLAS. + !! 1_${ik}$-by-1 and 2_${ik}$-by-2 diagonal blocks. + !! This is the blocked version of the algorithm, calling Level 3_${ik}$ BLAS. ! -- lapack computational routine -- ! -- lapack is a software package provided by univ. of tennessee, -- ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda, lwork, n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, lwork, n ! Array Arguments - integer(ilp), intent(out) :: ipiv(*) + integer(${ik}$), intent(out) :: ipiv(*) real(sp), intent(inout) :: a(lda,*) real(sp), intent(out) :: work(*) ! ===================================================================== ! Local Scalars logical(lk) :: lquery, upper - integer(ilp) :: iinfo, iws, j, k, kb, ldwork, lwkopt, nb, nbmin + integer(${ik}$) :: iinfo, iws, j, k, kb, ldwork, lwkopt, nb, nbmin ! Intrinsic Functions intrinsic :: max ! Executable Statements ! test the input parameters. - info = 0 + info = 0_${ik}$ upper = stdlib_lsame( uplo, 'U' ) - lquery = ( lwork==-1 ) + lquery = ( lwork==-1_${ik}$ ) if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then - info = -1 - else if( n<0 ) then - info = -2 - else if( lda1 .and. nb1_${ik}$ .and. nbnb ) then ! factorize columns k-kb+1:k of a and use blocked code to - ! update columns 1:k-kb - call stdlib_slasyf_rook( uplo, k, nb, kb, a, lda,ipiv, work, ldwork, iinfo ) + ! update columns 1_${ik}$:k-kb + call stdlib${ii}$_slasyf_rook( uplo, k, nb, kb, a, lda,ipiv, work, ldwork, iinfo ) else - ! use unblocked code to factorize columns 1:k of a - call stdlib_ssytf2_rook( uplo, k, a, lda, ipiv, iinfo ) + ! use unblocked code to factorize columns 1_${ik}$:k of a + call stdlib${ii}$_ssytf2_rook( uplo, k, a, lda, ipiv, iinfo ) kb = k end if ! set info on the first occurrence of a zero pivot - if( info==0 .and. iinfo>0 )info = iinfo + if( info==0_${ik}$ .and. iinfo>0_${ik}$ )info = iinfo ! no need to adjust ipiv ! decrease k and return to the start of the main loop k = k - kb go to 10 else ! factorize a as l*d*l**t using the lower triangle of a - ! k is the main loop index, increasing from 1 to n in steps of - ! kb, where kb is the number of columns factorized by stdlib_slasyf_rook; + ! k is the main loop index, increasing from 1_${ik}$ to n in steps of + ! kb, where kb is the number of columns factorized by stdlib${ii}$_slasyf_rook; ! kb is either nb or nb-1, or n-k+1 for the last block - k = 1 + k = 1_${ik}$ 20 continue ! if k > n, exit from loop if( k>n )go to 40 if( k<=n-nb ) then ! factorize columns k:k+kb-1 of a and use blocked code to ! update columns k+kb:n - call stdlib_slasyf_rook( uplo, n-k+1, nb, kb, a( k, k ), lda,ipiv( k ), work, & + call stdlib${ii}$_slasyf_rook( uplo, n-k+1, nb, kb, a( k, k ), lda,ipiv( k ), work, & ldwork, iinfo ) else ! use unblocked code to factorize columns k:n of a - call stdlib_ssytf2_rook( uplo, n-k+1, a( k, k ), lda, ipiv( k ),iinfo ) - kb = n - k + 1 + call stdlib${ii}$_ssytf2_rook( uplo, n-k+1, a( k, k ), lda, ipiv( k ),iinfo ) + kb = n - k + 1_${ik}$ end if ! set info on the first occurrence of a zero pivot - if( info==0 .and. iinfo>0 )info = iinfo + k - 1 + if( info==0_${ik}$ .and. iinfo>0_${ik}$ )info = iinfo + k - 1_${ik}$ ! adjust ipiv do j = k, k + kb - 1 - if( ipiv( j )>0 ) then - ipiv( j ) = ipiv( j ) + k - 1 + if( ipiv( j )>0_${ik}$ ) then + ipiv( j ) = ipiv( j ) + k - 1_${ik}$ else - ipiv( j ) = ipiv( j ) - k + 1 + ipiv( j ) = ipiv( j ) - k + 1_${ik}$ end if end do ! increase k and return to the start of the main loop @@ -19615,12 +19617,12 @@ module stdlib_linalg_lapack_s go to 20 end if 40 continue - work( 1 ) = lwkopt + work( 1_${ik}$ ) = lwkopt return - end subroutine stdlib_ssytrf_rook + end subroutine stdlib${ii}$_ssytrf_rook - pure subroutine stdlib_ssytri( uplo, n, a, lda, ipiv, work, info ) + pure subroutine stdlib${ii}$_ssytri( uplo, n, a, lda, ipiv, work, info ) !! SSYTRI 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 !! SSYTRF. @@ -19629,33 +19631,33 @@ module stdlib_linalg_lapack_s ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda, n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, n ! Array Arguments - integer(ilp), intent(in) :: ipiv(*) + integer(${ik}$), intent(in) :: ipiv(*) real(sp), intent(inout) :: a(lda,*) real(sp), intent(out) :: work(*) ! ===================================================================== ! Local Scalars logical(lk) :: upper - integer(ilp) :: k, kp, kstep + integer(${ik}$) :: k, kp, kstep real(sp) :: ak, akkp1, akp1, d, t, temp ! Intrinsic Functions intrinsic :: abs,max ! Executable Statements ! test the input parameters. - info = 0 + info = 0_${ik}$ upper = stdlib_lsame( uplo, 'U' ) if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then - info = -1 - else if( n<0 ) then - info = -2 - else if( lda0 .and. a( info, info )==zero )return end do end if - info = 0 + info = 0_${ik}$ if( upper ) then ! compute inv(a) from the factorization a = u*d*u**t. - ! k is the main loop index, increasing from 1 to n in steps of - ! 1 or 2, depending on the size of the diagonal blocks. - k = 1 + ! k is the main loop index, increasing from 1_${ik}$ to n in steps of + ! 1_${ik}$ or 2_${ik}$, depending on the size of the diagonal blocks. + k = 1_${ik}$ 30 continue ! if k > n, exit from loop. if( k>n )go to 40 - if( ipiv( k )>0 ) then - ! 1 x 1 diagonal block + if( ipiv( k )>0_${ik}$ ) then + ! 1_${ik}$ x 1_${ik}$ diagonal block ! invert the diagonal block. a( k, k ) = one / a( k, k ) ! compute column k of the inverse. - if( k>1 ) then - call stdlib_scopy( k-1, a( 1, k ), 1, work, 1 ) - call stdlib_ssymv( uplo, k-1, -one, a, lda, work, 1, zero,a( 1, k ), 1 ) + if( k>1_${ik}$ ) then + call stdlib${ii}$_scopy( k-1, a( 1_${ik}$, k ), 1_${ik}$, work, 1_${ik}$ ) + call stdlib${ii}$_ssymv( uplo, k-1, -one, a, lda, work, 1_${ik}$, zero,a( 1_${ik}$, k ), 1_${ik}$ ) - a( k, k ) = a( k, k ) - stdlib_sdot( k-1, work, 1, a( 1, k ),1 ) + a( k, k ) = a( k, k ) - stdlib${ii}$_sdot( k-1, work, 1_${ik}$, a( 1_${ik}$, k ),1_${ik}$ ) end if - kstep = 1 + kstep = 1_${ik}$ else - ! 2 x 2 diagonal block + ! 2_${ik}$ x 2_${ik}$ diagonal block ! invert the diagonal block. t = abs( a( k, k+1 ) ) ak = a( k, k ) / t @@ -19705,31 +19707,31 @@ module stdlib_linalg_lapack_s a( k+1, k+1 ) = ak / d a( k, k+1 ) = -akkp1 / d ! compute columns k and k+1 of the inverse. - if( k>1 ) then - call stdlib_scopy( k-1, a( 1, k ), 1, work, 1 ) - call stdlib_ssymv( uplo, k-1, -one, a, lda, work, 1, zero,a( 1, k ), 1 ) + if( k>1_${ik}$ ) then + call stdlib${ii}$_scopy( k-1, a( 1_${ik}$, k ), 1_${ik}$, work, 1_${ik}$ ) + call stdlib${ii}$_ssymv( uplo, k-1, -one, a, lda, work, 1_${ik}$, zero,a( 1_${ik}$, k ), 1_${ik}$ ) - a( k, k ) = a( k, k ) - stdlib_sdot( k-1, work, 1, a( 1, k ),1 ) - a( k, k+1 ) = a( k, k+1 ) -stdlib_sdot( k-1, a( 1, k ), 1, a( 1, k+1 ), 1 ) + a( k, k ) = a( k, k ) - stdlib${ii}$_sdot( k-1, work, 1_${ik}$, a( 1_${ik}$, k ),1_${ik}$ ) + a( k, k+1 ) = a( k, k+1 ) -stdlib${ii}$_sdot( k-1, a( 1_${ik}$, k ), 1_${ik}$, a( 1_${ik}$, k+1 ), 1_${ik}$ ) - call stdlib_scopy( k-1, a( 1, k+1 ), 1, work, 1 ) - call stdlib_ssymv( uplo, k-1, -one, a, lda, work, 1, zero,a( 1, k+1 ), 1 ) + call stdlib${ii}$_scopy( k-1, a( 1_${ik}$, k+1 ), 1_${ik}$, work, 1_${ik}$ ) + call stdlib${ii}$_ssymv( uplo, k-1, -one, a, lda, work, 1_${ik}$, zero,a( 1_${ik}$, k+1 ), 1_${ik}$ ) - a( k+1, k+1 ) = a( k+1, k+1 ) -stdlib_sdot( k-1, work, 1, a( 1, k+1 ), 1 ) + a( k+1, k+1 ) = a( k+1, k+1 ) -stdlib${ii}$_sdot( k-1, work, 1_${ik}$, a( 1_${ik}$, k+1 ), 1_${ik}$ ) end if - kstep = 2 + kstep = 2_${ik}$ end if kp = abs( ipiv( k ) ) if( kp/=k ) then ! interchange rows and columns k and kp in the leading - ! submatrix a(1:k+1,1:k+1) - call stdlib_sswap( kp-1, a( 1, k ), 1, a( 1, kp ), 1 ) - call stdlib_sswap( k-kp-1, a( kp+1, k ), 1, a( kp, kp+1 ), lda ) + ! submatrix a(1_${ik}$:k+1,1_${ik}$:k+1) + call stdlib${ii}$_sswap( kp-1, a( 1_${ik}$, k ), 1_${ik}$, a( 1_${ik}$, kp ), 1_${ik}$ ) + call stdlib${ii}$_sswap( k-kp-1, a( kp+1, k ), 1_${ik}$, a( kp, kp+1 ), lda ) temp = a( k, k ) a( k, k ) = a( kp, kp ) a( kp, kp ) = temp - if( kstep==2 ) then + if( kstep==2_${ik}$ ) then temp = a( k, k+1 ) a( k, k+1 ) = a( kp, k+1 ) a( kp, k+1 ) = temp @@ -19740,26 +19742,26 @@ module stdlib_linalg_lapack_s 40 continue else ! compute inv(a) from the factorization a = l*d*l**t. - ! k is the main loop index, increasing from 1 to n in steps of - ! 1 or 2, depending on the size of the diagonal blocks. + ! k is the main loop index, increasing from 1_${ik}$ to n in steps of + ! 1_${ik}$ or 2_${ik}$, depending on the size of the diagonal blocks. k = n 50 continue ! if k < 1, exit from loop. if( k<1 )go to 60 - if( ipiv( k )>0 ) then - ! 1 x 1 diagonal block + if( ipiv( k )>0_${ik}$ ) then + ! 1_${ik}$ x 1_${ik}$ diagonal block ! invert the diagonal block. a( k, k ) = one / a( k, k ) ! compute column k of the inverse. if( k0 .and. a( info, info )==zero )return end do end if - info = 0 + info = 0_${ik}$ if( upper ) then ! compute inv(a) from the factorization a = u*d*u**t. - ! k is the main loop index, increasing from 1 to n in steps of - ! 1 or 2, depending on the size of the diagonal blocks. - k = 1 + ! k is the main loop index, increasing from 1_${ik}$ to n in steps of + ! 1_${ik}$ or 2_${ik}$, depending on the size of the diagonal blocks. + k = 1_${ik}$ 30 continue ! if k > n, exit from loop. if( k>n )go to 40 - if( ipiv( k )>0 ) then - ! 1 x 1 diagonal block + if( ipiv( k )>0_${ik}$ ) then + ! 1_${ik}$ x 1_${ik}$ diagonal block ! invert the diagonal block. a( k, k ) = one / a( k, k ) ! compute column k of the inverse. - if( k>1 ) then - call stdlib_scopy( k-1, a( 1, k ), 1, work, 1 ) - call stdlib_ssymv( uplo, k-1, -one, a, lda, work, 1, zero,a( 1, k ), 1 ) + if( k>1_${ik}$ ) then + call stdlib${ii}$_scopy( k-1, a( 1_${ik}$, k ), 1_${ik}$, work, 1_${ik}$ ) + call stdlib${ii}$_ssymv( uplo, k-1, -one, a, lda, work, 1_${ik}$, zero,a( 1_${ik}$, k ), 1_${ik}$ ) - a( k, k ) = a( k, k ) - stdlib_sdot( k-1, work, 1, a( 1, k ),1 ) + a( k, k ) = a( k, k ) - stdlib${ii}$_sdot( k-1, work, 1_${ik}$, a( 1_${ik}$, k ),1_${ik}$ ) end if - kstep = 1 + kstep = 1_${ik}$ else - ! 2 x 2 diagonal block + ! 2_${ik}$ x 2_${ik}$ diagonal block ! invert the diagonal block. t = abs( a( k, k+1 ) ) ak = a( k, k ) / t @@ -19893,39 +19895,39 @@ module stdlib_linalg_lapack_s a( k+1, k+1 ) = ak / d a( k, k+1 ) = -akkp1 / d ! compute columns k and k+1 of the inverse. - if( k>1 ) then - call stdlib_scopy( k-1, a( 1, k ), 1, work, 1 ) - call stdlib_ssymv( uplo, k-1, -one, a, lda, work, 1, zero,a( 1, k ), 1 ) + if( k>1_${ik}$ ) then + call stdlib${ii}$_scopy( k-1, a( 1_${ik}$, k ), 1_${ik}$, work, 1_${ik}$ ) + call stdlib${ii}$_ssymv( uplo, k-1, -one, a, lda, work, 1_${ik}$, zero,a( 1_${ik}$, k ), 1_${ik}$ ) - a( k, k ) = a( k, k ) - stdlib_sdot( k-1, work, 1, a( 1, k ),1 ) - a( k, k+1 ) = a( k, k+1 ) -stdlib_sdot( k-1, a( 1, k ), 1, a( 1, k+1 ), 1 ) + a( k, k ) = a( k, k ) - stdlib${ii}$_sdot( k-1, work, 1_${ik}$, a( 1_${ik}$, k ),1_${ik}$ ) + a( k, k+1 ) = a( k, k+1 ) -stdlib${ii}$_sdot( k-1, a( 1_${ik}$, k ), 1_${ik}$, a( 1_${ik}$, k+1 ), 1_${ik}$ ) - call stdlib_scopy( k-1, a( 1, k+1 ), 1, work, 1 ) - call stdlib_ssymv( uplo, k-1, -one, a, lda, work, 1, zero,a( 1, k+1 ), 1 ) + call stdlib${ii}$_scopy( k-1, a( 1_${ik}$, k+1 ), 1_${ik}$, work, 1_${ik}$ ) + call stdlib${ii}$_ssymv( uplo, k-1, -one, a, lda, work, 1_${ik}$, zero,a( 1_${ik}$, k+1 ), 1_${ik}$ ) - a( k+1, k+1 ) = a( k+1, k+1 ) -stdlib_sdot( k-1, work, 1, a( 1, k+1 ), 1 ) + a( k+1, k+1 ) = a( k+1, k+1 ) -stdlib${ii}$_sdot( k-1, work, 1_${ik}$, a( 1_${ik}$, k+1 ), 1_${ik}$ ) end if - kstep = 2 + kstep = 2_${ik}$ end if - if( kstep==1 ) then + if( kstep==1_${ik}$ ) then ! interchange rows and columns k and ipiv(k) in the leading - ! submatrix a(1:k+1,1:k+1) + ! submatrix a(1_${ik}$:k+1,1_${ik}$:k+1) kp = ipiv( k ) if( kp/=k ) then - if( kp>1 )call stdlib_sswap( kp-1, a( 1, k ), 1, a( 1, kp ), 1 ) - call stdlib_sswap( k-kp-1, a( kp+1, k ), 1, a( kp, kp+1 ), lda ) + if( kp>1_${ik}$ )call stdlib${ii}$_sswap( kp-1, a( 1_${ik}$, k ), 1_${ik}$, a( 1_${ik}$, kp ), 1_${ik}$ ) + call stdlib${ii}$_sswap( k-kp-1, a( kp+1, k ), 1_${ik}$, a( kp, kp+1 ), lda ) temp = a( k, k ) a( k, k ) = a( kp, kp ) a( kp, kp ) = temp end if else ! interchange rows and columns k and k+1 with -ipiv(k) and - ! -ipiv(k+1)in the leading submatrix a(1:k+1,1:k+1) + ! -ipiv(k+1)in the leading submatrix a(1_${ik}$:k+1,1_${ik}$:k+1) kp = -ipiv( k ) if( kp/=k ) then - if( kp>1 )call stdlib_sswap( kp-1, a( 1, k ), 1, a( 1, kp ), 1 ) - call stdlib_sswap( k-kp-1, a( kp+1, k ), 1, a( kp, kp+1 ), lda ) + if( kp>1_${ik}$ )call stdlib${ii}$_sswap( kp-1, a( 1_${ik}$, k ), 1_${ik}$, a( 1_${ik}$, kp ), 1_${ik}$ ) + call stdlib${ii}$_sswap( k-kp-1, a( kp+1, k ), 1_${ik}$, a( kp, kp+1 ), lda ) temp = a( k, k ) a( k, k ) = a( kp, kp ) a( kp, kp ) = temp @@ -19933,41 +19935,41 @@ module stdlib_linalg_lapack_s a( k, k+1 ) = a( kp, k+1 ) a( kp, k+1 ) = temp end if - k = k + 1 + k = k + 1_${ik}$ kp = -ipiv( k ) if( kp/=k ) then - if( kp>1 )call stdlib_sswap( kp-1, a( 1, k ), 1, a( 1, kp ), 1 ) - call stdlib_sswap( k-kp-1, a( kp+1, k ), 1, a( kp, kp+1 ), lda ) + if( kp>1_${ik}$ )call stdlib${ii}$_sswap( kp-1, a( 1_${ik}$, k ), 1_${ik}$, a( 1_${ik}$, kp ), 1_${ik}$ ) + call stdlib${ii}$_sswap( k-kp-1, a( kp+1, k ), 1_${ik}$, a( kp, kp+1 ), lda ) temp = a( k, k ) a( k, k ) = a( kp, kp ) a( kp, kp ) = temp end if end if - k = k + 1 + k = k + 1_${ik}$ go to 30 40 continue else ! compute inv(a) from the factorization a = l*d*l**t. - ! k is the main loop index, increasing from 1 to n in steps of - ! 1 or 2, depending on the size of the diagonal blocks. + ! k is the main loop index, increasing from 1_${ik}$ to n in steps of + ! 1_${ik}$ or 2_${ik}$, depending on the size of the diagonal blocks. k = n 50 continue ! if k < 1, exit from loop. if( k<1 )go to 60 - if( ipiv( k )>0 ) then - ! 1 x 1 diagonal block + if( ipiv( k )>0_${ik}$ ) then + ! 1_${ik}$ x 1_${ik}$ diagonal block ! invert the diagonal block. a( k, k ) = one / a( k, k ) ! compute column k of the inverse. if( k0 ) then - ! 1 x 1 diagonal block + if( ipiv( k )>0_${ik}$ ) then + ! 1_${ik}$ x 1_${ik}$ diagonal block ! interchange rows k and ipiv(k). kp = ipiv( k ) - if( kp/=k )call stdlib_sswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib${ii}$_sswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) ! multiply by inv(u(k)), where u(k) is the transformation ! stored in column k of a. - call stdlib_sger( k-1, nrhs, -one, a( 1, k ), 1, b( k, 1 ), ldb,b( 1, 1 ), ldb ) + call stdlib${ii}$_sger( k-1, nrhs, -one, a( 1_${ik}$, k ), 1_${ik}$, b( k, 1_${ik}$ ), ldb,b( 1_${ik}$, 1_${ik}$ ), ldb ) ! multiply by the inverse of the diagonal block. - call stdlib_sscal( nrhs, one / a( k, k ), b( k, 1 ), ldb ) - k = k - 1 + call stdlib${ii}$_sscal( nrhs, one / a( k, k ), b( k, 1_${ik}$ ), ldb ) + k = k - 1_${ik}$ else - ! 2 x 2 diagonal block + ! 2_${ik}$ x 2_${ik}$ diagonal block ! interchange rows k-1 and -ipiv(k). kp = -ipiv( k ) - if( kp/=k-1 )call stdlib_sswap( nrhs, b( k-1, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k-1 )call stdlib${ii}$_sswap( nrhs, b( k-1, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) ! multiply by inv(u(k)), where u(k) is the transformation ! stored in columns k-1 and k of a. - call stdlib_sger( k-2, nrhs, -one, a( 1, k ), 1, b( k, 1 ), ldb,b( 1, 1 ), ldb ) + call stdlib${ii}$_sger( k-2, nrhs, -one, a( 1_${ik}$, k ), 1_${ik}$, b( k, 1_${ik}$ ), ldb,b( 1_${ik}$, 1_${ik}$ ), ldb ) - call stdlib_sger( k-2, nrhs, -one, a( 1, k-1 ), 1, b( k-1, 1 ),ldb, b( 1, 1 ), & + call stdlib${ii}$_sger( k-2, nrhs, -one, a( 1_${ik}$, k-1 ), 1_${ik}$, b( k-1, 1_${ik}$ ),ldb, b( 1_${ik}$, 1_${ik}$ ), & ldb ) ! multiply by the inverse of the diagonal block. akm1k = a( k-1, k ) @@ -20122,75 +20124,75 @@ module stdlib_linalg_lapack_s b( k-1, j ) = ( ak*bkm1-bk ) / denom b( k, j ) = ( akm1*bk-bkm1 ) / denom end do - k = k - 2 + k = k - 2_${ik}$ end if go to 10 30 continue ! next solve u**t *x = b, overwriting b with x. - ! k is the main loop index, increasing from 1 to n in steps of - ! 1 or 2, depending on the size of the diagonal blocks. - k = 1 + ! k is the main loop index, increasing from 1_${ik}$ to n in steps of + ! 1_${ik}$ or 2_${ik}$, depending on the size of the diagonal blocks. + k = 1_${ik}$ 40 continue ! if k > n, exit from loop. if( k>n )go to 50 - if( ipiv( k )>0 ) then - ! 1 x 1 diagonal block + if( ipiv( k )>0_${ik}$ ) then + ! 1_${ik}$ x 1_${ik}$ diagonal block ! multiply by inv(u**t(k)), where u(k) is the transformation ! stored in column k of a. - call stdlib_sgemv( 'TRANSPOSE', k-1, nrhs, -one, b, ldb, a( 1, k ),1, one, b( k, & - 1 ), ldb ) + call stdlib${ii}$_sgemv( 'TRANSPOSE', k-1, nrhs, -one, b, ldb, a( 1_${ik}$, k ),1_${ik}$, one, b( k, & + 1_${ik}$ ), ldb ) ! interchange rows k and ipiv(k). kp = ipiv( k ) - if( kp/=k )call stdlib_sswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) - k = k + 1 + if( kp/=k )call stdlib${ii}$_sswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) + k = k + 1_${ik}$ else - ! 2 x 2 diagonal block + ! 2_${ik}$ x 2_${ik}$ diagonal block ! multiply by inv(u**t(k+1)), where u(k+1) is the transformation ! stored in columns k and k+1 of a. - call stdlib_sgemv( 'TRANSPOSE', k-1, nrhs, -one, b, ldb, a( 1, k ),1, one, b( k, & - 1 ), ldb ) - call stdlib_sgemv( 'TRANSPOSE', k-1, nrhs, -one, b, ldb,a( 1, k+1 ), 1, one, b( & - k+1, 1 ), ldb ) + call stdlib${ii}$_sgemv( 'TRANSPOSE', k-1, nrhs, -one, b, ldb, a( 1_${ik}$, k ),1_${ik}$, one, b( k, & + 1_${ik}$ ), ldb ) + call stdlib${ii}$_sgemv( 'TRANSPOSE', k-1, nrhs, -one, b, ldb,a( 1_${ik}$, k+1 ), 1_${ik}$, one, b( & + k+1, 1_${ik}$ ), ldb ) ! interchange rows k and -ipiv(k). kp = -ipiv( k ) - if( kp/=k )call stdlib_sswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) - k = k + 2 + if( kp/=k )call stdlib${ii}$_sswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) + k = k + 2_${ik}$ end if go to 40 50 continue else ! solve a*x = b, where a = l*d*l**t. ! first solve l*d*x = b, overwriting b with x. - ! k is the main loop index, increasing from 1 to n in steps of - ! 1 or 2, depending on the size of the diagonal blocks. - k = 1 + ! k is the main loop index, increasing from 1_${ik}$ to n in steps of + ! 1_${ik}$ or 2_${ik}$, depending on the size of the diagonal blocks. + k = 1_${ik}$ 60 continue ! if k > n, exit from loop. if( k>n )go to 80 - if( ipiv( k )>0 ) then - ! 1 x 1 diagonal block + if( ipiv( k )>0_${ik}$ ) then + ! 1_${ik}$ x 1_${ik}$ diagonal block ! interchange rows k and ipiv(k). kp = ipiv( k ) - if( kp/=k )call stdlib_sswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib${ii}$_sswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) ! multiply by inv(l(k)), where l(k) is the transformation ! stored in column k of a. - if( k0 ) then - ! 1 x 1 diagonal block + if( ipiv( k )>0_${ik}$ ) then + ! 1_${ik}$ x 1_${ik}$ diagonal block ! multiply by inv(l**t(k)), where l(k) is the transformation ! stored in column k of a. - if( k= 1 ) - if( ipiv( k )>0 ) then - ! 1 x 1 diagonal block + if( ipiv( k )>0_${ik}$ ) then + ! 1_${ik}$ x 1_${ik}$ diagonal block ! interchange rows k and ipiv(k). kp = ipiv( k ) - if( kp/=k )call stdlib_sswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib${ii}$_sswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) k=k-1 else - ! 2 x 2 diagonal block + ! 2_${ik}$ x 2_${ik}$ diagonal block ! interchange rows k-1 and -ipiv(k). kp = -ipiv( k ) - if( kp==-ipiv( k-1 ) )call stdlib_sswap( nrhs, b( k-1, 1 ), ldb, b( kp, 1 ), ldb & + if( kp==-ipiv( k-1 ) )call stdlib${ii}$_sswap( nrhs, b( k-1, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb & ) k=k-2 end if end do ! compute (u \p**t * b) -> b [ (u \p**t * b) ] - call stdlib_strsm('L','U','N','U',n,nrhs,one,a,lda,b,ldb) + call stdlib${ii}$_strsm('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_sscal( nrhs, one / a( i, i ), b( i, 1 ), ldb ) - elseif ( i > 1) then + if( ipiv(i) > 0_${ik}$ ) then + call stdlib${ii}$_sscal( nrhs, one / a( i, i ), b( i, 1_${ik}$ ), ldb ) + elseif ( i > 1_${ik}$) then if ( ipiv(i-1) == ipiv(i) ) then akm1k = work(i) akm1 = a( i-1, i-1 ) / akm1k @@ -20330,58 +20332,58 @@ module stdlib_linalg_lapack_s b( i-1, j ) = ( ak*bkm1-bk ) / denom b( i, j ) = ( akm1*bk-bkm1 ) / denom end do - i = i - 1 + i = i - 1_${ik}$ endif endif - i = i - 1 + i = i - 1_${ik}$ end do ! compute (u**t \ b) -> b [ u**t \ (d \ (u \p**t * b) ) ] - call stdlib_strsm('L','U','T','U',n,nrhs,one,a,lda,b,ldb) + call stdlib${ii}$_strsm('L','U','T','U',n,nrhs,one,a,lda,b,ldb) ! p * b [ p * (u**t \ (d \ (u \p**t * b) )) ] - k=1 + k=1_${ik}$ do while ( k <= n ) - if( ipiv( k )>0 ) then - ! 1 x 1 diagonal block + if( ipiv( k )>0_${ik}$ ) then + ! 1_${ik}$ x 1_${ik}$ diagonal block ! interchange rows k and ipiv(k). kp = ipiv( k ) - if( kp/=k )call stdlib_sswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib${ii}$_sswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) k=k+1 else - ! 2 x 2 diagonal block + ! 2_${ik}$ x 2_${ik}$ diagonal block ! interchange rows k-1 and -ipiv(k). kp = -ipiv( k ) - if( k < n .and. kp==-ipiv( k+1 ) )call stdlib_sswap( nrhs, b( k, 1 ), ldb, b( kp,& - 1 ), ldb ) + if( k < n .and. kp==-ipiv( k+1 ) )call stdlib${ii}$_sswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp,& + 1_${ik}$ ), ldb ) k=k+2 endif end do else ! solve a*x = b, where a = l*d*l**t. ! p**t * b - k=1 + k=1_${ik}$ do while ( k <= n ) - if( ipiv( k )>0 ) then - ! 1 x 1 diagonal block + if( ipiv( k )>0_${ik}$ ) then + ! 1_${ik}$ x 1_${ik}$ diagonal block ! interchange rows k and ipiv(k). kp = ipiv( k ) - if( kp/=k )call stdlib_sswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib${ii}$_sswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) k=k+1 else - ! 2 x 2 diagonal block + ! 2_${ik}$ x 2_${ik}$ diagonal block ! interchange rows k and -ipiv(k+1). kp = -ipiv( k+1 ) - if( kp==-ipiv( k ) )call stdlib_sswap( nrhs, b( k+1, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp==-ipiv( k ) )call stdlib${ii}$_sswap( nrhs, b( k+1, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) k=k+2 endif end do ! compute (l \p**t * b) -> b [ (l \p**t * b) ] - call stdlib_strsm('L','L','N','U',n,nrhs,one,a,lda,b,ldb) + call stdlib${ii}$_strsm('L','L','N','U',n,nrhs,one,a,lda,b,ldb) ! compute d \ b -> b [ d \ (l \p**t * b) ] - i=1 + i=1_${ik}$ do while ( i <= n ) - if( ipiv(i) > 0 ) then - call stdlib_sscal( nrhs, one / a( i, i ), b( i, 1 ), ldb ) + if( ipiv(i) > 0_${ik}$ ) then + call stdlib${ii}$_sscal( nrhs, one / a( i, i ), b( i, 1_${ik}$ ), ldb ) else akm1k = work(i) akm1 = a( i, i ) / akm1k @@ -20393,38 +20395,38 @@ module stdlib_linalg_lapack_s b( i, j ) = ( ak*bkm1-bk ) / denom b( i+1, j ) = ( akm1*bk-bkm1 ) / denom end do - i = i + 1 + i = i + 1_${ik}$ endif - i = i + 1 + i = i + 1_${ik}$ end do ! compute (l**t \ b) -> b [ l**t \ (d \ (l \p**t * b) ) ] - call stdlib_strsm('L','L','T','U',n,nrhs,one,a,lda,b,ldb) + call stdlib${ii}$_strsm('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 ) - if( ipiv( k )>0 ) then - ! 1 x 1 diagonal block + if( ipiv( k )>0_${ik}$ ) then + ! 1_${ik}$ x 1_${ik}$ diagonal block ! interchange rows k and ipiv(k). kp = ipiv( k ) - if( kp/=k )call stdlib_sswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib${ii}$_sswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) k=k-1 else - ! 2 x 2 diagonal block + ! 2_${ik}$ x 2_${ik}$ diagonal block ! interchange rows k-1 and -ipiv(k). kp = -ipiv( k ) - if( k>1 .and. kp==-ipiv( k-1 ) )call stdlib_sswap( nrhs, b( k, 1 ), ldb, b( kp, & - 1 ), ldb ) + if( k>1_${ik}$ .and. kp==-ipiv( k-1 ) )call stdlib${ii}$_sswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, & + 1_${ik}$ ), ldb ) k=k-2 endif end do end if ! revert a - call stdlib_ssyconv( uplo, 'R', n, a, lda, ipiv, work, iinfo ) + call stdlib${ii}$_ssyconv( uplo, 'R', n, a, lda, ipiv, work, iinfo ) return - end subroutine stdlib_ssytrs2 + end subroutine stdlib${ii}$_ssytrs2 - pure subroutine stdlib_ssytrs_3( uplo, n, nrhs, a, lda, e, ipiv, b, ldb,info ) + pure subroutine stdlib${ii}$_ssytrs_3( uplo, n, nrhs, a, lda, e, ipiv, b, ldb,info ) !! SSYTRS_3 solves a system of linear equations A * X = B with a real !! symmetric matrix A using the factorization computed !! by SSYTRF_RK or SSYTRF_BK: @@ -20432,43 +20434,43 @@ module stdlib_linalg_lapack_s !! where U (or L) is unit upper (or lower) triangular matrix, !! U**T (or L**T) is the transpose of U (or L), P is a permutation !! matrix, P**T is the transpose of P, and D is symmetric and block - !! diagonal with 1-by-1 and 2-by-2 diagonal blocks. - !! This algorithm is using Level 3 BLAS. + !! diagonal with 1_${ik}$-by-1 and 2_${ik}$-by-2 diagonal blocks. + !! This algorithm is using Level 3_${ik}$ BLAS. ! -- lapack computational routine -- ! -- lapack is a software package provided by univ. of tennessee, -- ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda, ldb, n, nrhs + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, ldb, n, nrhs ! Array Arguments - integer(ilp), intent(in) :: ipiv(*) + integer(${ik}$), intent(in) :: ipiv(*) real(sp), intent(in) :: a(lda,*), e(*) real(sp), intent(inout) :: b(ldb,*) ! ===================================================================== ! Local Scalars logical(lk) :: upper - integer(ilp) :: i, j, k, kp + integer(${ik}$) :: i, j, k, kp real(sp) :: ak, akm1, akm1k, bk, bkm1, denom ! Intrinsic Functions intrinsic :: abs,max ! Executable Statements - info = 0 + info = 0_${ik}$ upper = stdlib_lsame( uplo, 'U' ) if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then - info = -1 - else if( n<0 ) then - info = -2 - else if( nrhs<0 ) then - info = -3 - else if( lda b [ (u \p**t * b) ] - call stdlib_strsm( 'L', 'U', 'N', 'U', n, nrhs, one, a, lda, b, ldb ) + call stdlib${ii}$_strsm( '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_sscal( nrhs, one / a( i, i ), b( i, 1 ), ldb ) - else if ( i>1 ) then + if( ipiv( i )>0_${ik}$ ) then + call stdlib${ii}$_sscal( nrhs, one / a( i, i ), b( i, 1_${ik}$ ), ldb ) + else if ( i>1_${ik}$ ) then akm1k = e( i ) akm1 = a( i-1, i-1 ) / akm1k ak = a( i, i ) / akm1k @@ -20506,22 +20508,22 @@ module stdlib_linalg_lapack_s b( i-1, j ) = ( ak*bkm1-bk ) / denom b( i, j ) = ( akm1*bk-bkm1 ) / denom end do - i = i - 1 + i = i - 1_${ik}$ end if - i = i - 1 + i = i - 1_${ik}$ end do ! compute (u**t \ b) -> b [ u**t \ (d \ (u \p**t * b) ) ] - call stdlib_strsm( 'L', 'U', 'T', 'U', n, nrhs, one, a, lda, b, ldb ) + call stdlib${ii}$_strsm( '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. ! (we can do the simple loop over ipiv with increment 1, ! since the abs value of ipiv(i) represents the row index - ! of the interchange with row i in both 1x1 and 2x2 pivot cases) + ! of the interchange with row i in both 1_${ik}$x1 and 2_${ik}$x2 pivot cases) do k = 1, n, 1 kp = abs( ipiv( k ) ) if( kp/=k ) then - call stdlib_sswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + call stdlib${ii}$_sswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) end if end do else @@ -20532,20 +20534,20 @@ module stdlib_linalg_lapack_s ! that the formation order of ipiv(i) vector for lower case. ! (we can do the simple loop over ipiv with increment 1, ! since the abs value of ipiv(i) represents the row index - ! of the interchange with row i in both 1x1 and 2x2 pivot cases) + ! of the interchange with row i in both 1_${ik}$x1 and 2_${ik}$x2 pivot cases) do k = 1, n, 1 kp = abs( ipiv( k ) ) if( kp/=k ) then - call stdlib_sswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + call stdlib${ii}$_sswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) end if end do ! compute (l \p**t * b) -> b [ (l \p**t * b) ] - call stdlib_strsm( 'L', 'L', 'N', 'U', n, nrhs, one, a, lda, b, ldb ) + call stdlib${ii}$_strsm( 'L', 'L', 'N', 'U', n, nrhs, one, a, lda, b, ldb ) ! compute d \ b -> b [ d \ (l \p**t * b) ] - i = 1 + i = 1_${ik}$ do while ( i<=n ) - if( ipiv( i )>0 ) then - call stdlib_sscal( nrhs, one / a( i, i ), b( i, 1 ), ldb ) + if( ipiv( i )>0_${ik}$ ) then + call stdlib${ii}$_sscal( nrhs, one / a( i, i ), b( i, 1_${ik}$ ), ldb ) else if( i b [ l**t \ (d \ (l \p**t * b) ) ] - call stdlib_strsm('L', 'L', 'T', 'U', n, nrhs, one, a, lda, b, ldb ) + call stdlib${ii}$_strsm('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. ! (we can do the simple loop over ipiv with decrement -1, ! since the abs value of ipiv(i) represents the row index - ! of the interchange with row i in both 1x1 and 2x2 pivot cases) + ! of the interchange with row i in both 1_${ik}$x1 and 2_${ik}$x2 pivot cases) do k = n, 1, -1 kp = abs( ipiv( k ) ) if( kp/=k ) then - call stdlib_sswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + call stdlib${ii}$_sswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) end if end do ! end lower end if return - end subroutine stdlib_ssytrs_3 + end subroutine stdlib${ii}$_ssytrs_3 - pure subroutine stdlib_ssytrs_aa( uplo, n, nrhs, a, lda, ipiv, b, ldb,work, lwork, info ) + pure subroutine stdlib${ii}$_ssytrs_aa( uplo, n, nrhs, a, lda, ipiv, b, ldb,work, lwork, info ) !! SSYTRS_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 SSYTRF_AA. @@ -20591,124 +20593,124 @@ module stdlib_linalg_lapack_s ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: uplo - integer(ilp), intent(in) :: n, nrhs, lda, ldb, lwork - integer(ilp), intent(out) :: info + integer(${ik}$), intent(in) :: n, nrhs, lda, ldb, lwork + integer(${ik}$), intent(out) :: info ! Array Arguments - integer(ilp), intent(in) :: ipiv(*) + integer(${ik}$), intent(in) :: ipiv(*) real(sp), intent(in) :: a(lda,*) real(sp), intent(inout) :: b(ldb,*) real(sp), intent(out) :: work(*) ! ===================================================================== logical(lk) :: lquery, upper - integer(ilp) :: k, kp, lwkopt + integer(${ik}$) :: k, kp, lwkopt ! Intrinsic Functions intrinsic :: max ! Executable Statements - info = 0 + info = 0_${ik}$ upper = stdlib_lsame( uplo, 'U' ) - lquery = ( lwork==-1 ) + lquery = ( lwork==-1_${ik}$ ) if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then - info = -1 - else if( n<0 ) then - info = -2 - else if( nrhs<0 ) then - info = -3 - else if( lda1 ) then + ! 1_${ik}$) forward substitution with u**t + if( n>1_${ik}$ ) then ! pivot, p**t * b -> b - k = 1 + k = 1_${ik}$ do while ( k<=n ) kp = ipiv( k ) - if( kp/=k )call stdlib_sswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) - k = k + 1 + if( kp/=k )call stdlib${ii}$_sswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) + k = k + 1_${ik}$ end do ! compute u**t \ b -> b [ (u**t \p**t * b) ] - call stdlib_strsm( 'L', 'U', 'T', 'U', n-1, nrhs, one, a( 1, 2 ),lda, b( 2, 1 ), & + call stdlib${ii}$_strsm( 'L', 'U', 'T', 'U', n-1, nrhs, one, a( 1_${ik}$, 2_${ik}$ ),lda, b( 2_${ik}$, 1_${ik}$ ), & ldb) end if - ! 2) solve with triangular matrix t + ! 2_${ik}$) solve with triangular matrix t ! compute t \ b -> b [ t \ (u**t \p**t * b) ] - call stdlib_slacpy( 'F', 1, n, a(1, 1), lda+1, work(n), 1) - if( n>1 ) then - call stdlib_slacpy( 'F', 1, n-1, a(1, 2), lda+1, work(1), 1) - call stdlib_slacpy( 'F', 1, n-1, a(1, 2), lda+1, work(2*n), 1) - end if - call stdlib_sgtsv(n, nrhs, work(1), work(n), work(2*n), b, ldb,info) - ! 3) backward substitution with u - if( n>1 ) then + call stdlib${ii}$_slacpy( 'F', 1_${ik}$, n, a(1_${ik}$, 1_${ik}$), lda+1, work(n), 1_${ik}$) + if( n>1_${ik}$ ) then + call stdlib${ii}$_slacpy( 'F', 1_${ik}$, n-1, a(1_${ik}$, 2_${ik}$), lda+1, work(1_${ik}$), 1_${ik}$) + call stdlib${ii}$_slacpy( 'F', 1_${ik}$, n-1, a(1_${ik}$, 2_${ik}$), lda+1, work(2_${ik}$*n), 1_${ik}$) + end if + call stdlib${ii}$_sgtsv(n, nrhs, work(1_${ik}$), work(n), work(2_${ik}$*n), b, ldb,info) + ! 3_${ik}$) backward substitution with u + if( n>1_${ik}$ ) then ! compute u \ b -> b [ u \ (t \ (u**t \p**t * b) ) ] - call stdlib_strsm( 'L', 'U', 'N', 'U', n-1, nrhs, one, a( 1, 2 ),lda, b(2, 1), & + call stdlib${ii}$_strsm( 'L', 'U', 'N', 'U', n-1, nrhs, one, a( 1_${ik}$, 2_${ik}$ ),lda, b(2_${ik}$, 1_${ik}$), & ldb) ! pivot, p * b -> b [ p * (u \ (t \ (u**t \p**t * b) )) ] k = n do while ( k>=1 ) kp = ipiv( k ) - if( kp/=k )call stdlib_sswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) - k = k - 1 + if( kp/=k )call stdlib${ii}$_sswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) + k = k - 1_${ik}$ end do end if else ! solve a*x = b, where a = l*t*l**t. - ! 1) forward substitution with l - if( n>1 ) then + ! 1_${ik}$) forward substitution with l + if( n>1_${ik}$ ) then ! pivot, p**t * b -> b - k = 1 + k = 1_${ik}$ do while ( k<=n ) kp = ipiv( k ) - if( kp/=k )call stdlib_sswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) - k = k + 1 + if( kp/=k )call stdlib${ii}$_sswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) + k = k + 1_${ik}$ end do ! compute l \ b -> b [ (l \p**t * b) ] - call stdlib_strsm( 'L', 'L', 'N', 'U', n-1, nrhs, one, a( 2, 1),lda, b(2, 1), & + call stdlib${ii}$_strsm( 'L', 'L', 'N', 'U', n-1, nrhs, one, a( 2_${ik}$, 1_${ik}$),lda, b(2_${ik}$, 1_${ik}$), & ldb) end if - ! 2) solve with triangular matrix t + ! 2_${ik}$) solve with triangular matrix t ! compute t \ b -> b [ t \ (l \p**t * b) ] - call stdlib_slacpy( 'F', 1, n, a(1, 1), lda+1, work(n), 1) - if( n>1 ) then - call stdlib_slacpy( 'F', 1, n-1, a(2, 1), lda+1, work(1), 1) - call stdlib_slacpy( 'F', 1, n-1, a(2, 1), lda+1, work(2*n), 1) - end if - call stdlib_sgtsv(n, nrhs, work(1), work(n), work(2*n), b, ldb,info) - ! 3) backward substitution with l**t - if( n>1 ) then + call stdlib${ii}$_slacpy( 'F', 1_${ik}$, n, a(1_${ik}$, 1_${ik}$), lda+1, work(n), 1_${ik}$) + if( n>1_${ik}$ ) then + call stdlib${ii}$_slacpy( 'F', 1_${ik}$, n-1, a(2_${ik}$, 1_${ik}$), lda+1, work(1_${ik}$), 1_${ik}$) + call stdlib${ii}$_slacpy( 'F', 1_${ik}$, n-1, a(2_${ik}$, 1_${ik}$), lda+1, work(2_${ik}$*n), 1_${ik}$) + end if + call stdlib${ii}$_sgtsv(n, nrhs, work(1_${ik}$), work(n), work(2_${ik}$*n), b, ldb,info) + ! 3_${ik}$) backward substitution with l**t + if( n>1_${ik}$ ) then ! compute l**t \ b -> b [ l**t \ (t \ (l \p**t * b) ) ] - call stdlib_strsm( 'L', 'L', 'T', 'U', n-1, nrhs, one, a( 2, 1 ),lda, b( 2, 1 ), & + call stdlib${ii}$_strsm( 'L', 'L', 'T', 'U', n-1, nrhs, one, a( 2_${ik}$, 1_${ik}$ ),lda, b( 2_${ik}$, 1_${ik}$ ), & ldb) ! pivot, p * b -> b [ p * (l**t \ (t \ (l \p**t * b) )) ] k = n do while ( k>=1 ) kp = ipiv( k ) - if( kp/=k )call stdlib_sswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) - k = k - 1 + if( kp/=k )call stdlib${ii}$_sswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) + k = k - 1_${ik}$ end do end if end if return - end subroutine stdlib_ssytrs_aa + end subroutine stdlib${ii}$_ssytrs_aa - pure subroutine stdlib_ssytrs_rook( uplo, n, nrhs, a, lda, ipiv, b, ldb,info ) + pure subroutine stdlib${ii}$_ssytrs_rook( uplo, n, nrhs, a, lda, ipiv, b, ldb,info ) !! SSYTRS_ROOK solves a system of linear equations A*X = B with !! a real symmetric matrix A using the factorization A = U*D*U**T or !! A = L*D*L**T computed by SSYTRF_ROOK. @@ -20717,36 +20719,36 @@ module stdlib_linalg_lapack_s ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda, ldb, n, nrhs + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, ldb, n, nrhs ! Array Arguments - integer(ilp), intent(in) :: ipiv(*) + integer(${ik}$), intent(in) :: ipiv(*) real(sp), intent(in) :: a(lda,*) real(sp), intent(inout) :: b(ldb,*) ! ===================================================================== ! Local Scalars logical(lk) :: upper - integer(ilp) :: j, k, kp + integer(${ik}$) :: j, k, kp real(sp) :: ak, akm1, akm1k, bk, bkm1, denom ! Intrinsic Functions intrinsic :: max ! Executable Statements - info = 0 + info = 0_${ik}$ upper = stdlib_lsame( uplo, 'U' ) if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then - info = -1 - else if( n<0 ) then - info = -2 - else if( nrhs<0 ) then - info = -3 - else if( lda0 ) then - ! 1 x 1 diagonal block + if( ipiv( k )>0_${ik}$ ) then + ! 1_${ik}$ x 1_${ik}$ diagonal block ! interchange rows k and ipiv(k). kp = ipiv( k ) - if( kp/=k )call stdlib_sswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib${ii}$_sswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) ! multiply by inv(u(k)), where u(k) is the transformation ! stored in column k of a. - call stdlib_sger( k-1, nrhs, -one, a( 1, k ), 1, b( k, 1 ), ldb,b( 1, 1 ), ldb ) + call stdlib${ii}$_sger( k-1, nrhs, -one, a( 1_${ik}$, k ), 1_${ik}$, b( k, 1_${ik}$ ), ldb,b( 1_${ik}$, 1_${ik}$ ), ldb ) ! multiply by the inverse of the diagonal block. - call stdlib_sscal( nrhs, one / a( k, k ), b( k, 1 ), ldb ) - k = k - 1 + call stdlib${ii}$_sscal( nrhs, one / a( k, k ), b( k, 1_${ik}$ ), ldb ) + k = k - 1_${ik}$ else - ! 2 x 2 diagonal block + ! 2_${ik}$ x 2_${ik}$ diagonal block ! interchange rows k and -ipiv(k) then k-1 and -ipiv(k-1) kp = -ipiv( k ) - if( kp/=k )call stdlib_sswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib${ii}$_sswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) kp = -ipiv( k-1 ) - if( kp/=k-1 )call stdlib_sswap( nrhs, b( k-1, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k-1 )call stdlib${ii}$_sswap( nrhs, b( k-1, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) ! multiply by inv(u(k)), where u(k) is the transformation ! stored in columns k-1 and k of a. - if( k>2 ) then - call stdlib_sger( k-2, nrhs, -one, a( 1, k ), 1, b( k, 1 ),ldb, b( 1, 1 ), & + if( k>2_${ik}$ ) then + call stdlib${ii}$_sger( k-2, nrhs, -one, a( 1_${ik}$, k ), 1_${ik}$, b( k, 1_${ik}$ ),ldb, b( 1_${ik}$, 1_${ik}$ ), & ldb ) - call stdlib_sger( k-2, nrhs, -one, a( 1, k-1 ), 1, b( k-1, 1 ),ldb, b( 1, 1 ),& + call stdlib${ii}$_sger( k-2, nrhs, -one, a( 1_${ik}$, k-1 ), 1_${ik}$, b( k-1, 1_${ik}$ ),ldb, b( 1_${ik}$, 1_${ik}$ ),& ldb ) end if ! multiply by the inverse of the diagonal block. @@ -20798,81 +20800,81 @@ module stdlib_linalg_lapack_s b( k-1, j ) = ( ak*bkm1-bk ) / denom b( k, j ) = ( akm1*bk-bkm1 ) / denom end do - k = k - 2 + k = k - 2_${ik}$ end if go to 10 30 continue ! next solve u**t *x = b, overwriting b with x. - ! k is the main loop index, increasing from 1 to n in steps of - ! 1 or 2, depending on the size of the diagonal blocks. - k = 1 + ! k is the main loop index, increasing from 1_${ik}$ to n in steps of + ! 1_${ik}$ or 2_${ik}$, depending on the size of the diagonal blocks. + k = 1_${ik}$ 40 continue ! if k > n, exit from loop. if( k>n )go to 50 - if( ipiv( k )>0 ) then - ! 1 x 1 diagonal block + if( ipiv( k )>0_${ik}$ ) then + ! 1_${ik}$ x 1_${ik}$ 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_sgemv( 'TRANSPOSE', k-1, nrhs, -one, b,ldb, a( 1, k ), 1, & - one, b( k, 1 ), ldb ) + if( k>1_${ik}$ )call stdlib${ii}$_sgemv( 'TRANSPOSE', k-1, nrhs, -one, b,ldb, a( 1_${ik}$, k ), 1_${ik}$, & + one, b( k, 1_${ik}$ ), ldb ) ! interchange rows k and ipiv(k). kp = ipiv( k ) - if( kp/=k )call stdlib_sswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) - k = k + 1 + if( kp/=k )call stdlib${ii}$_sswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) + k = k + 1_${ik}$ else - ! 2 x 2 diagonal block + ! 2_${ik}$ x 2_${ik}$ 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_sgemv( 'TRANSPOSE', k-1, nrhs, -one, b,ldb, a( 1, k ), 1, one, b( & - k, 1 ), ldb ) - call stdlib_sgemv( 'TRANSPOSE', k-1, nrhs, -one, b,ldb, a( 1, k+1 ), 1, one, & - b( k+1, 1 ), ldb ) + if( k>1_${ik}$ ) then + call stdlib${ii}$_sgemv( 'TRANSPOSE', k-1, nrhs, -one, b,ldb, a( 1_${ik}$, k ), 1_${ik}$, one, b( & + k, 1_${ik}$ ), ldb ) + call stdlib${ii}$_sgemv( 'TRANSPOSE', k-1, nrhs, -one, b,ldb, a( 1_${ik}$, k+1 ), 1_${ik}$, one, & + b( k+1, 1_${ik}$ ), ldb ) end if ! interchange rows k and -ipiv(k) then k+1 and -ipiv(k+1). kp = -ipiv( k ) - if( kp/=k )call stdlib_sswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib${ii}$_sswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) kp = -ipiv( k+1 ) - if( kp/=k+1 )call stdlib_sswap( nrhs, b( k+1, 1 ), ldb, b( kp, 1 ), ldb ) - k = k + 2 + if( kp/=k+1 )call stdlib${ii}$_sswap( nrhs, b( k+1, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) + k = k + 2_${ik}$ end if go to 40 50 continue else ! solve a*x = b, where a = l*d*l**t. ! first solve l*d*x = b, overwriting b with x. - ! k is the main loop index, increasing from 1 to n in steps of - ! 1 or 2, depending on the size of the diagonal blocks. - k = 1 + ! k is the main loop index, increasing from 1_${ik}$ to n in steps of + ! 1_${ik}$ or 2_${ik}$, depending on the size of the diagonal blocks. + k = 1_${ik}$ 60 continue ! if k > n, exit from loop. if( k>n )go to 80 - if( ipiv( k )>0 ) then - ! 1 x 1 diagonal block + if( ipiv( k )>0_${ik}$ ) then + ! 1_${ik}$ x 1_${ik}$ diagonal block ! interchange rows k and ipiv(k). kp = ipiv( k ) - if( kp/=k )call stdlib_sswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib${ii}$_sswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) ! multiply by inv(l(k)), where l(k) is the transformation ! stored in column k of a. - if( k0 ) then - ! 1 x 1 diagonal block + if( ipiv( k )>0_${ik}$ ) then + ! 1_${ik}$ x 1_${ik}$ diagonal block ! multiply by inv(l**t(k)), where l(k) is the transformation ! stored in column k of a. - if( k a(0,0), t2 -> a(0,1), s -> a(n1,0) - ! t1 -> a(0), t2 -> a(n), s -> a(n1); lda = n - ijp = 0 - jp = 0 + ! srpa for lower, normal and n is odd ( a(0_${ik}$:n-1,0_${ik}$:n1-1) ) + ! t1 -> a(0_${ik}$,0_${ik}$), t2 -> a(0_${ik}$,1_${ik}$), s -> a(n1,0_${ik}$) + ! t1 -> a(0_${ik}$), t2 -> a(n), s -> a(n1); lda = n + ijp = 0_${ik}$ + jp = 0_${ik}$ do j = 0, n2 do i = j, n - 1 ij = i + jp ap( ijp ) = arf( ij ) - ijp = ijp + 1 + ijp = ijp + 1_${ik}$ end do jp = jp + lda end do @@ -21836,28 +21838,28 @@ module stdlib_linalg_lapack_s do j = 1 + i, n2 ij = i + j*lda ap( ijp ) = arf( ij ) - ijp = ijp + 1 + ijp = ijp + 1_${ik}$ end do end do 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) - ijp = 0 + ! srpa for upper, normal and n is odd ( a(0_${ik}$:n-1,0_${ik}$:n2-1) + ! t1 -> a(n1+1,0_${ik}$), t2 -> a(n1,0_${ik}$), s -> a(0_${ik}$,0_${ik}$) + ! t1 -> a(n2), t2 -> a(n1), s -> a(0_${ik}$) + ijp = 0_${ik}$ do j = 0, n1 - 1 ij = n2 + j do i = 0, j ap( ijp ) = arf( ij ) - ijp = ijp + 1 + ijp = ijp + 1_${ik}$ ij = ij + lda end do end do - js = 0 + js = 0_${ik}$ do j = n1, n - 1 ij = js do ij = js, js + j ap( ijp ) = arf( ij ) - ijp = ijp + 1 + ijp = ijp + 1_${ik}$ end do js = js + lda end do @@ -21866,40 +21868,40 @@ module stdlib_linalg_lapack_s ! n is odd and transr = 't' if( lower ) then ! srpa for lower, transpose and n is odd - ! t1 -> a(0,0) , t2 -> a(1,0) , s -> a(0,n1) - ! t1 -> a(0+0) , t2 -> a(1+0) , s -> a(0+n1*n1); lda=n1 - ijp = 0 + ! t1 -> a(0_${ik}$,0_${ik}$) , t2 -> a(1_${ik}$,0_${ik}$) , s -> a(0_${ik}$,n1) + ! t1 -> a(0_${ik}$+0) , t2 -> a(1_${ik}$+0) , s -> a(0_${ik}$+n1*n1); lda=n1 + ijp = 0_${ik}$ do i = 0, n2 do ij = i*( lda+1 ), n*lda - 1, lda ap( ijp ) = arf( ij ) - ijp = ijp + 1 + ijp = ijp + 1_${ik}$ end do end do - js = 1 + js = 1_${ik}$ do j = 0, n2 - 1 do ij = js, js + n2 - j - 1 ap( ijp ) = arf( ij ) - ijp = ijp + 1 + ijp = ijp + 1_${ik}$ end do - js = js + lda + 1 + js = js + lda + 1_${ik}$ end do 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 - ijp = 0 + ! t1 -> a(0_${ik}$,n1+1), t2 -> a(0_${ik}$,n1), s -> a(0_${ik}$,0_${ik}$) + ! t1 -> a(n2*n2), t2 -> a(n1*n2), s -> a(0_${ik}$); lda = n2 + ijp = 0_${ik}$ js = n2*lda do j = 0, n1 - 1 do ij = js, js + j ap( ijp ) = arf( ij ) - ijp = ijp + 1 + ijp = ijp + 1_${ik}$ end do js = js + lda end do do i = 0, n1 do ij = i, i + ( n1+i )*lda, lda ap( ijp ) = arf( ij ) - ijp = ijp + 1 + ijp = ijp + 1_${ik}$ end do end do end if @@ -21909,16 +21911,16 @@ module stdlib_linalg_lapack_s if( normaltransr ) then ! n is even and transr = 'n' if( lower ) then - ! srpa for lower, normal, and n is even ( a(0:n,0:k-1) ) - ! t1 -> a(1,0), t2 -> a(0,0), s -> a(k+1,0) - ! t1 -> a(1), t2 -> a(0), s -> a(k+1) - ijp = 0 - jp = 0 + ! srpa for lower, normal, and n is even ( a(0_${ik}$:n,0_${ik}$:k-1) ) + ! t1 -> a(1_${ik}$,0_${ik}$), t2 -> a(0_${ik}$,0_${ik}$), s -> a(k+1,0_${ik}$) + ! t1 -> a(1_${ik}$), t2 -> a(0_${ik}$), s -> a(k+1) + ijp = 0_${ik}$ + jp = 0_${ik}$ do j = 0, k - 1 do i = j, n - 1 - ij = 1 + i + jp + ij = 1_${ik}$ + i + jp ap( ijp ) = arf( ij ) - ijp = ijp + 1 + ijp = ijp + 1_${ik}$ end do jp = jp + lda end do @@ -21926,28 +21928,28 @@ module stdlib_linalg_lapack_s do j = i, k - 1 ij = i + j*lda ap( ijp ) = arf( ij ) - ijp = ijp + 1 + ijp = ijp + 1_${ik}$ end do end do 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) - ijp = 0 + ! srpa for upper, normal, and n is even ( a(0_${ik}$:n,0_${ik}$:k-1) ) + ! t1 -> a(k+1,0_${ik}$) , t2 -> a(k,0_${ik}$), s -> a(0_${ik}$,0_${ik}$) + ! t1 -> a(k+1), t2 -> a(k), s -> a(0_${ik}$) + ijp = 0_${ik}$ do j = 0, k - 1 - ij = k + 1 + j + ij = k + 1_${ik}$ + j do i = 0, j ap( ijp ) = arf( ij ) - ijp = ijp + 1 + ijp = ijp + 1_${ik}$ ij = ij + lda end do end do - js = 0 + js = 0_${ik}$ do j = k, n - 1 ij = js do ij = js, js + j ap( ijp ) = arf( ij ) - ijp = ijp + 1 + ijp = ijp + 1_${ik}$ end do js = js + lda end do @@ -21956,50 +21958,50 @@ module stdlib_linalg_lapack_s ! n is even and transr = 't' if( lower ) then ! srpa for lower, transpose and n is even (see paper) - ! t1 -> b(0,1), t2 -> b(0,0), s -> b(0,k+1) - ! t1 -> a(0+k), t2 -> a(0+0), s -> a(0+k*(k+1)); lda=k - ijp = 0 + ! t1 -> b(0_${ik}$,1_${ik}$), t2 -> b(0_${ik}$,0_${ik}$), s -> b(0_${ik}$,k+1) + ! t1 -> a(0_${ik}$+k), t2 -> a(0_${ik}$+0), s -> a(0_${ik}$+k*(k+1)); lda=k + ijp = 0_${ik}$ do i = 0, k - 1 do ij = i + ( i+1 )*lda, ( n+1 )*lda - 1, lda ap( ijp ) = arf( ij ) - ijp = ijp + 1 + ijp = ijp + 1_${ik}$ end do end do - js = 0 + js = 0_${ik}$ do j = 0, k - 1 do ij = js, js + k - j - 1 ap( ijp ) = arf( ij ) - ijp = ijp + 1 + ijp = ijp + 1_${ik}$ end do - js = js + lda + 1 + js = js + lda + 1_${ik}$ end do 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 - ijp = 0 + ! t1 -> b(0_${ik}$,k+1), t2 -> b(0_${ik}$,k), s -> b(0_${ik}$,0_${ik}$) + ! t1 -> a(0_${ik}$+k*(k+1)), t2 -> a(0_${ik}$+k*k), s -> a(0_${ik}$+0)); lda=k + ijp = 0_${ik}$ js = ( k+1 )*lda do j = 0, k - 1 do ij = js, js + j ap( ijp ) = arf( ij ) - ijp = ijp + 1 + ijp = ijp + 1_${ik}$ end do js = js + lda end do do i = 0, k - 1 do ij = i, i + ( k+i )*lda, lda ap( ijp ) = arf( ij ) - ijp = ijp + 1 + ijp = ijp + 1_${ik}$ end do end do end if end if end if return - end subroutine stdlib_stfttp + end subroutine stdlib${ii}$_stfttp - pure subroutine stdlib_stfttr( transr, uplo, n, arf, a, lda, info ) + pure subroutine stdlib${ii}$_stfttr( transr, uplo, n, arf, a, lda, info ) !! STFTTR copies a triangular matrix A from rectangular full packed !! format (TF) to standard full format (TR). ! -- lapack computational routine -- @@ -22007,60 +22009,60 @@ module stdlib_linalg_lapack_s ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: transr, uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: n, lda + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: n, lda ! Array Arguments - real(sp), intent(out) :: a(0:lda-1,0:*) - real(sp), intent(in) :: arf(0:*) + real(sp), intent(out) :: a(0_${ik}$:lda-1,0_${ik}$:*) + real(sp), intent(in) :: arf(0_${ik}$:*) ! ===================================================================== ! Local Scalars logical(lk) :: lower, nisodd, normaltransr - integer(ilp) :: n1, n2, k, nt, nx2, np1x2 - integer(ilp) :: i, j, l, ij + integer(${ik}$) :: n1, n2, k, nt, nx2, np1x2 + integer(${ik}$) :: i, j, l, ij ! Intrinsic Functions intrinsic :: max,mod ! Executable Statements ! test the input parameters. - info = 0 + info = 0_${ik}$ normaltransr = stdlib_lsame( transr, 'N' ) lower = stdlib_lsame( uplo, 'L' ) if( .not.normaltransr .and. .not.stdlib_lsame( transr, 'T' ) ) then - info = -1 + info = -1_${ik}$ else if( .not.lower .and. .not.stdlib_lsame( uplo, 'U' ) ) then - info = -2 - else if( n<0 ) then - info = -3 - else if( lda=n ) then + nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'STRTRI', uplo // diag, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ ) + if( nb<=1_${ik}$ .or. nb>=n ) then ! use unblocked code - call stdlib_strti2( uplo, diag, n, a, lda, info ) + call stdlib${ii}$_strti2( uplo, diag, n, a, lda, info ) else ! use blocked code if( upper ) then ! compute inverse of upper triangular matrix do j = 1, n, nb jb = min( nb, n-j+1 ) - ! compute rows 1:j-1 of current block column - call stdlib_strmm( 'LEFT', 'UPPER', 'NO TRANSPOSE', diag, j-1,jb, one, a, lda,& - a( 1, j ), lda ) - call stdlib_strsm( 'RIGHT', 'UPPER', 'NO TRANSPOSE', diag, j-1,jb, -one, a( j,& - j ), lda, a( 1, j ), lda ) + ! compute rows 1_${ik}$:j-1 of current block column + call stdlib${ii}$_strmm( 'LEFT', 'UPPER', 'NO TRANSPOSE', diag, j-1,jb, one, a, lda,& + a( 1_${ik}$, j ), lda ) + call stdlib${ii}$_strsm( 'RIGHT', 'UPPER', 'NO TRANSPOSE', diag, j-1,jb, -one, a( j,& + j ), lda, a( 1_${ik}$, j ), lda ) ! compute inverse of current diagonal block - call stdlib_strti2( 'UPPER', diag, jb, a( j, j ), lda, info ) + call stdlib${ii}$_strti2( 'UPPER', diag, jb, a( j, j ), lda, info ) end do else ! compute inverse of lower triangular matrix - nn = ( ( n-1 ) / nb )*nb + 1 + nn = ( ( n-1 ) / nb )*nb + 1_${ik}$ do j = nn, 1, -nb jb = min( nb, n-j+1 ) if( j+jb<=n ) then ! compute rows j+jb:n of current block column - call stdlib_strmm( 'LEFT', 'LOWER', 'NO TRANSPOSE', diag,n-j-jb+1, jb, one,& + call stdlib${ii}$_strmm( 'LEFT', 'LOWER', 'NO TRANSPOSE', diag,n-j-jb+1, jb, one,& a( j+jb, j+jb ), lda,a( j+jb, j ), lda ) - call stdlib_strsm( 'RIGHT', 'LOWER', 'NO TRANSPOSE', diag,n-j-jb+1, jb, -& + call stdlib${ii}$_strsm( '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_strti2( 'LOWER', diag, jb, a( j, j ), lda, info ) + call stdlib${ii}$_strti2( 'LOWER', diag, jb, a( j, j ), lda, info ) end do end if end if return - end subroutine stdlib_strtri + end subroutine stdlib${ii}$_strtri - pure subroutine stdlib_strtrs( uplo, trans, diag, n, nrhs, a, lda, b, ldb,info ) + pure subroutine stdlib${ii}$_strtrs( uplo, trans, diag, n, nrhs, a, lda, b, ldb,info ) !! STRTRS 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 @@ -23756,8 +23758,8 @@ module stdlib_linalg_lapack_s ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: diag, trans, uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda, ldb, n, nrhs + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, ldb, n, nrhs ! Array Arguments real(sp), intent(in) :: a(lda,*) real(sp), intent(inout) :: b(ldb,*) @@ -23769,26 +23771,26 @@ module stdlib_linalg_lapack_s intrinsic :: max ! Executable Statements ! test the input parameters. - info = 0 + info = 0_${ik}$ nounit = stdlib_lsame( diag, 'N' ) if( .not.stdlib_lsame( uplo, 'U' ) .and. .not.stdlib_lsame( uplo, 'L' ) ) then - info = -1 + info = -1_${ik}$ else if( .not.stdlib_lsame( trans, 'N' ) .and. .not.stdlib_lsame( trans, 'T' ) .and. & .not.stdlib_lsame( trans, 'C' ) ) then - info = -2 + info = -2_${ik}$ else if( .not.nounit .and. .not.stdlib_lsame( diag, 'U' ) ) then - info = -3 - else if( n<0 ) then - info = -4 - else if( nrhs<0 ) then - info = -5 - else if( lda m ) then - info = -7 - else if( q < 0 .or. q > m ) then - info = -8 + if( m < 0_${ik}$ ) then + info = -6_${ik}$ + else if( p < 0_${ik}$ .or. p > m ) then + info = -7_${ik}$ + else if( q < 0_${ik}$ .or. q > m ) then + info = -8_${ik}$ else if( q > p .or. q > m-p .or. q > m-q ) then - info = -8 + info = -8_${ik}$ else if( wantu1 .and. ldu1 < p ) then - info = -12 + info = -12_${ik}$ else if( wantu2 .and. ldu2 < m-p ) then - info = -14 + info = -14_${ik}$ else if( wantv1t .and. ldv1t < q ) then - info = -16 + info = -16_${ik}$ else if( wantv2t .and. ldv2t < m-q ) then - info = -18 + info = -18_${ik}$ end if ! quick return if q = 0 - if( info == 0 .and. q == 0 ) then - lworkmin = 1 - work(1) = lworkmin + if( info == 0_${ik}$ .and. q == 0_${ik}$ ) then + lworkmin = 1_${ik}$ + work(1_${ik}$) = lworkmin return end if ! compute workspace - if( info == 0 ) then - iu1cs = 1 + if( info == 0_${ik}$ ) then + iu1cs = 1_${ik}$ iu1sn = iu1cs + q iu2cs = iu1sn + q iu2sn = iu2cs + q @@ -24185,22 +24187,22 @@ module stdlib_linalg_lapack_s iv1tsn = iv1tcs + q iv2tcs = iv1tsn + q iv2tsn = iv2tcs + q - lworkopt = iv2tsn + q - 1 + lworkopt = iv2tsn + q - 1_${ik}$ lworkmin = lworkopt - work(1) = lworkopt + work(1_${ik}$) = lworkopt if( lwork < lworkmin .and. .not. lquery ) then - info = -28 + info = -28_${ik}$ end if end if - if( info /= 0 ) then - call stdlib_xerbla( 'SBBCSD', -info ) + if( info /= 0_${ik}$ ) then + call stdlib${ii}$_xerbla( 'SBBCSD', -info ) return else if( lquery ) then return end if ! get machine constants - eps = stdlib_slamch( 'EPSILON' ) - unfl = stdlib_slamch( 'SAFE MINIMUM' ) + eps = stdlib${ii}$_slamch( 'EPSILON' ) + unfl = stdlib${ii}$_slamch( 'SAFE MINIMUM' ) tolmul = max( ten, min( hundred, eps**meighth ) ) tol = tolmul*eps thresh = max( tol, maxitr*q*q*unfl ) @@ -24225,18 +24227,18 @@ module stdlib_linalg_lapack_s if( phi(imax-1) /= zero ) then exit end if - imax = imax - 1 + imax = imax - 1_${ik}$ end do - imin = imax - 1 - if ( imin > 1 ) then + imin = imax - 1_${ik}$ + if ( imin > 1_${ik}$ ) then do while( phi(imin-1) /= zero ) - imin = imin - 1 + imin = imin - 1_${ik}$ if ( imin <= 1 ) exit end do end if ! initialize iteration counter maxit = maxitr*q*q - iter = 0 + iter = 0_${ik}$ ! begin main iteration loop do while( imax > 1 ) ! compute the matrix entries @@ -24256,9 +24258,9 @@ module stdlib_linalg_lapack_s b22d(imax) = cos( theta(imax) ) ! abort if not converging; otherwise, increment iter if( iter > maxit ) then - info = 0 + info = 0_${ik}$ do i = 1, q - if( phi(i) /= zero )info = info + 1 + if( phi(i) /= zero )info = info + 1_${ik}$ end do return end if @@ -24282,20 +24284,20 @@ module stdlib_linalg_lapack_s nu = zero else ! compute shifts for b11 and b21 and use the lesser - call stdlib_slas2( b11d(imax-1), b11e(imax-1), b11d(imax), sigma11,dummy ) + call stdlib${ii}$_slas2( b11d(imax-1), b11e(imax-1), b11d(imax), sigma11,dummy ) - call stdlib_slas2( b21d(imax-1), b21e(imax-1), b21d(imax), sigma21,dummy ) + call stdlib${ii}$_slas2( b21d(imax-1), b21e(imax-1), b21d(imax), sigma21,dummy ) if( sigma11 <= sigma21 ) then mu = sigma11 - nu = sqrt( one - mu**2 ) + nu = sqrt( one - mu**2_${ik}$ ) if( mu < thresh ) then mu = zero nu = one end if else nu = sigma21 - mu = sqrt( 1.0_sp - nu**2 ) + mu = sqrt( 1.0_sp - nu**2_${ik}$ ) if( nu < thresh ) then mu = one nu = zero @@ -24304,10 +24306,10 @@ module stdlib_linalg_lapack_s end if ! rotate to produce bulges in b11 and b21 if( mu <= nu ) then - call stdlib_slartgs( b11d(imin), b11e(imin), mu,work(iv1tcs+imin-1), work(iv1tsn+& + call stdlib${ii}$_slartgs( b11d(imin), b11e(imin), mu,work(iv1tcs+imin-1), work(iv1tsn+& imin-1) ) else - call stdlib_slartgs( b21d(imin), b21e(imin), nu,work(iv1tcs+imin-1), work(iv1tsn+& + call stdlib${ii}$_slartgs( 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) @@ -24321,27 +24323,27 @@ module stdlib_linalg_lapack_s b21bulge = work(iv1tsn+imin-1)*b21d(imin+1) b21d(imin+1) = work(iv1tcs+imin-1)*b21d(imin+1) ! compute theta(imin) - theta( imin ) = atan2( sqrt( b21d(imin)**2+b21bulge**2 ),sqrt( b11d(imin)**2+& - b11bulge**2 ) ) + theta( imin ) = atan2( sqrt( b21d(imin)**2_${ik}$+b21bulge**2_${ik}$ ),sqrt( b11d(imin)**2_${ik}$+& + b11bulge**2_${ik}$ ) ) ! chase the bulges in b11(imin+1,imin) and b21(imin+1,imin) - if( b11d(imin)**2+b11bulge**2 > thresh**2 ) then - call stdlib_slartgp( b11bulge, b11d(imin), work(iu1sn+imin-1),work(iu1cs+imin-1),& + if( b11d(imin)**2_${ik}$+b11bulge**2_${ik}$ > thresh**2_${ik}$ ) then + call stdlib${ii}$_slartgp( b11bulge, b11d(imin), work(iu1sn+imin-1),work(iu1cs+imin-1),& r ) else if( mu <= nu ) then - call stdlib_slartgs( b11e( imin ), b11d( imin + 1 ), mu,work(iu1cs+imin-1), work(& + call stdlib${ii}$_slartgs( b11e( imin ), b11d( imin + 1_${ik}$ ), mu,work(iu1cs+imin-1), work(& iu1sn+imin-1) ) else - call stdlib_slartgs( b12d( imin ), b12e( imin ), nu,work(iu1cs+imin-1), work(& + call stdlib${ii}$_slartgs( 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_slartgp( b21bulge, b21d(imin), work(iu2sn+imin-1),work(iu2cs+imin-1),& + if( b21d(imin)**2_${ik}$+b21bulge**2_${ik}$ > thresh**2_${ik}$ ) then + call stdlib${ii}$_slartgp( b21bulge, b21d(imin), work(iu2sn+imin-1),work(iu2cs+imin-1),& r ) else if( nu < mu ) then - call stdlib_slartgs( b21e( imin ), b21d( imin + 1 ), nu,work(iu2cs+imin-1), work(& + call stdlib${ii}$_slartgs( b21e( imin ), b21d( imin + 1_${ik}$ ), nu,work(iu2cs+imin-1), work(& iu2sn+imin-1) ) else - call stdlib_slartgs( b22d(imin), b22e(imin), mu,work(iu2cs+imin-1), work(iu2sn+& + call stdlib${ii}$_slartgs( b22d(imin), b22e(imin), mu,work(iu2cs+imin-1), work(iu2sn+& imin-1) ) end if work(iu2cs+imin-1) = -work(iu2cs+imin-1) @@ -24381,48 +24383,48 @@ module stdlib_linalg_lapack_s x2 = sin(theta(i-1))*b11bulge + cos(theta(i-1))*b21bulge y1 = sin(theta(i-1))*b12d(i-1) + cos(theta(i-1))*b22d(i-1) y2 = sin(theta(i-1))*b12bulge + cos(theta(i-1))*b22bulge - phi(i-1) = atan2( sqrt(x1**2+x2**2), sqrt(y1**2+y2**2) ) + phi(i-1) = atan2( sqrt(x1**2_${ik}$+x2**2_${ik}$), sqrt(y1**2_${ik}$+y2**2_${ik}$) ) ! determine if there are bulges to chase or if a new direct ! summand has been reached - restart11 = b11e(i-1)**2 + b11bulge**2 <= thresh**2 - restart21 = b21e(i-1)**2 + b21bulge**2 <= thresh**2 - restart12 = b12d(i-1)**2 + b12bulge**2 <= thresh**2 - restart22 = b22d(i-1)**2 + b22bulge**2 <= thresh**2 + restart11 = b11e(i-1)**2_${ik}$ + b11bulge**2_${ik}$ <= thresh**2_${ik}$ + restart21 = b21e(i-1)**2_${ik}$ + b21bulge**2_${ik}$ <= thresh**2_${ik}$ + restart12 = b12d(i-1)**2_${ik}$ + b12bulge**2_${ik}$ <= thresh**2_${ik}$ + restart22 = b22d(i-1)**2_${ik}$ + b22bulge**2_${ik}$ <= thresh**2_${ik}$ ! if possible, chase bulges from b11(i-1,i+1), b12(i-1,i), ! 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_slartgp( x2, x1, work(iv1tsn+i-1), work(iv1tcs+i-1),r ) + call stdlib${ii}$_slartgp( x2, x1, work(iv1tsn+i-1), work(iv1tcs+i-1),r ) else if( .not. restart11 .and. restart21 ) then - call stdlib_slartgp( b11bulge, b11e(i-1), work(iv1tsn+i-1),work(iv1tcs+i-1), & + call stdlib${ii}$_slartgp( b11bulge, b11e(i-1), work(iv1tsn+i-1),work(iv1tcs+i-1), & r ) else if( restart11 .and. .not. restart21 ) then - call stdlib_slartgp( b21bulge, b21e(i-1), work(iv1tsn+i-1),work(iv1tcs+i-1), & + call stdlib${ii}$_slartgp( b21bulge, b21e(i-1), work(iv1tsn+i-1),work(iv1tcs+i-1), & r ) else if( mu <= nu ) then - call stdlib_slartgs( b11d(i), b11e(i), mu, work(iv1tcs+i-1),work(iv1tsn+i-1) ) + call stdlib${ii}$_slartgs( b11d(i), b11e(i), mu, work(iv1tcs+i-1),work(iv1tsn+i-1) ) else - call stdlib_slartgs( b21d(i), b21e(i), nu, work(iv1tcs+i-1),work(iv1tsn+i-1) ) + call stdlib${ii}$_slartgs( 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_slartgp( y2, y1, work(iv2tsn+i-1-1),work(iv2tcs+i-1-1), r ) + call stdlib${ii}$_slartgp( y2, y1, work(iv2tsn+i-1-1),work(iv2tcs+i-1-1), r ) else if( .not. restart12 .and. restart22 ) then - call stdlib_slartgp( b12bulge, b12d(i-1), work(iv2tsn+i-1-1),work(iv2tcs+i-1-& - 1), r ) + call stdlib${ii}$_slartgp( b12bulge, b12d(i-1), work(iv2tsn+i-1-1),work(iv2tcs+i-1-& + 1_${ik}$), r ) else if( restart12 .and. .not. restart22 ) then - call stdlib_slartgp( b22bulge, b22d(i-1), work(iv2tsn+i-1-1),work(iv2tcs+i-1-& - 1), r ) + call stdlib${ii}$_slartgp( b22bulge, b22d(i-1), work(iv2tsn+i-1-1),work(iv2tcs+i-1-& + 1_${ik}$), r ) else if( nu < mu ) then - call stdlib_slartgs( b12e(i-1), b12d(i), nu, work(iv2tcs+i-1-1),work(iv2tsn+i-& - 1-1) ) + call stdlib${ii}$_slartgs( b12e(i-1), b12d(i), nu, work(iv2tcs+i-1-1),work(iv2tsn+i-& + 1_${ik}$-1) ) else - call stdlib_slartgs( b22e(i-1), b22d(i), mu, work(iv2tcs+i-1-1),work(iv2tsn+i-& - 1-1) ) + call stdlib${ii}$_slartgs( b22e(i-1), b22d(i), mu, work(iv2tcs+i-1-1),work(iv2tsn+i-& + 1_${ik}$-1) ) end if temp = work(iv1tcs+i-1)*b11d(i) + work(iv1tsn+i-1)*b11e(i) b11e(i) = work(iv1tcs+i-1)*b11e(i) -work(iv1tsn+i-1)*b11d(i) @@ -24449,44 +24451,44 @@ module stdlib_linalg_lapack_s x2 = cos(phi(i-1))*b11bulge + sin(phi(i-1))*b12bulge y1 = cos(phi(i-1))*b21d(i) + sin(phi(i-1))*b22e(i-1) y2 = cos(phi(i-1))*b21bulge + sin(phi(i-1))*b22bulge - theta(i) = atan2( sqrt(y1**2+y2**2), sqrt(x1**2+x2**2) ) + theta(i) = atan2( sqrt(y1**2_${ik}$+y2**2_${ik}$), sqrt(x1**2_${ik}$+x2**2_${ik}$) ) ! determine if there are bulges to chase or if a new direct ! summand has been reached - restart11 = b11d(i)**2 + b11bulge**2 <= thresh**2 - restart12 = b12e(i-1)**2 + b12bulge**2 <= thresh**2 - restart21 = b21d(i)**2 + b21bulge**2 <= thresh**2 - restart22 = b22e(i-1)**2 + b22bulge**2 <= thresh**2 + restart11 = b11d(i)**2_${ik}$ + b11bulge**2_${ik}$ <= thresh**2_${ik}$ + restart12 = b12e(i-1)**2_${ik}$ + b12bulge**2_${ik}$ <= thresh**2_${ik}$ + restart21 = b21d(i)**2_${ik}$ + b21bulge**2_${ik}$ <= thresh**2_${ik}$ + restart22 = b22e(i-1)**2_${ik}$ + b22bulge**2_${ik}$ <= thresh**2_${ik}$ ! if possible, chase bulges from b11(i+1,i), b12(i+1,i-1), ! 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_slartgp( x2, x1, work(iu1sn+i-1), work(iu1cs+i-1),r ) + call stdlib${ii}$_slartgp( x2, x1, work(iu1sn+i-1), work(iu1cs+i-1),r ) else if( .not. restart11 .and. restart12 ) then - call stdlib_slartgp( b11bulge, b11d(i), work(iu1sn+i-1),work(iu1cs+i-1), r ) + call stdlib${ii}$_slartgp( b11bulge, b11d(i), work(iu1sn+i-1),work(iu1cs+i-1), r ) else if( restart11 .and. .not. restart12 ) then - call stdlib_slartgp( b12bulge, b12e(i-1), work(iu1sn+i-1),work(iu1cs+i-1), r ) + call stdlib${ii}$_slartgp( b12bulge, b12e(i-1), work(iu1sn+i-1),work(iu1cs+i-1), r ) else if( mu <= nu ) then - call stdlib_slartgs( b11e(i), b11d(i+1), mu, work(iu1cs+i-1),work(iu1sn+i-1) ) + call stdlib${ii}$_slartgs( b11e(i), b11d(i+1), mu, work(iu1cs+i-1),work(iu1sn+i-1) ) else - call stdlib_slartgs( b12d(i), b12e(i), nu, work(iu1cs+i-1),work(iu1sn+i-1) ) + call stdlib${ii}$_slartgs( b12d(i), b12e(i), nu, work(iu1cs+i-1),work(iu1sn+i-1) ) end if if( .not. restart21 .and. .not. restart22 ) then - call stdlib_slartgp( y2, y1, work(iu2sn+i-1), work(iu2cs+i-1),r ) + call stdlib${ii}$_slartgp( y2, y1, work(iu2sn+i-1), work(iu2cs+i-1),r ) else if( .not. restart21 .and. restart22 ) then - call stdlib_slartgp( b21bulge, b21d(i), work(iu2sn+i-1),work(iu2cs+i-1), r ) + call stdlib${ii}$_slartgp( b21bulge, b21d(i), work(iu2sn+i-1),work(iu2cs+i-1), r ) else if( restart21 .and. .not. restart22 ) then - call stdlib_slartgp( b22bulge, b22e(i-1), work(iu2sn+i-1),work(iu2cs+i-1), r ) + call stdlib${ii}$_slartgp( b22bulge, b22e(i-1), work(iu2sn+i-1),work(iu2cs+i-1), r ) else if( nu < mu ) then - call stdlib_slartgs( b21e(i), b21e(i+1), nu, work(iu2cs+i-1),work(iu2sn+i-1) ) + call stdlib${ii}$_slartgs( b21e(i), b21e(i+1), nu, work(iu2cs+i-1),work(iu2sn+i-1) ) else - call stdlib_slartgs( b22d(i), b22e(i), mu, work(iu2cs+i-1),work(iu2sn+i-1) ) + call stdlib${ii}$_slartgs( b22d(i), b22e(i), mu, work(iu2cs+i-1),work(iu2sn+i-1) ) end if work(iu2cs+i-1) = -work(iu2cs+i-1) @@ -24494,14 +24496,14 @@ module stdlib_linalg_lapack_s temp = work(iu1cs+i-1)*b11e(i) + work(iu1sn+i-1)*b11d(i+1) b11d(i+1) = work(iu1cs+i-1)*b11d(i+1) -work(iu1sn+i-1)*b11e(i) b11e(i) = temp - if( i < imax - 1 ) then + if( i < imax - 1_${ik}$ ) then b11bulge = work(iu1sn+i-1)*b11e(i+1) b11e(i+1) = work(iu1cs+i-1)*b11e(i+1) end if temp = work(iu2cs+i-1)*b21e(i) + work(iu2sn+i-1)*b21d(i+1) b21d(i+1) = work(iu2cs+i-1)*b21d(i+1) -work(iu2sn+i-1)*b21e(i) b21e(i) = temp - if( i < imax - 1 ) then + if( i < imax - 1_${ik}$ ) then b21bulge = work(iu2sn+i-1)*b21e(i+1) b21e(i+1) = work(iu2cs+i-1)*b21e(i+1) end if @@ -24520,24 +24522,24 @@ module stdlib_linalg_lapack_s x1 = sin(theta(imax-1))*b11e(imax-1) +cos(theta(imax-1))*b21e(imax-1) y1 = sin(theta(imax-1))*b12d(imax-1) +cos(theta(imax-1))*b22d(imax-1) y2 = sin(theta(imax-1))*b12bulge + cos(theta(imax-1))*b22bulge - phi(imax-1) = atan2( abs(x1), sqrt(y1**2+y2**2) ) + phi(imax-1) = atan2( abs(x1), sqrt(y1**2_${ik}$+y2**2_${ik}$) ) ! chase bulges from b12(imax-1,imax) and b22(imax-1,imax) - restart12 = b12d(imax-1)**2 + b12bulge**2 <= thresh**2 - restart22 = b22d(imax-1)**2 + b22bulge**2 <= thresh**2 + restart12 = b12d(imax-1)**2_${ik}$ + b12bulge**2_${ik}$ <= thresh**2_${ik}$ + restart22 = b22d(imax-1)**2_${ik}$ + b22bulge**2_${ik}$ <= thresh**2_${ik}$ if( .not. restart12 .and. .not. restart22 ) then - call stdlib_slartgp( y2, y1, work(iv2tsn+imax-1-1),work(iv2tcs+imax-1-1), r ) + call stdlib${ii}$_slartgp( y2, y1, work(iv2tsn+imax-1-1),work(iv2tcs+imax-1-1), r ) else if( .not. restart12 .and. restart22 ) then - call stdlib_slartgp( b12bulge, b12d(imax-1), work(iv2tsn+imax-1-1),work(iv2tcs+& + call stdlib${ii}$_slartgp( b12bulge, b12d(imax-1), work(iv2tsn+imax-1-1),work(iv2tcs+& imax-1-1), r ) else if( restart12 .and. .not. restart22 ) then - call stdlib_slartgp( b22bulge, b22d(imax-1), work(iv2tsn+imax-1-1),work(iv2tcs+& + call stdlib${ii}$_slartgp( b22bulge, b22d(imax-1), work(iv2tsn+imax-1-1),work(iv2tcs+& imax-1-1), r ) else if( nu < mu ) then - call stdlib_slartgs( b12e(imax-1), b12d(imax), nu,work(iv2tcs+imax-1-1), work(& + call stdlib${ii}$_slartgs( b12e(imax-1), b12d(imax), nu,work(iv2tcs+imax-1-1), work(& iv2tsn+imax-1-1) ) else - call stdlib_slartgs( b22e(imax-1), b22d(imax), mu,work(iv2tcs+imax-1-1), work(& + call stdlib${ii}$_slartgs( 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) @@ -24551,49 +24553,49 @@ module stdlib_linalg_lapack_s ! update singular vectors if( wantu1 ) then if( colmajor ) then - call stdlib_slasr( 'R', 'V', 'F', p, imax-imin+1,work(iu1cs+imin-1), work(& - iu1sn+imin-1),u1(1,imin), ldu1 ) + call stdlib${ii}$_slasr( 'R', 'V', 'F', p, imax-imin+1,work(iu1cs+imin-1), work(& + iu1sn+imin-1),u1(1_${ik}$,imin), ldu1 ) else - call stdlib_slasr( 'L', 'V', 'F', imax-imin+1, p,work(iu1cs+imin-1), work(& - iu1sn+imin-1),u1(imin,1), ldu1 ) + call stdlib${ii}$_slasr( 'L', 'V', 'F', imax-imin+1, p,work(iu1cs+imin-1), work(& + iu1sn+imin-1),u1(imin,1_${ik}$), ldu1 ) end if end if if( wantu2 ) then if( colmajor ) then - call stdlib_slasr( 'R', 'V', 'F', m-p, imax-imin+1,work(iu2cs+imin-1), work(& - iu2sn+imin-1),u2(1,imin), ldu2 ) + call stdlib${ii}$_slasr( 'R', 'V', 'F', m-p, imax-imin+1,work(iu2cs+imin-1), work(& + iu2sn+imin-1),u2(1_${ik}$,imin), ldu2 ) else - call stdlib_slasr( 'L', 'V', 'F', imax-imin+1, m-p,work(iu2cs+imin-1), work(& - iu2sn+imin-1),u2(imin,1), ldu2 ) + call stdlib${ii}$_slasr( 'L', 'V', 'F', imax-imin+1, m-p,work(iu2cs+imin-1), work(& + iu2sn+imin-1),u2(imin,1_${ik}$), ldu2 ) end if end if if( wantv1t ) then if( colmajor ) then - call stdlib_slasr( 'L', 'V', 'F', imax-imin+1, q,work(iv1tcs+imin-1), work(& - iv1tsn+imin-1),v1t(imin,1), ldv1t ) + call stdlib${ii}$_slasr( 'L', 'V', 'F', imax-imin+1, q,work(iv1tcs+imin-1), work(& + iv1tsn+imin-1),v1t(imin,1_${ik}$), ldv1t ) else - call stdlib_slasr( 'R', 'V', 'F', q, imax-imin+1,work(iv1tcs+imin-1), work(& - iv1tsn+imin-1),v1t(1,imin), ldv1t ) + call stdlib${ii}$_slasr( 'R', 'V', 'F', q, imax-imin+1,work(iv1tcs+imin-1), work(& + iv1tsn+imin-1),v1t(1_${ik}$,imin), ldv1t ) end if end if if( wantv2t ) then if( colmajor ) then - call stdlib_slasr( 'L', 'V', 'F', imax-imin+1, m-q,work(iv2tcs+imin-1), work(& - iv2tsn+imin-1),v2t(imin,1), ldv2t ) + call stdlib${ii}$_slasr( 'L', 'V', 'F', imax-imin+1, m-q,work(iv2tcs+imin-1), work(& + iv2tsn+imin-1),v2t(imin,1_${ik}$), ldv2t ) else - call stdlib_slasr( 'R', 'V', 'F', m-q, imax-imin+1,work(iv2tcs+imin-1), work(& - iv2tsn+imin-1),v2t(1,imin), ldv2t ) + call stdlib${ii}$_slasr( 'R', 'V', 'F', m-q, imax-imin+1,work(iv2tcs+imin-1), work(& + iv2tsn+imin-1),v2t(1_${ik}$,imin), ldv2t ) end if end if ! fix signs on b11(imax-1,imax) and b21(imax-1,imax) - if( b11e(imax-1)+b21e(imax-1) > 0 ) then + if( b11e(imax-1)+b21e(imax-1) > 0_${ik}$ ) then b11d(imax) = -b11d(imax) b21d(imax) = -b21d(imax) if( wantv1t ) then if( colmajor ) then - call stdlib_sscal( q, negone, v1t(imax,1), ldv1t ) + call stdlib${ii}$_sscal( q, negone, v1t(imax,1_${ik}$), ldv1t ) else - call stdlib_sscal( q, negone, v1t(1,imax), 1 ) + call stdlib${ii}$_sscal( q, negone, v1t(1_${ik}$,imax), 1_${ik}$ ) end if end if end if @@ -24603,33 +24605,33 @@ module stdlib_linalg_lapack_s theta(imax) = atan2( abs(y1), abs(x1) ) ! fix signs on b11(imax,imax), b12(imax,imax-1), b21(imax,imax), ! and b22(imax,imax-1) - if( b11d(imax)+b12e(imax-1) < 0 ) then + if( b11d(imax)+b12e(imax-1) < 0_${ik}$ ) then b12d(imax) = -b12d(imax) if( wantu1 ) then if( colmajor ) then - call stdlib_sscal( p, negone, u1(1,imax), 1 ) + call stdlib${ii}$_sscal( p, negone, u1(1_${ik}$,imax), 1_${ik}$ ) else - call stdlib_sscal( p, negone, u1(imax,1), ldu1 ) + call stdlib${ii}$_sscal( p, negone, u1(imax,1_${ik}$), ldu1 ) end if end if end if - if( b21d(imax)+b22e(imax-1) > 0 ) then + if( b21d(imax)+b22e(imax-1) > 0_${ik}$ ) then b22d(imax) = -b22d(imax) if( wantu2 ) then if( colmajor ) then - call stdlib_sscal( m-p, negone, u2(1,imax), 1 ) + call stdlib${ii}$_sscal( m-p, negone, u2(1_${ik}$,imax), 1_${ik}$ ) else - call stdlib_sscal( m-p, negone, u2(imax,1), ldu2 ) + call stdlib${ii}$_sscal( m-p, negone, u2(imax,1_${ik}$), ldu2 ) end if end if end if ! fix signs on b12(imax,imax) and b22(imax,imax) - if( b12d(imax)+b22d(imax) < 0 ) then + if( b12d(imax)+b22d(imax) < 0_${ik}$ ) then if( wantv2t ) then if( colmajor ) then - call stdlib_sscal( m-q, negone, v2t(imax,1), ldv2t ) + call stdlib${ii}$_sscal( m-q, negone, v2t(imax,1_${ik}$), ldv2t ) else - call stdlib_sscal( m-q, negone, v2t(1,imax), 1 ) + call stdlib${ii}$_sscal( m-q, negone, v2t(1_${ik}$,imax), 1_${ik}$ ) end if end if end if @@ -24649,16 +24651,16 @@ module stdlib_linalg_lapack_s end if end do ! deflate - if (imax > 1) then + if (imax > 1_${ik}$) then do while( phi(imax-1) == zero ) - imax = imax - 1 + imax = imax - 1_${ik}$ if (imax <= 1) exit end do end if - if( imin > imax - 1 )imin = imax - 1 - if (imin > 1) then + if( imin > imax - 1_${ik}$ )imin = imax - 1_${ik}$ + if (imin > 1_${ik}$) then do while (phi(imin-1) /= zero) - imin = imin - 1 + imin = imin - 1_${ik}$ if (imin <= 1) exit end do end if @@ -24678,25 +24680,25 @@ module stdlib_linalg_lapack_s theta(mini) = theta(i) theta(i) = thetamin if( colmajor ) then - if( wantu1 )call stdlib_sswap( p, u1(1,i), 1, u1(1,mini), 1 ) - if( wantu2 )call stdlib_sswap( m-p, u2(1,i), 1, u2(1,mini), 1 ) - if( wantv1t )call stdlib_sswap( q, v1t(i,1), ldv1t, v1t(mini,1), ldv1t ) + if( wantu1 )call stdlib${ii}$_sswap( p, u1(1_${ik}$,i), 1_${ik}$, u1(1_${ik}$,mini), 1_${ik}$ ) + if( wantu2 )call stdlib${ii}$_sswap( m-p, u2(1_${ik}$,i), 1_${ik}$, u2(1_${ik}$,mini), 1_${ik}$ ) + if( wantv1t )call stdlib${ii}$_sswap( q, v1t(i,1_${ik}$), ldv1t, v1t(mini,1_${ik}$), ldv1t ) - if( wantv2t )call stdlib_sswap( m-q, v2t(i,1), ldv2t, v2t(mini,1),ldv2t ) + if( wantv2t )call stdlib${ii}$_sswap( m-q, v2t(i,1_${ik}$), ldv2t, v2t(mini,1_${ik}$),ldv2t ) else - if( wantu1 )call stdlib_sswap( p, u1(i,1), ldu1, u1(mini,1), ldu1 ) - if( wantu2 )call stdlib_sswap( m-p, u2(i,1), ldu2, u2(mini,1), ldu2 ) - if( wantv1t )call stdlib_sswap( q, v1t(1,i), 1, v1t(1,mini), 1 ) - if( wantv2t )call stdlib_sswap( m-q, v2t(1,i), 1, v2t(1,mini), 1 ) + if( wantu1 )call stdlib${ii}$_sswap( p, u1(i,1_${ik}$), ldu1, u1(mini,1_${ik}$), ldu1 ) + if( wantu2 )call stdlib${ii}$_sswap( m-p, u2(i,1_${ik}$), ldu2, u2(mini,1_${ik}$), ldu2 ) + if( wantv1t )call stdlib${ii}$_sswap( q, v1t(1_${ik}$,i), 1_${ik}$, v1t(1_${ik}$,mini), 1_${ik}$ ) + if( wantv2t )call stdlib${ii}$_sswap( m-q, v2t(1_${ik}$,i), 1_${ik}$, v2t(1_${ik}$,mini), 1_${ik}$ ) end if end if end do return - end subroutine stdlib_sbbcsd + end subroutine stdlib${ii}$_sbbcsd - pure subroutine stdlib_sdisna( job, m, n, d, sep, info ) + pure subroutine stdlib${ii}$_sdisna( job, m, n, d, sep, info ) !! SDISNA 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 @@ -24705,7 +24707,7 @@ module stdlib_linalg_lapack_s !! The bound on the error, measured by angle in radians, in the I-th !! computed vector is given by !! SLAMCH( 'E' ) * ( ANORM / SEP( I ) ) - !! where ANORM = 2-norm(A) = max( abs( D(j) ) ). SEP(I) is not allowed + !! where ANORM = 2_${ik}$-norm(A) = max( abs( D(j) ) ). SEP(I) is not allowed !! to be smaller than SLAMCH( 'E' )*ANORM in order to limit the size of !! the error bound. !! SDISNA may also be used to compute error bounds for eigenvectors of @@ -24715,8 +24717,8 @@ module stdlib_linalg_lapack_s ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: job - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: m, n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: m, n ! Array Arguments real(sp), intent(in) :: d(*) real(sp), intent(out) :: sep(*) @@ -24724,13 +24726,13 @@ module stdlib_linalg_lapack_s ! Local Scalars logical(lk) :: decr, eigen, incr, left, right, sing - integer(ilp) :: i, k + integer(${ik}$) :: i, k real(sp) :: anorm, eps, newgap, oldgap, safmin, thresh ! Intrinsic Functions intrinsic :: abs,max,min ! Executable Statements ! test the input arguments - info = 0 + info = 0_${ik}$ eigen = stdlib_lsame( job, 'E' ) left = stdlib_lsame( job, 'L' ) right = stdlib_lsame( job, 'R' ) @@ -24741,11 +24743,11 @@ module stdlib_linalg_lapack_s k = min( m, n ) end if if( .not.eigen .and. .not.sing ) then - info = -1 - else if( m<0 ) then - info = -2 - else if( k<0 ) then - info = -3 + info = -1_${ik}$ + else if( m<0_${ik}$ ) then + info = -2_${ik}$ + else if( k<0_${ik}$ ) then + info = -3_${ik}$ else incr = .true. decr = .true. @@ -24753,24 +24755,24 @@ module stdlib_linalg_lapack_s if( incr )incr = incr .and. d( i )<=d( i+1 ) if( decr )decr = decr .and. d( i )>=d( i+1 ) end do - if( sing .and. k>0 ) then - if( incr )incr = incr .and. zero<=d( 1 ) + if( sing .and. k>0_${ik}$ ) then + if( incr )incr = incr .and. zero<=d( 1_${ik}$ ) if( decr )decr = decr .and. d( k )>=zero end if - if( .not.( incr .or. decr ) )info = -4 + if( .not.( incr .or. decr ) )info = -4_${ik}$ end if - if( info/=0 ) then - call stdlib_xerbla( 'SDISNA', -info ) + if( info/=0_${ik}$ ) then + call stdlib${ii}$_xerbla( 'SDISNA', -info ) return end if ! quick return if possible if( k==0 )return ! compute reciprocal condition numbers - if( k==1 ) then - sep( 1 ) = stdlib_slamch( 'O' ) + if( k==1_${ik}$ ) then + sep( 1_${ik}$ ) = stdlib${ii}$_slamch( 'O' ) else - oldgap = abs( d( 2 )-d( 1 ) ) - sep( 1 ) = oldgap + oldgap = abs( d( 2_${ik}$ )-d( 1_${ik}$ ) ) + sep( 1_${ik}$ ) = oldgap do i = 2, k - 1 newgap = abs( d( i+1 )-d( i ) ) sep( i ) = min( oldgap, newgap ) @@ -24780,15 +24782,15 @@ module stdlib_linalg_lapack_s end if if( sing ) then if( ( left .and. m>n ) .or. ( right .and. m0 - klu1 = kl + ku + 1 - info = 0 + wantc = ncc>0_${ik}$ + klu1 = kl + ku + 1_${ik}$ + info = 0_${ik}$ if( .not.wantq .and. .not.wantpt .and. .not.stdlib_lsame( vect, 'N' ) )then - info = -1 - else if( m<0 ) then - info = -2 - else if( n<0 ) then - info = -3 - else if( ncc<0 ) then - info = -4 - else if( kl<0 ) then - info = -5 - else if( ku<0 ) then - info = -6 + info = -1_${ik}$ + else if( m<0_${ik}$ ) then + info = -2_${ik}$ + else if( n<0_${ik}$ ) then + info = -3_${ik}$ + else if( ncc<0_${ik}$ ) then + info = -4_${ik}$ + else if( kl<0_${ik}$ ) then + info = -5_${ik}$ + else if( ku<0_${ik}$ ) then + info = -6_${ik}$ else if( ldab1 ) then - ! reduce to upper bidiagonal form if ku > 0; if ku = 0, reduce + if( kl+ku>1_${ik}$ ) then + ! reduce to upper bidiagonal form if ku > 0_${ik}$; if ku = 0_${ik}$, reduce ! first to lower bidiagonal form and then transform to upper ! bidiagonal - if( ku>0 ) then - ml0 = 1 - mu0 = 2 + if( ku>0_${ik}$ ) then + ml0 = 1_${ik}$ + mu0 = 2_${ik}$ else - ml0 = 2 - mu0 = 1 + ml0 = 2_${ik}$ + mu0 = 1_${ik}$ end if ! wherever possible, plane rotations are generated and applied in ! vector operations of length nr over the index set j1:j2:klu1. - ! the sines of the plane rotations are stored in work(1:max(m,n)) - ! and the cosines in work(max(m,n)+1:2*max(m,n)). + ! the sines of the plane rotations are stored in work(1_${ik}$:max(m,n)) + ! and the cosines in work(max(m,n)+1_${ik}$:2_${ik}$*max(m,n)). mn = max( m, n ) klm = min( m-1, kl ) kun = min( n-1, ku ) kb = klm + kun - kb1 = kb + 1 + kb1 = kb + 1_${ik}$ inca = kb1*ldab - nr = 0 - j1 = klm + 2 - j2 = 1 - kun + nr = 0_${ik}$ + j1 = klm + 2_${ik}$ + j2 = 1_${ik}$ - kun loop_90: do i = 1, minmn ! reduce i-th column and i-th row of matrix to bidiagonal form - ml = klm + 1 - mu = kun + 1 + ml = klm + 1_${ik}$ + mu = kun + 1_${ik}$ loop_80: do kk = 1, kb j1 = j1 + kb j2 = j2 + kb ! generate plane rotations to annihilate nonzero elements ! which have been created below the band - if( nr>0 )call stdlib_slargv( nr, ab( klu1, j1-klm-1 ), inca,work( j1 ), kb1, & + if( nr>0_${ik}$ )call stdlib${ii}$_slargv( nr, ab( klu1, j1-klm-1 ), inca,work( j1 ), kb1, & work( mn+j1 ), kb1 ) ! apply plane rotations from the left do l = 1, kb if( j2-klm+l-1>n ) then - nrt = nr - 1 + nrt = nr - 1_${ik}$ else nrt = nr end if - if( nrt>0 )call stdlib_slartv( nrt, ab( klu1-l, j1-klm+l-1 ), inca,ab( & + if( nrt>0_${ik}$ )call stdlib${ii}$_slartv( 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_slartg( ab( ku+ml-1, i ), ab( ku+ml, i ),work( mn+i+ml-1 ), & + call stdlib${ii}$_slartg( 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( in ) then ! adjust j2 to keep within the bounds of the matrix - nr = nr - 1 + nr = nr - 1_${ik}$ j2 = j2 - kb1 end if do j = j1, j2, kb1 ! create nonzero element a(j-1,j+ku) above the band - ! and store it in work(n+1:2*n) - work( j+kun ) = work( j )*ab( 1, j+kun ) - ab( 1, j+kun ) = work( mn+j )*ab( 1, j+kun ) + ! and store it in work(n+1:2_${ik}$*n) + work( j+kun ) = work( j )*ab( 1_${ik}$, j+kun ) + ab( 1_${ik}$, j+kun ) = work( mn+j )*ab( 1_${ik}$, j+kun ) end do ! generate plane rotations to annihilate nonzero elements ! which have been generated above the band - if( nr>0 )call stdlib_slargv( nr, ab( 1, j1+kun-1 ), inca,work( j1+kun ), kb1,& + if( nr>0_${ik}$ )call stdlib${ii}$_slargv( nr, ab( 1_${ik}$, j1+kun-1 ), inca,work( j1+kun ), kb1,& work( mn+j1+kun ),kb1 ) ! apply plane rotations from the right do l = 1, kb if( j2+l-1>m ) then - nrt = nr - 1 + nrt = nr - 1_${ik}$ else nrt = nr end if - if( nrt>0 )call stdlib_slartv( nrt, ab( l+1, j1+kun-1 ), inca,ab( l, j1+& + if( nrt>0_${ik}$ )call stdlib${ii}$_slartv( 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_slartg( ab( ku-mu+3, i+mu-2 ),ab( ku-mu+2, i+mu-1 ),work( & + call stdlib${ii}$_slartg( 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_srot( 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 ) ) + call stdlib${ii}$_srot( min( kl+mu-2, m-i ),ab( ku-mu+4, i+mu-2 ), 1_${ik}$,ab( ku-& + mu+3, i+mu-1 ), 1_${ik}$,work( mn+i+mu-1 ), work( i+mu-1 ) ) end if - nr = nr + 1 + nr = nr + 1_${ik}$ j1 = j1 - kb1 end if if( wantpt ) then ! accumulate product of plane rotations in p**t do j = j1, j2, kb1 - call stdlib_srot( n, pt( j+kun-1, 1 ), ldpt,pt( j+kun, 1 ), ldpt, work( & + call stdlib${ii}$_srot( n, pt( j+kun-1, 1_${ik}$ ), ldpt,pt( j+kun, 1_${ik}$ ), ldpt, work( & mn+j+kun ),work( j+kun ) ) end do end if if( j2+kb>m ) then ! adjust j2 to keep within the bounds of the matrix - nr = nr - 1 + nr = nr - 1_${ik}$ j2 = j2 - kb1 end if do j = j1, j2, kb1 ! create nonzero element a(j+kl+ku,j+ku-1) below the - ! band and store it in work(1:n) + ! band and store it in work(1_${ik}$:n) work( j+kb ) = work( j+kun )*ab( klu1, j+kun ) ab( klu1, j+kun ) = work( mn+j+kun )*ab( klu1, j+kun ) end do if( ml>ml0 ) then - ml = ml - 1 + ml = ml - 1_${ik}$ else - mu = mu - 1 + mu = mu - 1_${ik}$ end if end do loop_80 end do loop_90 end if - if( ku==0 .and. kl>0 ) then + if( ku==0_${ik}$ .and. kl>0_${ik}$ ) then ! a has been reduced to lower bidiagonal form ! transform lower bidiagonal form to upper bidiagonal by applying ! 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_slartg( ab( 1, i ), ab( 2, i ), rc, rs, ra ) + call stdlib${ii}$_slartg( ab( 1_${ik}$, i ), ab( 2_${ik}$, i ), rc, rs, ra ) d( i ) = ra if( i0 ) then + if( m<=n )d( m ) = ab( 1_${ik}$, m ) + else if( ku>0_${ik}$ ) then ! a has been reduced to upper bidiagonal form if( m1 ) then + if( i>1_${ik}$ ) then rb = -rs*ab( ku, i ) e( i-1 ) = rc*ab( ku, i ) end if - if( wantpt )call stdlib_srot( n, pt( i, 1 ), ldpt, pt( m+1, 1 ), ldpt,rc, rs ) + if( wantpt )call stdlib${ii}$_srot( n, pt( i, 1_${ik}$ ), ldpt, pt( m+1, 1_${ik}$ ), ldpt,rc, rs ) end do else @@ -25051,33 +25053,33 @@ module stdlib_linalg_lapack_s e( i ) = zero end do do i = 1, minmn - d( i ) = ab( 1, i ) + d( i ) = ab( 1_${ik}$, i ) end do end if return - end subroutine stdlib_sgbbrd + end subroutine stdlib${ii}$_sgbbrd - pure subroutine stdlib_sgbcon( norm, n, kl, ku, ab, ldab, ipiv, anorm, rcond,work, iwork, & + pure subroutine stdlib${ii}$_sgbcon( norm, n, kl, ku, ab, ldab, ipiv, anorm, rcond,work, iwork, & !! SGBCON estimates the reciprocal of the condition number of a real - !! general band matrix A, in either the 1-norm or the infinity-norm, + !! general band matrix A, in either the 1_${ik}$-norm or the infinity-norm, !! using the LU factorization computed by SGBTRF. !! An estimate is obtained for norm(inv(A)), and the reciprocal of the !! condition number is computed as - !! RCOND = 1 / ( norm(A) * norm(inv(A)) ). + !! RCOND = 1_${ik}$ / ( norm(A) * norm(inv(A)) ). info ) ! -- lapack computational routine -- ! -- lapack is a software package provided by univ. of tennessee, -- ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: norm - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: kl, ku, ldab, n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: kl, ku, ldab, n real(sp), intent(in) :: anorm real(sp), intent(out) :: rcond ! Array Arguments - integer(ilp), intent(in) :: ipiv(*) - integer(ilp), intent(out) :: iwork(*) + integer(${ik}$), intent(in) :: ipiv(*) + integer(${ik}$), intent(out) :: iwork(*) real(sp), intent(in) :: ab(ldab,*) real(sp), intent(out) :: work(*) ! ===================================================================== @@ -25085,56 +25087,56 @@ module stdlib_linalg_lapack_s ! Local Scalars logical(lk) :: lnoti, onenrm character :: normin - integer(ilp) :: ix, j, jp, kase, kase1, kd, lm + integer(${ik}$) :: ix, j, jp, kase, kase1, kd, lm real(sp) :: ainvnm, scale, smlnum, t ! Local Arrays - integer(ilp) :: isave(3) + integer(${ik}$) :: isave(3_${ik}$) ! Intrinsic Functions intrinsic :: abs,min ! Executable Statements ! test the input parameters. - info = 0 - onenrm = norm=='1' .or. stdlib_lsame( norm, 'O' ) + info = 0_${ik}$ + onenrm = norm=='1_${ik}$' .or. stdlib_lsame( norm, 'O' ) if( .not.onenrm .and. .not.stdlib_lsame( norm, 'I' ) ) then - info = -1 - else if( n<0 ) then - info = -2 - else if( kl<0 ) then - info = -3 - else if( ku<0 ) then - info = -4 - else if( ldab<2*kl+ku+1 ) then - info = -6 + info = -1_${ik}$ + else if( n<0_${ik}$ ) then + info = -2_${ik}$ + else if( kl<0_${ik}$ ) then + info = -3_${ik}$ + else if( ku<0_${ik}$ ) then + info = -4_${ik}$ + else if( ldab<2_${ik}$*kl+ku+1 ) then + info = -6_${ik}$ else if( anorm0 - kase = 0 + kd = kl + ku + 1_${ik}$ + lnoti = kl>0_${ik}$ + kase = 0_${ik}$ 10 continue - call stdlib_slacn2( n, work( n+1 ), work, iwork, ainvnm, kase, isave ) - if( kase/=0 ) then + call stdlib${ii}$_slacn2( n, work( n+1 ), work, iwork, ainvnm, kase, isave ) + if( kase/=0_${ik}$ ) then if( kase==kase1 ) then ! multiply by inv(l). if( lnoti ) then @@ -25146,21 +25148,21 @@ module stdlib_linalg_lapack_s work( jp ) = work( j ) work( j ) = t end if - call stdlib_saxpy( lm, -t, ab( kd+1, j ), 1, work( j+1 ), 1 ) + call stdlib${ii}$_saxpy( lm, -t, ab( kd+1, j ), 1_${ik}$, work( j+1 ), 1_${ik}$ ) end do end if ! multiply by inv(u). - call stdlib_slatbs( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', normin, n,kl+ku, ab, & - ldab, work, scale, work( 2*n+1 ),info ) + call stdlib${ii}$_slatbs( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', normin, n,kl+ku, ab, & + ldab, work, scale, work( 2_${ik}$*n+1 ),info ) else ! multiply by inv(u**t). - call stdlib_slatbs( 'UPPER', 'TRANSPOSE', 'NON-UNIT', normin, n,kl+ku, ab, ldab, & - work, scale, work( 2*n+1 ),info ) + call stdlib${ii}$_slatbs( 'UPPER', 'TRANSPOSE', 'NON-UNIT', normin, n,kl+ku, ab, ldab, & + work, scale, work( 2_${ik}$*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_sdot( lm, ab( kd+1, j ), 1,work( j+1 ), 1 ) + work( j ) = work( j ) - stdlib${ii}$_sdot( lm, ab( kd+1, j ), 1_${ik}$,work( j+1 ), 1_${ik}$ ) jp = ipiv( j ) if( jp/=j ) then @@ -25171,12 +25173,12 @@ module stdlib_linalg_lapack_s end do end if end if - ! divide x by 1/scale if doing so will not cause overflow. + ! divide x by 1_${ik}$/scale if doing so will not cause overflow. normin = 'Y' if( scale/=one ) then - ix = stdlib_isamax( n, work, 1 ) + ix = stdlib${ii}$_isamax( n, work, 1_${ik}$ ) if( scalezero ) then - r( i ) = radix**int( log( r( i ) ) / logrdx,KIND=ilp) + r( i ) = radix**int( log( r( i ) ) / logrdx,KIND=${ik}$) end if end do ! find the maximum and minimum scale factors. @@ -25432,7 +25434,7 @@ module stdlib_linalg_lapack_s c( j ) = max( c( j ), abs( ab( kd+i-j, j ) )*r( i ) ) end do if( c( j )>zero ) then - c( j ) = radix**int( log( c( j ) ) / logrdx,KIND=ilp) + c( j ) = radix**int( log( c( j ) ) / logrdx,KIND=${ik}$) end if end do ! find the maximum and minimum scale factors. @@ -25459,10 +25461,10 @@ module stdlib_linalg_lapack_s colcnd = max( rcmin, smlnum ) / min( rcmax, bignum ) end if return - end subroutine stdlib_sgbequb + end subroutine stdlib${ii}$_sgbequb - pure subroutine stdlib_sgbrfs( trans, n, kl, ku, nrhs, ab, ldab, afb, ldafb,ipiv, b, ldb, x, & + pure subroutine stdlib${ii}$_sgbrfs( trans, n, kl, ku, nrhs, ab, ldab, afb, ldafb,ipiv, b, ldb, x, & !! SGBRFS improves the computed solution to a system of linear !! equations when the coefficient matrix is banded, and provides !! error bounds and backward error estimates for the solution. @@ -25472,17 +25474,17 @@ module stdlib_linalg_lapack_s ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: trans - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: kl, ku, ldab, ldafb, ldb, ldx, n, nrhs + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: kl, ku, ldab, ldafb, ldb, ldx, n, nrhs ! Array Arguments - integer(ilp), intent(in) :: ipiv(*) - integer(ilp), intent(out) :: iwork(*) + integer(${ik}$), intent(in) :: ipiv(*) + integer(${ik}$), intent(out) :: iwork(*) real(sp), intent(in) :: ab(ldab,*), afb(ldafb,*), b(ldb,*) real(sp), intent(out) :: berr(*), ferr(*), work(*) real(sp), intent(inout) :: x(ldx,*) ! ===================================================================== ! Parameters - integer(ilp), parameter :: itmax = 5 + integer(${ik}$), parameter :: itmax = 5_${ik}$ @@ -25491,42 +25493,42 @@ module stdlib_linalg_lapack_s ! Local Scalars logical(lk) :: notran character :: transt - integer(ilp) :: count, i, j, k, kase, kk, nz + integer(${ik}$) :: count, i, j, k, kase, kk, nz real(sp) :: eps, lstres, s, safe1, safe2, safmin, xk ! Local Arrays - integer(ilp) :: isave(3) + integer(${ik}$) :: isave(3_${ik}$) ! Intrinsic Functions intrinsic :: abs,max,min ! Executable Statements ! test the input parameters. - info = 0 + info = 0_${ik}$ notran = stdlib_lsame( trans, 'N' ) if( .not.notran .and. .not.stdlib_lsame( trans, 'T' ) .and. .not.stdlib_lsame( trans, & 'C' ) ) then - info = -1 - else if( n<0 ) then - info = -2 - else if( kl<0 ) then - info = -3 - else if( ku<0 ) then - info = -4 - else if( nrhs<0 ) then - info = -5 + info = -1_${ik}$ + else if( n<0_${ik}$ ) then + info = -2_${ik}$ + else if( kl<0_${ik}$ ) then + info = -3_${ik}$ + else if( ku<0_${ik}$ ) then + info = -4_${ik}$ + else if( nrhs<0_${ik}$ ) then + info = -5_${ik}$ else if( ldabeps .and. two*berr( j )<=lstres .and.count<=itmax ) then ! update solution and try again. - call stdlib_sgbtrs( trans, n, kl, ku, 1, afb, ldafb, ipiv,work( n+1 ), n, info ) + call stdlib${ii}$_sgbtrs( trans, n, kl, ku, 1_${ik}$, afb, ldafb, ipiv,work( n+1 ), n, info ) - call stdlib_saxpy( n, one, work( n+1 ), 1, x( 1, j ), 1 ) + call stdlib${ii}$_saxpy( n, one, work( n+1 ), 1_${ik}$, x( 1_${ik}$, j ), 1_${ik}$ ) lstres = berr( j ) - count = count + 1 + count = count + 1_${ik}$ go to 20 end if ! bound error from formula @@ -25615,7 +25617,7 @@ module stdlib_linalg_lapack_s ! inv(op(a)) is the inverse of op(a) ! abs(z) is the componentwise absolute value of the matrix or ! vector z - ! nz is the maximum number of nonzeros in any row of a, plus 1 + ! nz is the maximum number of nonzeros in any row of a, plus 1_${ik}$ ! eps is machine epsilon ! 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 @@ -25630,14 +25632,14 @@ module stdlib_linalg_lapack_s work( i ) = abs( work( n+i ) ) + nz*eps*work( i ) + safe1 end if end do - kase = 0 + kase = 0_${ik}$ 100 continue - call stdlib_slacn2( n, work( 2*n+1 ), work( n+1 ), iwork, ferr( j ),kase, isave ) + call stdlib${ii}$_slacn2( n, work( 2_${ik}$*n+1 ), work( n+1 ), iwork, ferr( j ),kase, isave ) - if( kase/=0 ) then - if( kase==1 ) then + if( kase/=0_${ik}$ ) then + if( kase==1_${ik}$ ) then ! multiply by diag(w)*inv(op(a)**t). - call stdlib_sgbtrs( transt, n, kl, ku, 1, afb, ldafb, ipiv,work( n+1 ), n, & + call stdlib${ii}$_sgbtrs( transt, n, kl, ku, 1_${ik}$, afb, ldafb, ipiv,work( n+1 ), n, & info ) do i = 1, n work( n+i ) = work( n+i )*work( i ) @@ -25647,7 +25649,7 @@ module stdlib_linalg_lapack_s do i = 1, n work( n+i ) = work( n+i )*work( i ) end do - call stdlib_sgbtrs( trans, n, kl, ku, 1, afb, ldafb, ipiv,work( n+1 ), n, & + call stdlib${ii}$_sgbtrs( trans, n, kl, ku, 1_${ik}$, afb, ldafb, ipiv,work( n+1 ), n, & info ) end if go to 100 @@ -25660,30 +25662,30 @@ module stdlib_linalg_lapack_s if( lstres/=zero )ferr( j ) = ferr( j ) / lstres end do loop_140 return - end subroutine stdlib_sgbrfs + end subroutine stdlib${ii}$_sgbrfs - pure subroutine stdlib_sgbtrf( m, n, kl, ku, ab, ldab, ipiv, info ) + pure subroutine stdlib${ii}$_sgbtrf( m, n, kl, ku, ab, ldab, ipiv, info ) !! SGBTRF 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. + !! This is the blocked version of the algorithm, calling Level 3_${ik}$ BLAS. ! -- lapack computational routine -- ! -- lapack is a software package provided by univ. of tennessee, -- ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: kl, ku, ldab, m, n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: kl, ku, ldab, m, n ! Array Arguments - integer(ilp), intent(out) :: ipiv(*) + integer(${ik}$), intent(out) :: ipiv(*) real(sp), intent(inout) :: ab(ldab,*) ! ===================================================================== ! Parameters - integer(ilp), parameter :: nbmax = 64 - integer(ilp), parameter :: ldwork = nbmax+1 + integer(${ik}$), parameter :: nbmax = 64_${ik}$ + integer(${ik}$), parameter :: ldwork = nbmax+1 ! Local Scalars - integer(ilp) :: i, i2, i3, ii, ip, j, j2, j3, jb, jj, jm, jp, ju, k2, km, kv, nb, & + integer(${ik}$) :: i, i2, i3, ii, ip, j, j2, j3, jb, jj, jm, jp, ju, k2, km, kv, nb, & nw real(sp) :: temp ! Local Arrays @@ -25695,32 +25697,32 @@ module stdlib_linalg_lapack_s ! fill-in kv = ku + kl ! test the input parameters. - info = 0 - if( m<0 ) then - info = -1 - else if( n<0 ) then - info = -2 - else if( kl<0 ) then - info = -3 - else if( ku<0 ) then - info = -4 + info = 0_${ik}$ + if( m<0_${ik}$ ) then + info = -1_${ik}$ + else if( n<0_${ik}$ ) then + info = -2_${ik}$ + else if( kl<0_${ik}$ ) then + info = -3_${ik}$ + else if( ku<0_${ik}$ ) then + info = -4_${ik}$ else if( ldabkl ) then + if( nb<=1_${ik}$ .or. nb>kl ) then ! use unblocked code - call stdlib_sgbtf2( m, n, kl, ku, ab, ldab, ipiv, info ) + call stdlib${ii}$_sgbtf2( m, n, kl, ku, ab, ldab, ipiv, info ) else ! use blocked code ! zero the superdiagonal elements of the work array work13 @@ -25744,7 +25746,7 @@ module stdlib_linalg_lapack_s end do ! ju is the index of the last column affected by the current ! stage of the factorization - ju = 1 + ju = 1_${ik}$ loop_180: do j = 1, min( m, n ), nb jb = min( nb, min( m, n )-j+1 ) ! the active part of the matrix is partitioned @@ -25770,57 +25772,57 @@ module stdlib_linalg_lapack_s ! find pivot and test for singularity. km is the number of ! subdiagonal elements in the current column. km = min( kl, m-jj ) - jp = stdlib_isamax( km+1, ab( kv+1, jj ), 1 ) + jp = stdlib${ii}$_isamax( km+1, ab( kv+1, jj ), 1_${ik}$ ) 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 + if( jp/=1_${ik}$ ) then ! apply interchange to columns j to j+jb-1 if( jp+jj-1jj )call stdlib_sger( km, jm-jj, -one, ab( kv+2, jj ), 1,ab( kv, jj+& - 1 ), ldab-1,ab( kv+1, jj+1 ), ldab-1 ) + if( jm>jj )call stdlib${ii}$_sger( km, jm-jj, -one, ab( kv+2, jj ), 1_${ik}$,ab( kv, jj+& + 1_${ik}$ ), ldab-1,ab( kv+1, jj+1 ), ldab-1 ) else ! if pivot is zero, set info to the index of the pivot ! unless a zero pivot has already been found. - if( info==0 )info = jj + if( info==0_${ik}$ )info = jj end if ! copy current column of a31 into the work array work31 nw = min( jj-j+1, i3 ) - if( nw>0 )call stdlib_scopy( nw, ab( kv+kl+1-jj+j, jj ), 1,work31( 1, jj-j+1 )& - , 1 ) + if( nw>0_${ik}$ )call stdlib${ii}$_scopy( nw, ab( kv+kl+1-jj+j, jj ), 1_${ik}$,work31( 1_${ik}$, jj-j+1 )& + , 1_${ik}$ ) 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 ) + j3 = max( 0_${ik}$, ju-j-kv+1 ) ! use stdlib_slaswp to apply the row interchanges to a12, a22, and ! a32. - call stdlib_slaswp( j2, ab( kv+1-jb, j+jb ), ldab-1, 1, jb,ipiv( j ), 1 ) + call stdlib${ii}$_slaswp( j2, ab( kv+1-jb, j+jb ), ldab-1, 1_${ik}$, jb,ipiv( j ), 1_${ik}$ ) ! adjust the pivot indices. do i = j, j + jb - 1 - ipiv( i ) = ipiv( i ) + j - 1 + ipiv( i ) = ipiv( i ) + j - 1_${ik}$ end do ! apply the row interchanges to a13, a23, and a33 ! columnwise. - k2 = j - 1 + jb + j2 + k2 = j - 1_${ik}$ + jb + j2 do i = 1, j3 jj = k2 + i do ii = j + i - 1, j + jb - 1 @@ -25833,24 +25835,24 @@ module stdlib_linalg_lapack_s end do end do ! update the relevant part of the trailing submatrix - if( j2>0 ) then + if( j2>0_${ik}$ ) then ! update a12 - call stdlib_strsm( 'LEFT', 'LOWER', 'NO TRANSPOSE', 'UNIT',jb, j2, one, ab(& + call stdlib${ii}$_strsm( '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 + if( i2>0_${ik}$ ) then ! update a22 - call stdlib_sgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', i2, j2,jb, -one, ab( & + call stdlib${ii}$_sgemm( '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 + if( i3>0_${ik}$ ) then ! update a32 - call stdlib_sgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', i3, j2,jb, -one, & + call stdlib${ii}$_sgemm( '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 end if - if( j3>0 ) then + if( j3>0_${ik}$ ) then ! copy the lower triangle of a13 into the work array ! work13 do jj = 1, j3 @@ -25859,18 +25861,18 @@ module stdlib_linalg_lapack_s end do end do ! update a13 in the work array - call stdlib_strsm( 'LEFT', 'LOWER', 'NO TRANSPOSE', 'UNIT',jb, j3, one, ab(& + call stdlib${ii}$_strsm( 'LEFT', 'LOWER', 'NO TRANSPOSE', 'UNIT',jb, j3, one, ab(& kv+1, j ), ldab-1,work13, ldwork ) - if( i2>0 ) then + if( i2>0_${ik}$ ) then ! update a23 - call stdlib_sgemm( '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 ) + call stdlib${ii}$_sgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', i2, j3,jb, -one, ab( & + kv+1+jb, j ), ldab-1,work13, ldwork, one, ab( 1_${ik}$+jb, j+kv ),ldab-1 ) end if - if( i3>0 ) then + if( i3>0_${ik}$ ) then ! update a33 - call stdlib_sgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', i3, j3,jb, -one, & - work31, ldwork, work13,ldwork, one, ab( 1+kl, j+kv ), ldab-1 ) + call stdlib${ii}$_sgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', i3, j3,jb, -one, & + work31, ldwork, work13,ldwork, one, ab( 1_${ik}$+kl, j+kv ), ldab-1 ) end if ! copy the lower triangle of a13 back into place do jj = 1, j3 @@ -25882,55 +25884,55 @@ module stdlib_linalg_lapack_s else ! adjust the pivot indices. do i = j, j + jb - 1 - ipiv( i ) = ipiv( i ) + j - 1 + ipiv( i ) = ipiv( i ) + j - 1_${ik}$ end do end if ! partially undo the interchanges in the current block to ! restore the upper triangular form of a31 and copy the upper ! triangle of a31 back into place do jj = j + jb - 1, j, -1 - jp = ipiv( jj ) - jj + 1 - if( jp/=1 ) then + jp = ipiv( jj ) - jj + 1_${ik}$ + if( jp/=1_${ik}$ ) then ! apply interchange to columns j to jj-1 if( jp+jj-10 )call stdlib_scopy( nw, work31( 1, jj-j+1 ), 1,ab( kv+kl+1-jj+j, jj )& - , 1 ) + if( nw>0_${ik}$ )call stdlib${ii}$_scopy( nw, work31( 1_${ik}$, jj-j+1 ), 1_${ik}$,ab( kv+kl+1-jj+j, jj )& + , 1_${ik}$ ) end do end do loop_180 end if return - end subroutine stdlib_sgbtrf + end subroutine stdlib${ii}$_sgbtrf - pure subroutine stdlib_sgecon( norm, n, a, lda, anorm, rcond, work, iwork,info ) + pure subroutine stdlib${ii}$_sgecon( norm, n, a, lda, anorm, rcond, work, iwork,info ) !! SGECON estimates the reciprocal of the condition number of a general - !! real matrix A, in either the 1-norm or the infinity-norm, using + !! real matrix A, in either the 1_${ik}$-norm or the infinity-norm, using !! the LU factorization computed by SGETRF. !! An estimate is obtained for norm(inv(A)), and the reciprocal of the !! condition number is computed as - !! RCOND = 1 / ( norm(A) * norm(inv(A)) ). + !! RCOND = 1_${ik}$ / ( norm(A) * norm(inv(A)) ). ! -- lapack computational routine -- ! -- lapack is a software package provided by univ. of tennessee, -- ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: norm - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda, n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, n real(sp), intent(in) :: anorm real(sp), intent(out) :: rcond ! Array Arguments - integer(ilp), intent(out) :: iwork(*) + integer(${ik}$), intent(out) :: iwork(*) real(sp), intent(inout) :: a(lda,*) real(sp), intent(out) :: work(*) ! ===================================================================== @@ -25938,72 +25940,72 @@ module stdlib_linalg_lapack_s ! Local Scalars logical(lk) :: onenrm character :: normin - integer(ilp) :: ix, kase, kase1 + integer(${ik}$) :: ix, kase, kase1 real(sp) :: ainvnm, scale, sl, smlnum, su ! Local Arrays - integer(ilp) :: isave(3) + integer(${ik}$) :: isave(3_${ik}$) ! Intrinsic Functions intrinsic :: abs,max ! Executable Statements ! test the input parameters. - info = 0 - onenrm = norm=='1' .or. stdlib_lsame( norm, 'O' ) + info = 0_${ik}$ + onenrm = norm=='1_${ik}$' .or. stdlib_lsame( norm, 'O' ) if( .not.onenrm .and. .not.stdlib_lsame( norm, 'I' ) ) then - info = -1 - else if( n<0 ) then - info = -2 - else if( ldazero ) then - r( i ) = radix**int( log( r( i ) ) / logrdx,KIND=ilp) + r( i ) = radix**int( log( r( i ) ) / logrdx,KIND=${ik}$) end if end do ! find the maximum and minimum scale factors. @@ -26246,7 +26248,7 @@ module stdlib_linalg_lapack_s c( j ) = max( c( j ), abs( a( i, j ) )*r( i ) ) end do if( c( j )>zero ) then - c( j ) = radix**int( log( c( j ) ) / logrdx,KIND=ilp) + c( j ) = radix**int( log( c( j ) ) / logrdx,KIND=${ik}$) end if end do ! find the maximum and minimum scale factors. @@ -26273,17 +26275,17 @@ module stdlib_linalg_lapack_s colcnd = max( rcmin, smlnum ) / min( rcmax, bignum ) end if return - end subroutine stdlib_sgeequb + end subroutine stdlib${ii}$_sgeequb - pure subroutine stdlib_sgemlqt( side, trans, m, n, k, mb, v, ldv, t, ldt,c, ldc, work, info ) + pure subroutine stdlib${ii}$_sgemlqt( 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 !! TRANS = 'T': Q**T C C Q**T !! where Q is a real orthogonal matrix defined as the product of K !! elementary reflectors: - !! Q = H(1) H(2) . . . H(K) = I - V T V**T + !! Q = H(1_${ik}$) H(2_${ik}$) . . . H(K) = I - V T V**T !! generated using the compact WY representation as returned by SGELQT. !! Q is of order M if SIDE = 'L' and of order N if SIDE = 'R'. @@ -26292,8 +26294,8 @@ module stdlib_linalg_lapack_s ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: side, trans - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: k, ldv, ldc, m, n, mb, ldt + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: k, ldv, ldc, m, n, mb, ldt ! Array Arguments real(sp), intent(in) :: v(ldv,*), t(ldt,*) real(sp), intent(inout) :: c(ldc,*) @@ -26301,44 +26303,44 @@ module stdlib_linalg_lapack_s ! ===================================================================== ! Local Scalars logical(lk) :: left, right, tran, notran - integer(ilp) :: i, ib, ldwork, kf, q + integer(${ik}$) :: i, ib, ldwork, kf, q ! Intrinsic Functions intrinsic :: max,min ! Executable Statements ! Test The Input Arguments - info = 0 + info = 0_${ik}$ left = stdlib_lsame( side, 'L' ) right = stdlib_lsame( side, 'R' ) tran = stdlib_lsame( trans, 'T' ) notran = stdlib_lsame( trans, 'N' ) if( left ) then - ldwork = max( 1, n ) + ldwork = max( 1_${ik}$, n ) q = m else if ( right ) then - ldwork = max( 1, m ) + ldwork = max( 1_${ik}$, m ) q = n end if if( .not.left .and. .not.right ) then - info = -1 + info = -1_${ik}$ else if( .not.tran .and. .not.notran ) then - info = -2 - else if( m<0 ) then - info = -3 - else if( n<0 ) then - info = -4 - else if( k<0 .or. k>q ) then - info = -5 - else if( mb<1 .or. (mb>k .and. k>0)) then - info = -6 - else if( ldvq ) then + info = -5_${ik}$ + else if( mb<1_${ik}$ .or. (mb>k .and. k>0_${ik}$)) then + info = -6_${ik}$ + else if( ldvq ) then - info = -5 - else if( nb<1 .or. (nb>k .and. k>0)) then - info = -6 - else if( ldvq ) then + info = -5_${ik}$ + else if( nb<1_${ik}$ .or. (nb>k .and. k>0_${ik}$)) then + info = -6_${ik}$ + else if( ldvabs( a( n, n ) ) ) then temp = ( one / two ) / abs( rhs( i ) ) - call stdlib_sscal( n, temp, rhs( 1 ), 1 ) + call stdlib${ii}$_sscal( n, temp, rhs( 1_${ik}$ ), 1_${ik}$ ) scale = scale*temp end if do i = n, 1, -1 @@ -26525,49 +26527,49 @@ module stdlib_linalg_lapack_s end do end do ! apply permutations jpiv to the solution (rhs) - call stdlib_slaswp( 1, rhs, lda, 1, n-1, jpiv, -1 ) + call stdlib${ii}$_slaswp( 1_${ik}$, rhs, lda, 1_${ik}$, n-1, jpiv, -1_${ik}$ ) return - end subroutine stdlib_sgesc2 + end subroutine stdlib${ii}$_sgesc2 - pure subroutine stdlib_sgetc2( n, a, lda, ipiv, jpiv, info ) + pure subroutine stdlib${ii}$_sgetc2( n, a, lda, ipiv, jpiv, info ) !! SGETC2 computes an LU factorization with complete pivoting of the !! n-by-n matrix A. The factorization has the form A = P * L * U * Q, !! where P and Q are permutation matrices, L is lower triangular with !! unit diagonal elements and U is upper triangular. - !! This is the Level 2 BLAS algorithm. + !! This is the Level 2_${ik}$ BLAS algorithm. ! -- 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, n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, n ! Array Arguments - integer(ilp), intent(out) :: ipiv(*), jpiv(*) + integer(${ik}$), intent(out) :: ipiv(*), jpiv(*) real(sp), intent(inout) :: a(lda,*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, ip, ipv, j, jp, jpv + integer(${ik}$) :: i, ip, ipv, j, jp, jpv real(sp) :: bignum, eps, smin, smlnum, xmax ! Intrinsic Functions intrinsic :: abs,max ! Executable Statements - info = 0 + info = 0_${ik}$ ! quick return if possible if( n==0 )return ! set constants to control overflow - eps = stdlib_slamch( 'P' ) - smlnum = stdlib_slamch( 'S' ) / eps + eps = stdlib${ii}$_slamch( 'P' ) + smlnum = stdlib${ii}$_slamch( 'S' ) / eps bignum = one / smlnum - call stdlib_slabad( smlnum, bignum ) - ! handle the case n=1 by itself - if( n==1 ) then - ipiv( 1 ) = 1 - jpiv( 1 ) = 1 - if( abs( a( 1, 1 ) ) n), and U is upper !! triangular (upper trapezoidal if m < n). - !! This is the right-looking Level 2 BLAS version of the algorithm. + !! This is the right-looking Level 2_${ik}$ BLAS version of the algorithm. ! -- 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 - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda, m, n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, m, n ! Array Arguments - integer(ilp), intent(out) :: ipiv(*) + integer(${ik}$), intent(out) :: ipiv(*) real(sp), intent(inout) :: a(lda,*) ! ===================================================================== ! Local Scalars real(sp) :: sfmin - integer(ilp) :: i, j, jp + integer(${ik}$) :: i, j, jp ! Intrinsic Functions intrinsic :: max,min ! Executable Statements ! test the input parameters. - info = 0 - if( m<0 ) then - info = -1 - else if( n<0 ) then - info = -2 - else if( lda= sfmin ) then - call stdlib_sscal( m-j, one / a( j, j ), a( j+1, j ), 1 ) + call stdlib${ii}$_sscal( m-j, one / a( j, j ), a( j+1, j ), 1_${ik}$ ) else do i = 1, m-j a( j+i, j ) = a( j+i, j ) / a( j, j ) end do end if end if - else if( info==0 ) then + else if( info==0_${ik}$ ) then info = j end if if( j= sfmin ) then - call stdlib_sscal( m-1, one / a( 1, 1 ), a( 2, 1 ), 1 ) + if( i/=1_${ik}$ ) then + temp = a( 1_${ik}$, 1_${ik}$ ) + a( 1_${ik}$, 1_${ik}$ ) = a( i, 1_${ik}$ ) + a( i, 1_${ik}$ ) = temp + end if + ! compute elements 2_${ik}$:m of the column + if( abs(a( 1_${ik}$, 1_${ik}$ )) >= sfmin ) then + call stdlib${ii}$_sscal( m-1, one / a( 1_${ik}$, 1_${ik}$ ), a( 2_${ik}$, 1_${ik}$ ), 1_${ik}$ ) else do i = 1, m-1 - a( 1+i, 1 ) = a( 1+i, 1 ) / a( 1, 1 ) + a( 1_${ik}$+i, 1_${ik}$ ) = a( 1_${ik}$+i, 1_${ik}$ ) / a( 1_${ik}$, 1_${ik}$ ) end do end if else - info = 1 + info = 1_${ik}$ end if else ! use recursive code - n1 = min( m, n ) / 2 + n1 = min( m, n ) / 2_${ik}$ n2 = n-n1 ! [ a11 ] ! factor [ --- ] ! [ a21 ] - call stdlib_sgetrf2( m, n1, a, lda, ipiv, iinfo ) - if ( info==0 .and. iinfo>0 )info = iinfo + call stdlib${ii}$_sgetrf2( m, n1, a, lda, ipiv, iinfo ) + if ( info==0_${ik}$ .and. iinfo>0_${ik}$ )info = iinfo ! [ a12 ] ! apply interchanges to [ --- ] ! [ a22 ] - call stdlib_slaswp( n2, a( 1, n1+1 ), lda, 1, n1, ipiv, 1 ) + call stdlib${ii}$_slaswp( n2, a( 1_${ik}$, n1+1 ), lda, 1_${ik}$, n1, ipiv, 1_${ik}$ ) ! solve a12 - call stdlib_strsm( 'L', 'L', 'N', 'U', n1, n2, one, a, lda,a( 1, n1+1 ), lda ) + call stdlib${ii}$_strsm( 'L', 'L', 'N', 'U', n1, n2, one, a, lda,a( 1_${ik}$, n1+1 ), lda ) ! update a22 - call stdlib_sgemm( 'N', 'N', m-n1, n2, n1, -one, a( n1+1, 1 ), lda,a( 1, n1+1 ), & + call stdlib${ii}$_sgemm( 'N', 'N', m-n1, n2, n1, -one, a( n1+1, 1_${ik}$ ), lda,a( 1_${ik}$, n1+1 ), & lda, one, a( n1+1, n1+1 ), lda ) ! factor a22 - call stdlib_sgetrf2( m-n1, n2, a( n1+1, n1+1 ), lda, ipiv( n1+1 ),iinfo ) + call stdlib${ii}$_sgetrf2( 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 + if ( info==0_${ik}$ .and. iinfo>0_${ik}$ )info = iinfo + n1 do i = n1+1, min( m, n ) ipiv( i ) = ipiv( i ) + n1 end do ! apply interchanges to a21 - call stdlib_slaswp( n1, a( 1, 1 ), lda, n1+1, min( m, n), ipiv, 1 ) + call stdlib${ii}$_slaswp( n1, a( 1_${ik}$, 1_${ik}$ ), lda, n1+1, min( m, n), ipiv, 1_${ik}$ ) end if return - end subroutine stdlib_sgetrf2 + end subroutine stdlib${ii}$_sgetrf2 - pure subroutine stdlib_sgetri( n, a, lda, ipiv, work, lwork, info ) + pure subroutine stdlib${ii}$_sgetri( n, a, lda, ipiv, work, lwork, info ) !! SGETRI computes the inverse of a matrix using the LU factorization !! computed by SGETRF. !! This method inverts U and then computes inv(A) by solving the system @@ -26811,52 +26813,52 @@ module stdlib_linalg_lapack_s ! -- 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, lwork, n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, lwork, n ! Array Arguments - integer(ilp), intent(in) :: ipiv(*) + integer(${ik}$), intent(in) :: ipiv(*) real(sp), intent(inout) :: a(lda,*) real(sp), intent(out) :: work(*) ! ===================================================================== ! Local Scalars logical(lk) :: lquery - integer(ilp) :: i, iws, j, jb, jj, jp, ldwork, lwkopt, nb, nbmin, nn + integer(${ik}$) :: i, iws, j, jb, jj, jp, ldwork, lwkopt, nb, nbmin, nn ! Intrinsic Functions intrinsic :: max,min ! Executable Statements ! test the input parameters. - info = 0 - nb = stdlib_ilaenv( 1, 'SGETRI', ' ', n, -1, -1, -1 ) + info = 0_${ik}$ + nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'SGETRI', ' ', n, -1_${ik}$, -1_${ik}$, -1_${ik}$ ) lwkopt = n*nb - work( 1 ) = lwkopt - lquery = ( lwork==-1 ) - if( n<0 ) then - info = -1 - else if( lda 0 from stdlib_strtri, then u is singular, + ! form inv(u). if info > 0_${ik}$ from stdlib${ii}$_strtri, then u is singular, ! and the inverse is not computed. - call stdlib_strtri( 'UPPER', 'NON-UNIT', n, a, lda, info ) + call stdlib${ii}$_strtri( 'UPPER', 'NON-UNIT', n, a, lda, info ) if( info>0 )return - nbmin = 2 + nbmin = 2_${ik}$ ldwork = n - if( nb>1 .and. nb1_${ik}$ .and. nbn .or. ihi=nrhs ) then - call stdlib_sgtts2( itrans, n, nrhs, dl, d, du, du2, ipiv, b, ldb ) + call stdlib${ii}$_sgtts2( itrans, n, nrhs, dl, d, du, du2, ipiv, b, ldb ) else do j = 1, nrhs, nb jb = min( nrhs-j+1, nb ) - call stdlib_sgtts2( itrans, n, jb, dl, d, du, du2, ipiv, b( 1, j ),ldb ) + call stdlib${ii}$_sgtts2( itrans, n, jb, dl, d, du, du2, ipiv, b( 1_${ik}$, j ),ldb ) end do end if - end subroutine stdlib_sgttrs + end subroutine stdlib${ii}$_sgttrs - pure logical(lk) function stdlib_sisnan( sin ) + pure logical(lk) function stdlib${ii}$_sisnan( sin ) !! SISNAN returns .TRUE. if its argument is NaN, and .FALSE. - !! otherwise. To be replaced by the Fortran 2003 intrinsic in the + !! otherwise. To be replaced by the Fortran 2003_${ik}$ intrinsic in the !! future. ! -- lapack auxiliary routine -- ! -- lapack is a software package provided by univ. of tennessee, -- @@ -27472,12 +27474,12 @@ module stdlib_linalg_lapack_s real(sp), intent(in) :: sin ! ===================================================================== ! Executable Statements - stdlib_sisnan = stdlib_slaisnan(sin,sin) + stdlib${ii}$_sisnan = stdlib${ii}$_slaisnan(sin,sin) return - end function stdlib_sisnan + end function stdlib${ii}$_sisnan - subroutine stdlib_sla_gbamv( trans, m, n, kl, ku, alpha, ab, ldab, x,incx, beta, y, incy ) + subroutine stdlib${ii}$_sla_gbamv( trans, m, n, kl, ku, alpha, ab, ldab, x,incx, beta, y, incy ) !! SLA_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), @@ -27497,7 +27499,7 @@ module stdlib_linalg_lapack_s ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments real(sp), intent(in) :: alpha, beta - integer(ilp), intent(in) :: incx, incy, ldab, m, n, kl, ku, trans + integer(${ik}$), intent(in) :: incx, incy, ldab, m, n, kl, ku, trans ! Array Arguments real(sp), intent(in) :: ab(ldab,*), x(*) real(sp), intent(inout) :: y(*) @@ -27506,68 +27508,68 @@ module stdlib_linalg_lapack_s ! Local Scalars logical(lk) :: symb_zero real(sp) :: temp, safe1 - integer(ilp) :: i, info, iy, j, jx, kx, ky, lenx, leny, kd, ke + integer(${ik}$) :: i, info, iy, j, jx, kx, ky, lenx, leny, kd, ke ! Intrinsic Functions intrinsic :: max,abs,sign ! Executable Statements ! test the input parameters. - info = 0 - if ( .not.( ( trans==stdlib_ilatrans( 'N' ) ).or. ( trans==stdlib_ilatrans( 'T' ) )& - .or. ( trans==stdlib_ilatrans( 'C' ) ) ) ) then - info = 1 - else if( m<0 )then - info = 2 - else if( n<0 )then - info = 3 - else if( kl<0 .or. kl>m-1 ) then - info = 4 - else if( ku<0 .or. ku>n-1 ) then - info = 5 + info = 0_${ik}$ + if ( .not.( ( trans==stdlib${ii}$_ilatrans( 'N' ) ).or. ( trans==stdlib${ii}$_ilatrans( 'T' ) )& + .or. ( trans==stdlib${ii}$_ilatrans( 'C' ) ) ) ) then + info = 1_${ik}$ + else if( m<0_${ik}$ )then + info = 2_${ik}$ + else if( n<0_${ik}$ )then + info = 3_${ik}$ + else if( kl<0_${ik}$ .or. kl>m-1 ) then + info = 4_${ik}$ + else if( ku<0_${ik}$ .or. ku>n-1 ) then + info = 5_${ik}$ else if( ldab0 )then - kx = 1 + if( incx>0_${ik}$ )then + kx = 1_${ik}$ else - kx = 1 - ( lenx - 1 )*incx + kx = 1_${ik}$ - ( lenx - 1_${ik}$ )*incx end if - if( incy>0 )then - ky = 1 + if( incy>0_${ik}$ )then + ky = 1_${ik}$ else - ky = 1 - ( leny - 1 )*incy + ky = 1_${ik}$ - ( leny - 1_${ik}$ )*incy end if ! set safe1 essentially to be the underflow threshold times the ! number of additions in each row. - safe1 = stdlib_slamch( 'SAFE MINIMUM' ) + safe1 = stdlib${ii}$_slamch( 'SAFE MINIMUM' ) safe1 = (n+1)*safe1 ! form y := alpha*abs(a)*abs(x) + beta*abs(y). ! the o(m*n) symb_zero tests could be replaced by o(n) queries to ! the inexact flag. still doesn't help change the iteration order ! to per-column. - kd = ku + 1 - ke = kl + 1 + kd = ku + 1_${ik}$ + ke = kl + 1_${ik}$ iy = ky - if ( incx==1 ) then - if( trans==stdlib_ilatrans( 'N' ) )then + if ( incx==1_${ik}$ ) then + if( trans==stdlib${ii}$_ilatrans( 'N' ) )then do i = 1, leny if ( beta == zero ) then symb_zero = .true. @@ -27611,7 +27613,7 @@ module stdlib_linalg_lapack_s end do end if else - if( trans==stdlib_ilatrans( 'N' ) )then + if( trans==stdlib${ii}$_ilatrans( 'N' ) )then do i = 1, leny if ( beta == zero ) then symb_zero = .true. @@ -27660,15 +27662,15 @@ module stdlib_linalg_lapack_s end if end if return - end subroutine stdlib_sla_gbamv + end subroutine stdlib${ii}$_sla_gbamv - real(sp) function stdlib_sla_gbrcond( trans, n, kl, ku, ab, ldab, afb, ldafb,ipiv, cmode, c, & + real(sp) function stdlib${ii}$_sla_gbrcond( trans, n, kl, ku, ab, ldab, afb, ldafb,ipiv, cmode, c, & !! SLA_GBRCOND Estimates the Skeel condition number of op(A) * op2(C) !! where op2 is determined by CMODE as follows - !! CMODE = 1 op2(C) = C - !! CMODE = 0 op2(C) = I - !! CMODE = -1 op2(C) = inv(C) + !! CMODE = 1_${ik}$ op2(C) = C + !! CMODE = 0_${ik}$ op2(C) = I + !! CMODE = -1_${ik}$ op2(C) = inv(C) !! The Skeel condition number cond(A) = norminf( |inv(A)||A| ) !! is computed by computing scaling factors R such that !! diag(R)*A*op2(C) is row equilibrated and computing the standard @@ -27679,60 +27681,60 @@ module stdlib_linalg_lapack_s ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: trans - integer(ilp), intent(in) :: n, ldab, ldafb, kl, ku, cmode - integer(ilp), intent(out) :: info + integer(${ik}$), intent(in) :: n, ldab, ldafb, kl, ku, cmode + integer(${ik}$), intent(out) :: info ! Array Arguments - integer(ilp), intent(out) :: iwork(*) - integer(ilp), intent(in) :: ipiv(*) + integer(${ik}$), intent(out) :: iwork(*) + integer(${ik}$), intent(in) :: ipiv(*) real(sp), intent(in) :: ab(ldab,*), afb(ldafb,*), c(*) real(sp), intent(out) :: work(*) ! ===================================================================== ! Local Scalars logical(lk) :: notrans - integer(ilp) :: kase, i, j, kd, ke + integer(${ik}$) :: kase, i, j, kd, ke real(sp) :: ainvnm, tmp ! Local Arrays - integer(ilp) :: isave(3) + integer(${ik}$) :: isave(3_${ik}$) ! Intrinsic Functions intrinsic :: abs,max ! Executable Statements - stdlib_sla_gbrcond = zero - info = 0 + stdlib${ii}$_sla_gbrcond = zero + info = 0_${ik}$ notrans = stdlib_lsame( trans, 'N' ) if ( .not. notrans .and. .not. stdlib_lsame(trans, 'T').and. .not. stdlib_lsame(trans, & 'C') ) then - info = -1 - else if( n<0 ) then - info = -2 - else if( kl<0 .or. kl>n-1 ) then - info = -3 - else if( ku<0 .or. ku>n-1 ) then - info = -4 + info = -1_${ik}$ + else if( n<0_${ik}$ ) then + info = -2_${ik}$ + else if( kl<0_${ik}$ .or. kl>n-1 ) then + info = -3_${ik}$ + else if( ku<0_${ik}$ .or. ku>n-1 ) then + info = -4_${ik}$ else if( ldab0 )then - kx = 1 + if( incx>0_${ik}$ )then + kx = 1_${ik}$ else - kx = 1 - ( lenx - 1 )*incx + kx = 1_${ik}$ - ( lenx - 1_${ik}$ )*incx end if - if( incy>0 )then - ky = 1 + if( incy>0_${ik}$ )then + ky = 1_${ik}$ else - ky = 1 - ( leny - 1 )*incy + ky = 1_${ik}$ - ( leny - 1_${ik}$ )*incy end if ! set safe1 essentially to be the underflow threshold times the ! number of additions in each row. - safe1 = stdlib_slamch( 'SAFE MINIMUM' ) + safe1 = stdlib${ii}$_slamch( 'SAFE MINIMUM' ) safe1 = (n+1)*safe1 ! form y := alpha*abs(a)*abs(x) + beta*abs(y). ! the o(m*n) symb_zero tests could be replaced by o(n) queries to ! the inexact flag. still doesn't help change the iteration order ! to per-column. iy = ky - if ( incx==1 ) then - if( trans==stdlib_ilatrans( 'N' ) )then + if ( incx==1_${ik}$ ) then + if( trans==stdlib${ii}$_ilatrans( 'N' ) )then do i = 1, leny if ( beta == zero ) then symb_zero = .true. @@ -27948,7 +27950,7 @@ module stdlib_linalg_lapack_s end do end if else - if( trans==stdlib_ilatrans( 'N' ) )then + if( trans==stdlib${ii}$_ilatrans( 'N' ) )then do i = 1, leny if ( beta == zero ) then symb_zero = .true. @@ -27997,15 +27999,15 @@ module stdlib_linalg_lapack_s end if end if return - end subroutine stdlib_sla_geamv + end subroutine stdlib${ii}$_sla_geamv - real(sp) function stdlib_sla_gercond( trans, n, a, lda, af, ldaf, ipiv,cmode, c, info, work, & + real(sp) function stdlib${ii}$_sla_gercond( trans, n, a, lda, af, ldaf, ipiv,cmode, c, info, work, & !! SLA_GERCOND estimates the Skeel condition number of op(A) * op2(C) !! where op2 is determined by CMODE as follows - !! CMODE = 1 op2(C) = C - !! CMODE = 0 op2(C) = I - !! CMODE = -1 op2(C) = inv(C) + !! CMODE = 1_${ik}$ op2(C) = C + !! CMODE = 0_${ik}$ op2(C) = I + !! CMODE = -1_${ik}$ op2(C) = inv(C) !! The Skeel condition number cond(A) = norminf( |inv(A)||A| ) !! is computed by computing scaling factors R such that !! diag(R)*A*op2(C) is row equilibrated and computing the standard @@ -28016,54 +28018,54 @@ module stdlib_linalg_lapack_s ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: trans - integer(ilp), intent(in) :: n, lda, ldaf, cmode - integer(ilp), intent(out) :: info + integer(${ik}$), intent(in) :: n, lda, ldaf, cmode + integer(${ik}$), intent(out) :: info ! Array Arguments - integer(ilp), intent(in) :: ipiv(*) - integer(ilp), intent(out) :: iwork(*) + integer(${ik}$), intent(in) :: ipiv(*) + integer(${ik}$), intent(out) :: iwork(*) real(sp), intent(in) :: a(lda,*), af(ldaf,*), c(*) real(sp), intent(out) :: work(*) ! ===================================================================== ! Local Scalars logical(lk) :: notrans - integer(ilp) :: kase, i, j + integer(${ik}$) :: kase, i, j real(sp) :: ainvnm, tmp ! Local Arrays - integer(ilp) :: isave(3) + integer(${ik}$) :: isave(3_${ik}$) ! Intrinsic Functions intrinsic :: abs,max ! Executable Statements - stdlib_sla_gercond = zero - info = 0 + stdlib${ii}$_sla_gercond = zero + info = 0_${ik}$ notrans = stdlib_lsame( trans, 'N' ) if ( .not. notrans .and. .not. stdlib_lsame(trans, 'T').and. .not. stdlib_lsame(trans, & 'C') ) then - info = -1 - else if( n<0 ) then - info = -2 - else if( lda0 )then - kx = 1 + if( incx>0_${ik}$ )then + kx = 1_${ik}$ else - kx = 1 - ( n - 1 )*incx + kx = 1_${ik}$ - ( n - 1_${ik}$ )*incx end if - if( incy>0 )then - ky = 1 + if( incy>0_${ik}$ )then + ky = 1_${ik}$ else - ky = 1 - ( n - 1 )*incy + ky = 1_${ik}$ - ( n - 1_${ik}$ )*incy end if ! set safe1 essentially to be the underflow threshold times the ! number of additions in each row. - safe1 = stdlib_slamch( 'SAFE MINIMUM' ) + safe1 = stdlib${ii}$_slamch( 'SAFE MINIMUM' ) safe1 = (n+1)*safe1 ! form y := alpha*abs(a)*abs(x) + beta*abs(y). - ! the o(n^2) symb_zero tests could be replaced by o(n) queries to + ! the o(n^2_${ik}$) symb_zero tests could be replaced by o(n) queries to ! the inexact flag. still doesn't help change the iteration order ! to per-column. iy = ky - if ( incx==1 ) then - if ( uplo == stdlib_ilauplo( 'U' ) ) then + if ( incx==1_${ik}$ ) then + if ( uplo == stdlib${ii}$_ilauplo( 'U' ) ) then do i = 1, n if ( beta == zero ) then symb_zero = .true. @@ -28475,7 +28477,7 @@ module stdlib_linalg_lapack_s end do end if else - if ( uplo == stdlib_ilauplo( 'U' ) ) then + if ( uplo == stdlib${ii}$_ilauplo( 'U' ) ) then do i = 1, n if ( beta == zero ) then symb_zero = .true. @@ -28536,15 +28538,15 @@ module stdlib_linalg_lapack_s end if end if return - end subroutine stdlib_sla_syamv + end subroutine stdlib${ii}$_sla_syamv - real(sp) function stdlib_sla_syrcond( uplo, n, a, lda, af, ldaf, ipiv, cmode,c, info, work, & + real(sp) function stdlib${ii}$_sla_syrcond( uplo, n, a, lda, af, ldaf, ipiv, cmode,c, info, work, & !! SLA_SYRCOND estimates the Skeel condition number of op(A) * op2(C) !! where op2 is determined by CMODE as follows - !! CMODE = 1 op2(C) = C - !! CMODE = 0 op2(C) = I - !! CMODE = -1 op2(C) = inv(C) + !! CMODE = 1_${ik}$ op2(C) = C + !! CMODE = 0_${ik}$ op2(C) = I + !! CMODE = -1_${ik}$ op2(C) = inv(C) !! The Skeel condition number cond(A) = norminf( |inv(A)||A| ) !! is computed by computing scaling factors R such that !! diag(R)*A*op2(C) is row equilibrated and computing the standard @@ -28555,56 +28557,56 @@ module stdlib_linalg_lapack_s ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: uplo - integer(ilp), intent(in) :: n, lda, ldaf, cmode - integer(ilp), intent(out) :: info + integer(${ik}$), intent(in) :: n, lda, ldaf, cmode + integer(${ik}$), intent(out) :: info ! Array Arguments - integer(ilp), intent(out) :: iwork(*) - integer(ilp), intent(in) :: ipiv(*) + integer(${ik}$), intent(out) :: iwork(*) + integer(${ik}$), intent(in) :: ipiv(*) real(sp), intent(in) :: a(lda,*), af(ldaf,*), c(*) real(sp), intent(out) :: work(*) ! ===================================================================== ! Local Scalars character :: normin - integer(ilp) :: kase, i, j + integer(${ik}$) :: kase, i, j real(sp) :: ainvnm, smlnum, tmp logical(lk) :: up ! Local Arrays - integer(ilp) :: isave(3) + integer(${ik}$) :: isave(3_${ik}$) ! Intrinsic Functions intrinsic :: abs,max ! Executable Statements - stdlib_sla_syrcond = zero - info = 0 - if( n<0 ) then - info = -2 - else if( lda0 ) - if ( ipiv( k )>0 ) then - ! 1x1 pivot + if ( ipiv( k )>0_${ik}$ ) then + ! 1_${ik}$x1 pivot kp = ipiv( k ) if ( kp /= k ) then tmp = work( n+k ) @@ -28782,9 +28784,9 @@ module stdlib_linalg_lapack_s do i = 1, k work( k ) = max( abs( af( i, k ) ), work( k ) ) end do - k = k - 1 + k = k - 1_${ik}$ else - ! 2x2 pivot + ! 2_${ik}$x2 pivot kp = -ipiv( k ) tmp = work( n+k-1 ) work( n+k-1 ) = work( n+kp ) @@ -28794,32 +28796,32 @@ module stdlib_linalg_lapack_s work( k-1 ) = max( abs( af( i, k-1 ) ), work( k-1 ) ) end do work( k ) = max( abs( af( k, k ) ), work( k ) ) - k = k - 2 + k = k - 2_${ik}$ end if end do k = ncols do while ( k <= n ) - if ( ipiv( k )>0 ) then + if ( ipiv( k )>0_${ik}$ ) then kp = ipiv( k ) if ( kp /= k ) then tmp = work( n+k ) work( n+k ) = work( n+kp ) work( n+kp ) = tmp end if - k = k + 1 + k = k + 1_${ik}$ else kp = -ipiv( k ) tmp = work( n+k ) work( n+k ) = work( n+kp ) work( n+kp ) = tmp - k = k + 2 + k = k + 2_${ik}$ end if end do else - k = 1 + k = 1_${ik}$ do while ( k <= ncols ) - if ( ipiv( k )>0 ) then - ! 1x1 pivot + if ( ipiv( k )>0_${ik}$ ) then + ! 1_${ik}$x1 pivot kp = ipiv( k ) if ( kp /= k ) then tmp = work( n+k ) @@ -28829,9 +28831,9 @@ module stdlib_linalg_lapack_s do i = k, n work( k ) = max( abs( af( i, k ) ), work( k ) ) end do - k = k + 1 + k = k + 1_${ik}$ else - ! 2x2 pivot + ! 2_${ik}$x2 pivot kp = -ipiv( k ) tmp = work( n+k+1 ) work( n+k+1 ) = work( n+kp ) @@ -28841,25 +28843,25 @@ module stdlib_linalg_lapack_s work( k+1 ) = max( abs( af(i, k+1 ) ), work( k+1 ) ) end do work( k ) = max( abs( af( k, k ) ), work( k ) ) - k = k + 2 + k = k + 2_${ik}$ end if end do k = ncols do while ( k >= 1 ) - if ( ipiv( k )>0 ) then + if ( ipiv( k )>0_${ik}$ ) then kp = ipiv( k ) if ( kp /= k ) then tmp = work( n+k ) work( n+k ) = work( n+kp ) work( n+kp ) = tmp end if - k = k - 1 + k = k - 1_${ik}$ else kp = -ipiv( k ) tmp = work( n+k ) work( n+k ) = work( n+kp ) work( n+kp ) = tmp - k = k - 2 + k = k - 2_${ik}$ endif end do end if @@ -28886,11 +28888,11 @@ module stdlib_linalg_lapack_s end if end do end if - stdlib_sla_syrpvgrw = rpvgrw - end function stdlib_sla_syrpvgrw + stdlib${ii}$_sla_syrpvgrw = rpvgrw + end function stdlib${ii}$_sla_syrpvgrw - pure subroutine stdlib_sladiv1( a, b, c, d, p, q ) + pure subroutine stdlib${ii}$_sladiv1( 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..-- @@ -28905,22 +28907,22 @@ module stdlib_linalg_lapack_s ! Executable Statements r = d / c t = one / (c + d * r) - p = stdlib_sladiv2(a, b, c, d, r, t) + p = stdlib${ii}$_sladiv2(a, b, c, d, r, t) a = -a - q = stdlib_sladiv2(b, a, c, d, r, t) + q = stdlib${ii}$_sladiv2(b, a, c, d, r, t) return - end subroutine stdlib_sladiv1 + end subroutine stdlib${ii}$_sladiv1 - pure subroutine stdlib_slaed6( kniter, orgati, rho, d, z, finit, tau, info ) + pure subroutine stdlib${ii}$_slaed6( kniter, orgati, rho, d, z, finit, tau, info ) !! SLAED6 computes the positive or negative root (closest to the origin) !! of - !! z(1) z(2) z(3) + !! z(1_${ik}$) z(2_${ik}$) z(3_${ik}$) !! f(x) = rho + --------- + ---------- + --------- - !! d(1)-x d(2)-x d(3)-x + !! d(1_${ik}$)-x d(2_${ik}$)-x d(3_${ik}$)-x !! It is assumed that - !! if ORGATI = .true. the root is between d(2) and d(3); - !! otherwise it is between d(1) and d(2) + !! if ORGATI = .true. the root is between d(2_${ik}$) and d(3_${ik}$); + !! otherwise it is between d(1_${ik}$) and d(2_${ik}$) !! This routine will be called by SLAED4 when necessary. In most cases, !! the root sought is the smallest in magnitude, though it might not be !! in some extremely rare situations. @@ -28929,53 +28931,53 @@ module stdlib_linalg_lapack_s ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments logical(lk), intent(in) :: orgati - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: kniter + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: kniter real(sp), intent(in) :: finit, rho real(sp), intent(out) :: tau ! Array Arguments - real(sp), intent(in) :: d(3), z(3) + real(sp), intent(in) :: d(3_${ik}$), z(3_${ik}$) ! ===================================================================== ! Parameters - integer(ilp), parameter :: maxit = 40 + integer(${ik}$), parameter :: maxit = 40_${ik}$ ! Local Arrays - real(sp) :: dscale(3), zscale(3) + real(sp) :: dscale(3_${ik}$), zscale(3_${ik}$) ! Local Scalars logical(lk) :: scale - integer(ilp) :: i, iter, niter + integer(${ik}$) :: i, iter, niter real(sp) :: a, b, base, c, ddf, df, eps, erretm, eta, f, fc, sclfac, sclinv, small1, & small2, sminv1, sminv2, temp, temp1, temp2, temp3, temp4, lbd, ubd ! Intrinsic Functions intrinsic :: abs,int,log,max,min,sqrt ! Executable Statements - info = 0 + info = 0_${ik}$ if( orgati ) then - lbd = d(2) - ubd = d(3) + lbd = d(2_${ik}$) + ubd = d(3_${ik}$) else - lbd = d(1) - ubd = d(2) + lbd = d(1_${ik}$) + ubd = d(2_${ik}$) end if if( finit < zero )then lbd = zero else ubd = zero end if - niter = 1 + niter = 1_${ik}$ tau = zero - if( kniter==2 ) then + if( kniter==2_${ik}$ ) then if( orgati ) then - temp = ( d( 3 )-d( 2 ) ) / two - c = rho + z( 1 ) / ( ( d( 1 )-d( 2 ) )-temp ) - a = c*( d( 2 )+d( 3 ) ) + z( 2 ) + z( 3 ) - b = c*d( 2 )*d( 3 ) + z( 2 )*d( 3 ) + z( 3 )*d( 2 ) + temp = ( d( 3_${ik}$ )-d( 2_${ik}$ ) ) / two + c = rho + z( 1_${ik}$ ) / ( ( d( 1_${ik}$ )-d( 2_${ik}$ ) )-temp ) + a = c*( d( 2_${ik}$ )+d( 3_${ik}$ ) ) + z( 2_${ik}$ ) + z( 3_${ik}$ ) + b = c*d( 2_${ik}$ )*d( 3_${ik}$ ) + z( 2_${ik}$ )*d( 3_${ik}$ ) + z( 3_${ik}$ )*d( 2_${ik}$ ) else - temp = ( d( 1 )-d( 2 ) ) / two - c = rho + z( 3 ) / ( ( d( 3 )-d( 2 ) )-temp ) - a = c*( d( 1 )+d( 2 ) ) + z( 1 ) + z( 2 ) - b = c*d( 1 )*d( 2 ) + z( 1 )*d( 2 ) + z( 2 )*d( 1 ) + temp = ( d( 1_${ik}$ )-d( 2_${ik}$ ) ) / two + c = rho + z( 3_${ik}$ ) / ( ( d( 3_${ik}$ )-d( 2_${ik}$ ) )-temp ) + a = c*( d( 1_${ik}$ )+d( 2_${ik}$ ) ) + z( 1_${ik}$ ) + z( 2_${ik}$ ) + b = c*d( 1_${ik}$ )*d( 2_${ik}$ ) + z( 1_${ik}$ )*d( 2_${ik}$ ) + z( 2_${ik}$ )*d( 1_${ik}$ ) end if temp = max( abs( a ), abs( b ), abs( c ) ) a = a / temp @@ -28989,11 +28991,11 @@ module stdlib_linalg_lapack_s tau = two*b / ( a+sqrt( abs( a*a-four*b*c ) ) ) end if if( tau < lbd .or. tau > ubd )tau = ( lbd+ubd )/two - if( d(1)==tau .or. d(2)==tau .or. d(3)==tau ) then + if( d(1_${ik}$)==tau .or. d(2_${ik}$)==tau .or. d(3_${ik}$)==tau ) then tau = zero else - temp = finit + tau*z(1)/( d(1)*( d( 1 )-tau ) ) +tau*z(2)/( d(2)*( d( 2 )-tau ) )& - +tau*z(3)/( d(3)*( d( 3 )-tau ) ) + temp = finit + tau*z(1_${ik}$)/( d(1_${ik}$)*( d( 1_${ik}$ )-tau ) ) +tau*z(2_${ik}$)/( d(2_${ik}$)*( d( 2_${ik}$ )-tau ) )& + +tau*z(3_${ik}$)/( d(3_${ik}$)*( d( 3_${ik}$ )-tau ) ) if( temp <= zero )then lbd = tau else @@ -29006,33 +29008,33 @@ module stdlib_linalg_lapack_s ! modified by sven: parameters small1, sminv1, small2, ! sminv2, eps are not saved anymore between one call to the ! others but recomputed at each call - eps = stdlib_slamch( 'EPSILON' ) - base = stdlib_slamch( 'BASE' ) - small1 = base**( int( log( stdlib_slamch( 'SAFMIN' ) ) / log( base ) /three,KIND=ilp) ) + eps = stdlib${ii}$_slamch( 'EPSILON' ) + base = stdlib${ii}$_slamch( 'BASE' ) + small1 = base**( int( log( stdlib${ii}$_slamch( 'SAFMIN' ) ) / log( base ) /three,KIND=${ik}$) ) sminv1 = one / small1 small2 = small1*small1 sminv2 = sminv1*sminv1 ! determine if scaling of inputs necessary to avoid overflow - ! when computing 1/temp**3 + ! when computing 1_${ik}$/temp**3_${ik}$ if( orgati ) then - temp = min( abs( d( 2 )-tau ), abs( d( 3 )-tau ) ) + temp = min( abs( d( 2_${ik}$ )-tau ), abs( d( 3_${ik}$ )-tau ) ) else - temp = min( abs( d( 1 )-tau ), abs( d( 2 )-tau ) ) + temp = min( abs( d( 1_${ik}$ )-tau ), abs( d( 2_${ik}$ )-tau ) ) end if scale = .false. if( temp<=small1 ) then scale = .true. if( temp<=small2 ) then - ! scale up by power of radix nearest 1/safmin**(2/3) + ! scale up by power of radix nearest 1_${ik}$/safmin**(2_${ik}$/3_${ik}$) sclfac = sminv2 sclinv = small2 else - ! scale up by power of radix nearest 1/safmin**(1/3) + ! scale up by power of radix nearest 1_${ik}$/safmin**(1_${ik}$/3_${ik}$) sclfac = sminv1 sclinv = small1 end if - ! scaling up safe because d, z, tau scaled elsewhere to be o(1) + ! scaling up safe because d, z, tau scaled elsewhere to be o(1_${ik}$) do i = 1, 3 dscale( i ) = d( i )*sclfac zscale( i ) = z( i )*sclfac @@ -29069,18 +29071,18 @@ module stdlib_linalg_lapack_s ! iteration begins -- use gragg-thornton-warner cubic convergent ! scheme ! it is not hard to see that - ! 1) iterations will go up monotonically - ! if finit < 0; - ! 2) iterations will go down monotonically + ! 1_${ik}$) iterations will go up monotonically + ! if finit < 0_${ik}$; + ! 2_${ik}$) iterations will go down monotonically ! if finit > 0. - iter = niter + 1 + iter = niter + 1_${ik}$ loop_50: do niter = iter, maxit if( orgati ) then - temp1 = dscale( 2 ) - tau - temp2 = dscale( 3 ) - tau + temp1 = dscale( 2_${ik}$ ) - tau + temp2 = dscale( 3_${ik}$ ) - tau else - temp1 = dscale( 1 ) - tau - temp2 = dscale( 2 ) - tau + temp1 = dscale( 1_${ik}$ ) - tau + temp2 = dscale( 2_${ik}$ ) - tau end if a = ( temp1+temp2 )*f - temp1*temp2*df b = temp1*temp2*f @@ -29122,36 +29124,36 @@ module stdlib_linalg_lapack_s end do f = finit + tau*fc erretm = eight*( abs( finit )+abs( tau )*erretm ) +abs( tau )*df - if( ( abs( f )<=four*eps*erretm ) .or.( (ubd-lbd)<=four*eps*abs(tau) ) )go to & - 60 + if( ( abs( f )<=four*eps*erretm ) .or.( (ubd-lbd)<=four*eps*abs(tau) ) )go to 60 + if( f <= zero )then lbd = tau else ubd = tau end if end do loop_50 - info = 1 + info = 1_${ik}$ 60 continue ! undo scaling if( scale )tau = tau*sclinv return - end subroutine stdlib_slaed6 + end subroutine stdlib${ii}$_slaed6 - pure subroutine stdlib_slags2( upper, a1, a2, a3, b1, b2, b3, csu, snu, csv,snv, csq, snq ) - !! SLAGS2 computes 2-by-2 orthogonal matrices U, V and Q, such + pure subroutine stdlib${ii}$_slags2( upper, a1, a2, a3, b1, b2, b3, csu, snu, csv,snv, csq, snq ) + !! SLAGS2 computes 2_${ik}$-by-2 orthogonal matrices U, V and Q, such !! that if ( UPPER ) then - !! U**T *A*Q = U**T *( A1 A2 )*Q = ( x 0 ) - !! ( 0 A3 ) ( x x ) + !! U**T *A*Q = U**T *( A1 A2 )*Q = ( x 0_${ik}$ ) + !! ( 0_${ik}$ A3 ) ( x x ) !! and - !! V**T*B*Q = V**T *( B1 B2 )*Q = ( x 0 ) - !! ( 0 B3 ) ( x x ) + !! V**T*B*Q = V**T *( B1 B2 )*Q = ( x 0_${ik}$ ) + !! ( 0_${ik}$ B3 ) ( x x ) !! or if ( .NOT.UPPER ) then - !! U**T *A*Q = U**T *( A1 0 )*Q = ( x x ) - !! ( A2 A3 ) ( 0 x ) + !! U**T *A*Q = U**T *( A1 0_${ik}$ )*Q = ( x x ) + !! ( A2 A3 ) ( 0_${ik}$ x ) !! and - !! V**T*B*Q = V**T*( B1 0 )*Q = ( x x ) - !! ( B2 B3 ) ( 0 x ) + !! V**T*B*Q = V**T*( B1 0_${ik}$ )*Q = ( x x ) + !! ( B2 B3 ) ( 0_${ik}$ x ) !! The rows of the transformed A and B are parallel, where !! U = ( CSU SNU ), V = ( CSV SNV ), Q = ( CSQ SNQ ) !! ( -SNU CSU ) ( -SNV CSV ) ( -SNQ CSQ ) @@ -29176,57 +29178,57 @@ module stdlib_linalg_lapack_s if( upper ) then ! input matrices a and b are upper triangular matrices ! form matrix c = a*adj(b) = ( a b ) - ! ( 0 d ) + ! ( 0_${ik}$ d ) a = a1*b3 d = a3*b1 b = a2*b1 - a1*b2 - ! 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_slasv2( a, b, d, s1, s2, snr, csr, snl, csl ) + ! the svd of real 2_${ik}$-by-2 triangular c + ! ( csl -snl )*( a b )*( csr snr ) = ( r 0_${ik}$ ) + ! ( snl csl ) ( 0_${ik}$ d ) ( -snr csr ) ( 0_${ik}$ t ) + call stdlib${ii}$_slasv2( 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|. + ! compute the (1_${ik}$,1_${ik}$) and (1_${ik}$,2_${ik}$) elements of u**t *a and v**t *b, + ! and (1_${ik}$,2_${ik}$) element of |u|**t *|a| and |v|**t *|b|. ua11r = csl*a1 ua12 = csl*a2 + snl*a3 vb11r = csr*b1 vb12 = csr*b2 + snr*b3 aua12 = abs( csl )*abs( a2 ) + abs( snl )*abs( a3 ) avb12 = abs( csr )*abs( b2 ) + abs( snr )*abs( b3 ) - ! zero (1,2) elements of u**t *a and v**t *b + ! zero (1_${ik}$,2_${ik}$) elements of u**t *a and v**t *b if( ( abs( ua11r )+abs( ua12 ) )/=zero ) then if( aua12 / ( abs( ua11r )+abs( ua12 ) )<=avb12 /( abs( vb11r )+abs( vb12 ) ) & ) then - call stdlib_slartg( -ua11r, ua12, csq, snq, r ) + call stdlib${ii}$_slartg( -ua11r, ua12, csq, snq, r ) else - call stdlib_slartg( -vb11r, vb12, csq, snq, r ) + call stdlib${ii}$_slartg( -vb11r, vb12, csq, snq, r ) end if else - call stdlib_slartg( -vb11r, vb12, csq, snq, r ) + call stdlib${ii}$_slartg( -vb11r, vb12, csq, snq, r ) end if csu = csl snu = -snl csv = csr snv = -snr else - ! compute the (2,1) and (2,2) elements of u**t *a and v**t *b, - ! and (2,2) element of |u|**t *|a| and |v|**t *|b|. + ! compute the (2_${ik}$,1_${ik}$) and (2_${ik}$,2_${ik}$) elements of u**t *a and v**t *b, + ! and (2_${ik}$,2_${ik}$) element of |u|**t *|a| and |v|**t *|b|. ua21 = -snl*a1 ua22 = -snl*a2 + csl*a3 vb21 = -snr*b1 vb22 = -snr*b2 + csr*b3 aua22 = abs( snl )*abs( a2 ) + abs( csl )*abs( a3 ) avb22 = abs( snr )*abs( b2 ) + abs( csr )*abs( b3 ) - ! zero (2,2) elements of u**t*a and v**t*b, and then swap. + ! zero (2_${ik}$,2_${ik}$) elements of u**t*a and v**t*b, and then swap. if( ( abs( ua21 )+abs( ua22 ) )/=zero ) then if( aua22 / ( abs( ua21 )+abs( ua22 ) )<=avb22 /( abs( vb21 )+abs( vb22 ) ) ) & then - call stdlib_slartg( -ua21, ua22, csq, snq, r ) + call stdlib${ii}$_slartg( -ua21, ua22, csq, snq, r ) else - call stdlib_slartg( -vb21, vb22, csq, snq, r ) + call stdlib${ii}$_slartg( -vb21, vb22, csq, snq, r ) end if else - call stdlib_slartg( -vb21, vb22, csq, snq, r ) + call stdlib${ii}$_slartg( -vb21, vb22, csq, snq, r ) end if csu = snl snu = csl @@ -29235,58 +29237,58 @@ module stdlib_linalg_lapack_s end if else ! input matrices a and b are lower triangular matrices - ! form matrix c = a*adj(b) = ( a 0 ) + ! form matrix c = a*adj(b) = ( a 0_${ik}$ ) ! ( c d ) a = a1*b3 d = a3*b1 c = a2*b3 - a3*b2 - ! 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_slasv2( a, c, d, s1, s2, snr, csr, snl, csl ) + ! the svd of real 2_${ik}$-by-2 triangular c + ! ( csl -snl )*( a 0_${ik}$ )*( csr snr ) = ( r 0_${ik}$ ) + ! ( snl csl ) ( c d ) ( -snr csr ) ( 0_${ik}$ t ) + call stdlib${ii}$_slasv2( 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|. + ! compute the (2_${ik}$,1_${ik}$) and (2_${ik}$,2_${ik}$) elements of u**t *a and v**t *b, + ! and (2_${ik}$,1_${ik}$) element of |u|**t *|a| and |v|**t *|b|. ua21 = -snr*a1 + csr*a2 ua22r = csr*a3 vb21 = -snl*b1 + csl*b2 vb22r = csl*b3 aua21 = abs( snr )*abs( a1 ) + abs( csr )*abs( a2 ) avb21 = abs( snl )*abs( b1 ) + abs( csl )*abs( b2 ) - ! zero (2,1) elements of u**t *a and v**t *b. + ! zero (2_${ik}$,1_${ik}$) elements of u**t *a and v**t *b. if( ( abs( ua21 )+abs( ua22r ) )/=zero ) then if( aua21 / ( abs( ua21 )+abs( ua22r ) )<=avb21 /( abs( vb21 )+abs( vb22r ) ) & ) then - call stdlib_slartg( ua22r, ua21, csq, snq, r ) + call stdlib${ii}$_slartg( ua22r, ua21, csq, snq, r ) else - call stdlib_slartg( vb22r, vb21, csq, snq, r ) + call stdlib${ii}$_slartg( vb22r, vb21, csq, snq, r ) end if else - call stdlib_slartg( vb22r, vb21, csq, snq, r ) + call stdlib${ii}$_slartg( vb22r, vb21, csq, snq, r ) end if csu = csr snu = -snr csv = csl snv = -snl else - ! compute the (1,1) and (1,2) elements of u**t *a and v**t *b, - ! and (1,1) element of |u|**t *|a| and |v|**t *|b|. + ! compute the (1_${ik}$,1_${ik}$) and (1_${ik}$,2_${ik}$) elements of u**t *a and v**t *b, + ! and (1_${ik}$,1_${ik}$) element of |u|**t *|a| and |v|**t *|b|. ua11 = csr*a1 + snr*a2 ua12 = snr*a3 vb11 = csl*b1 + snl*b2 vb12 = snl*b3 aua11 = abs( csr )*abs( a1 ) + abs( snr )*abs( a2 ) avb11 = abs( csl )*abs( b1 ) + abs( snl )*abs( b2 ) - ! zero (1,1) elements of u**t*a and v**t*b, and then swap. + ! zero (1_${ik}$,1_${ik}$) elements of u**t*a and v**t*b, and then swap. if( ( abs( ua11 )+abs( ua12 ) )/=zero ) then if( aua11 / ( abs( ua11 )+abs( ua12 ) )<=avb11 /( abs( vb11 )+abs( vb12 ) ) ) & then - call stdlib_slartg( ua12, ua11, csq, snq, r ) + call stdlib${ii}$_slartg( ua12, ua11, csq, snq, r ) else - call stdlib_slartg( vb12, vb11, csq, snq, r ) + call stdlib${ii}$_slartg( vb12, vb11, csq, snq, r ) end if else - call stdlib_slartg( vb12, vb11, csq, snq, r ) + call stdlib${ii}$_slartg( vb12, vb11, csq, snq, r ) end if csu = snr snu = csr @@ -29295,10 +29297,10 @@ module stdlib_linalg_lapack_s end if end if return - end subroutine stdlib_slags2 + end subroutine stdlib${ii}$_slags2 - pure subroutine stdlib_slagtf( n, a, lambda, b, c, tol, d, in, info ) + pure subroutine stdlib${ii}$_slagtf( n, a, lambda, b, c, tol, d, in, info ) !! SLAGTF 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, @@ -29315,37 +29317,37 @@ module stdlib_linalg_lapack_s ! -- 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) :: n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: n real(sp), intent(in) :: lambda, tol ! Array Arguments - integer(ilp), intent(out) :: in(*) + integer(${ik}$), intent(out) :: in(*) real(sp), intent(inout) :: a(*), b(*), c(*) real(sp), intent(out) :: d(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: k + integer(${ik}$) :: k real(sp) :: eps, mult, piv1, piv2, scale1, scale2, temp, tl ! Intrinsic Functions intrinsic :: abs,max ! Executable Statements - info = 0 - if( n<0 ) then - info = -1 - call stdlib_xerbla( 'SLAGTF', -info ) + info = 0_${ik}$ + if( n<0_${ik}$ ) then + info = -1_${ik}$ + call stdlib${ii}$_xerbla( 'SLAGTF', -info ) return end if if( n==0 )return - a( 1 ) = a( 1 ) - lambda - in( n ) = 0 - if( n==1 ) then - if( a( 1 )==zero )in( 1 ) = 1 + a( 1_${ik}$ ) = a( 1_${ik}$ ) - lambda + in( n ) = 0_${ik}$ + if( n==1_${ik}$ ) then + if( a( 1_${ik}$ )==zero )in( 1_${ik}$ ) = 1_${ik}$ return end if - eps = stdlib_slamch( 'EPSILON' ) + eps = stdlib${ii}$_slamch( 'EPSILON' ) tl = max( tol, eps ) - scale1 = abs( a( 1 ) ) + abs( b( 1 ) ) + scale1 = abs( a( 1_${ik}$ ) ) + abs( b( 1_${ik}$ ) ) loop_10: do k = 1, n - 1 a( k+1 ) = a( k+1 ) - lambda scale2 = abs( c( k ) ) + abs( a( k+1 ) ) @@ -29356,20 +29358,20 @@ module stdlib_linalg_lapack_s piv1 = abs( a( k ) ) / scale1 end if if( c( k )==zero ) then - in( k ) = 0 + in( k ) = 0_${ik}$ piv2 = zero scale1 = scale2 if( k<( n-1 ) )d( k ) = zero else piv2 = abs( c( k ) ) / scale2 if( piv2<=piv1 ) then - in( k ) = 0 + in( k ) = 0_${ik}$ scale1 = scale2 c( k ) = c( k ) / a( k ) a( k+1 ) = a( k+1 ) - c( k )*b( k ) if( k<( n-1 ) )d( k ) = zero else - in( k ) = 1 + in( k ) = 1_${ik}$ mult = a( k ) / c( k ) a( k ) = c( k ) temp = a( k+1 ) @@ -29382,14 +29384,14 @@ module stdlib_linalg_lapack_s c( k ) = mult end if end if - if( ( max( piv1, piv2 )<=tl ) .and. ( in( n )==0 ) )in( n ) = k + if( ( max( piv1, piv2 )<=tl ) .and. ( in( n )==0_${ik}$ ) )in( n ) = k end do loop_10 - if( ( abs( a( n ) )<=scale1*tl ) .and. ( in( n )==0 ) )in( n ) = n + if( ( abs( a( n ) )<=scale1*tl ) .and. ( in( n )==0_${ik}$ ) )in( n ) = n return - end subroutine stdlib_slagtf + end subroutine stdlib${ii}$_slagtf - pure subroutine stdlib_slagts( job, n, a, b, c, d, in, y, tol, info ) + pure subroutine stdlib${ii}$_slagts( job, n, a, b, c, d, in, y, tol, info ) !! SLAGTS 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 @@ -29403,39 +29405,39 @@ module stdlib_linalg_lapack_s ! -- 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) :: job, n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: job, n real(sp), intent(inout) :: tol ! Array Arguments - integer(ilp), intent(in) :: in(*) + integer(${ik}$), intent(in) :: in(*) real(sp), intent(in) :: a(*), b(*), c(*), d(*) real(sp), intent(inout) :: y(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: k + integer(${ik}$) :: k real(sp) :: absak, ak, bignum, eps, pert, sfmin, temp ! Intrinsic Functions intrinsic :: abs,max,sign ! Executable Statements - info = 0 - if( ( abs( job )>2 ) .or. ( job==0 ) ) then - info = -1 - else if( n<0 ) then - info = -2 + info = 0_${ik}$ + if( ( abs( job )>2_${ik}$ ) .or. ( job==0_${ik}$ ) ) then + info = -1_${ik}$ + else if( n<0_${ik}$ ) then + info = -2_${ik}$ end if - if( info/=0 ) then - call stdlib_xerbla( 'SLAGTS', -info ) + if( info/=0_${ik}$ ) then + call stdlib${ii}$_xerbla( 'SLAGTS', -info ) return end if if( n==0 )return - eps = stdlib_slamch( 'EPSILON' ) - sfmin = stdlib_slamch( 'SAFE MINIMUM' ) + eps = stdlib${ii}$_slamch( 'EPSILON' ) + sfmin = stdlib${ii}$_slamch( 'SAFE MINIMUM' ) bignum = one / sfmin - if( job<0 ) then + if( job<0_${ik}$ ) then if( tol<=zero ) then - tol = abs( a( 1 ) ) - if( n>1 )tol = max( tol, abs( a( 2 ) ), abs( b( 1 ) ) ) + tol = abs( a( 1_${ik}$ ) ) + if( n>1_${ik}$ )tol = max( tol, abs( a( 2_${ik}$ ) ), abs( b( 1_${ik}$ ) ) ) do k = 3, n tol = max( tol, abs( a( k ) ), abs( b( k-1 ) ),abs( d( k-2 ) ) ) end do @@ -29443,9 +29445,9 @@ module stdlib_linalg_lapack_s if( tol==zero )tol = eps end if end if - if( abs( job )==1 ) then + if( abs( job )==1_${ik}$ ) then do k = 2, n - if( in( k-1 )==0 ) then + if( in( k-1 )==0_${ik}$ ) then y( k ) = y( k ) - c( k-1 )*y( k-1 ) else temp = y( k-1 ) @@ -29453,7 +29455,7 @@ module stdlib_linalg_lapack_s y( k ) = temp - c( k-1 )*y( k ) end if end do - if( job==1 ) then + if( job==1_${ik}$ ) then loop_30: do k = n, 1, -1 if( k<=n-2 ) then temp = y( k ) - b( k )*y( k+1 ) - d( k )*y( k+2 ) @@ -29497,7 +29499,7 @@ module stdlib_linalg_lapack_s if( absakabsak )then ak = ak + pert - pert = 2*pert + pert = 2_${ik}$*pert go to 40 else temp = temp*bignum @@ -29505,7 +29507,7 @@ module stdlib_linalg_lapack_s end if else if( abs( temp )>absak*bignum ) then ak = ak + pert - pert = 2*pert + pert = 2_${ik}$*pert go to 40 end if end if @@ -29513,12 +29515,12 @@ module stdlib_linalg_lapack_s end do loop_50 end if else - ! come to here if job = 2 or -2 - if( job==2 ) then + ! come to here if job = 2_${ik}$ or -2_${ik}$ + if( job==2_${ik}$ ) then loop_60: do k = 1, n - if( k>=3 ) then + if( k>=3_${ik}$ ) then temp = y( k ) - b( k-1 )*y( k-1 ) - d( k-2 )*y( k-2 ) - else if( k==2 ) then + else if( k==2_${ik}$ ) then temp = y( k ) - b( k-1 )*y( k-1 ) else temp = y( k ) @@ -29543,9 +29545,9 @@ module stdlib_linalg_lapack_s end do loop_60 else loop_80: do k = 1, n - if( k>=3 ) then + if( k>=3_${ik}$ ) then temp = y( k ) - b( k-1 )*y( k-1 ) - d( k-2 )*y( k-2 ) - else if( k==2 ) then + else if( k==2_${ik}$ ) then temp = y( k ) - b( k-1 )*y( k-1 ) else temp = y( k ) @@ -29558,7 +29560,7 @@ module stdlib_linalg_lapack_s if( absakabsak )then ak = ak + pert - pert = 2*pert + pert = 2_${ik}$*pert go to 70 else temp = temp*bignum @@ -29566,7 +29568,7 @@ module stdlib_linalg_lapack_s end if else if( abs( temp )>absak*bignum ) then ak = ak + pert - pert = 2*pert + pert = 2_${ik}$*pert go to 70 end if end if @@ -29574,7 +29576,7 @@ module stdlib_linalg_lapack_s end do loop_80 end if do k = n, 2, -1 - if( in( k-1 )==0 ) then + if( in( k-1 )==0_${ik}$ ) then y( k-1 ) = y( k-1 ) - c( k-1 )*y( k ) else temp = y( k-1 ) @@ -29583,13 +29585,13 @@ module stdlib_linalg_lapack_s end if end do end if - end subroutine stdlib_slagts + end subroutine stdlib${ii}$_slagts - pure subroutine stdlib_slaic1( job, j, x, sest, w, gamma, sestpr, s, c ) + pure subroutine stdlib${ii}$_slaic1( job, j, x, sest, w, gamma, sestpr, s, c ) !! SLAIC1 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 + !! Let x, twonorm(x) = 1_${ik}$, be an approximate singular vector of an j-by-j !! lower triangular matrix L, such that !! twonorm(L*x) = sest !! Then SLAIC1 computes sestpr, s, c such that @@ -29597,21 +29599,21 @@ module stdlib_linalg_lapack_s !! [ s*x ] !! xhat = [ c ] !! is an approximate singular vector of - !! [ L 0 ] + !! [ L 0_${ik}$ ] !! Lhat = [ w**T gamma ] !! in the sense that !! twonorm(Lhat*xhat) = sestpr. !! Depending on JOB, an estimate for the largest or smallest singular !! value is computed. - !! Note that [s c]**T and sestpr**2 is an eigenpair of the system - !! diag(sest*sest, 0) + [alpha gamma] * [ alpha ] + !! Note that [s c]**T and sestpr**2_${ik}$ is an eigenpair of the system + !! diag(sest*sest, 0_${ik}$) + [alpha gamma] * [ alpha ] !! [ gamma ] !! where alpha = x**T*w. ! -- 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) :: j, job + integer(${ik}$), intent(in) :: j, job real(sp), intent(out) :: c, s, sestpr real(sp), intent(in) :: gamma, sest ! Array Arguments @@ -29625,12 +29627,12 @@ module stdlib_linalg_lapack_s ! Intrinsic Functions intrinsic :: abs,max,sign,sqrt ! Executable Statements - eps = stdlib_slamch( 'EPSILON' ) - alpha = stdlib_sdot( j, x, 1, w, 1 ) + eps = stdlib${ii}$_slamch( 'EPSILON' ) + alpha = stdlib${ii}$_sdot( j, x, 1_${ik}$, w, 1_${ik}$ ) absalp = abs( alpha ) absgam = abs( gamma ) absest = abs( sest ) - if( job==1 ) then + if( job==1_${ik}$ ) then ! estimating largest singular value ! special cases if( sest==zero ) then @@ -29705,7 +29707,7 @@ module stdlib_linalg_lapack_s sestpr = sqrt( t+one )*absest return end if - else if( job==2 ) then + else if( job==2_${ik}$ ) then ! estimating smallest singular value ! special cases if( sest==zero ) then @@ -29795,10 +29797,10 @@ module stdlib_linalg_lapack_s end if end if return - end subroutine stdlib_slaic1 + end subroutine stdlib${ii}$_slaic1 - pure integer(ilp) function stdlib_slaneg( n, d, lld, sigma, pivmin, r ) + pure integer(${ik}$) function stdlib${ii}$_slaneg( n, d, lld, sigma, pivmin, r ) !! SLANEG 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 @@ -29808,23 +29810,23 @@ module stdlib_linalg_lapack_s !! The current routine does not use the PIVMIN parameter but rather !! requires IEEE-754 propagation of Infinities and NaNs. This !! routine also has no input range restrictions but does require - !! default exception handling such that x/0 produces Inf when x is + !! default exception handling such that x/0_${ik}$ produces Inf when x is !! non-zero, and Inf/Inf produces NaN. For more information, see: !! Marques, Riedy, and Voemel, "Benefits of IEEE-754 Features in !! Modern Symmetric Tridiagonal Eigensolvers," SIAM Journal on - !! Scientific Computing, v28, n5, 2006. DOI 10.1137/050641624 - !! (Tech report version in LAWN 172 with the same title.) + !! Scientific Computing, v28, n5, 2006. DOI 10.1137/050641624_${ik}$ + !! (Tech report version in LAWN 172_${ik}$ with the same title.) ! -- 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) :: n, r + integer(${ik}$), intent(in) :: n, r real(sp), intent(in) :: pivmin, sigma ! Array Arguments real(sp), intent(in) :: d(*), lld(*) ! ===================================================================== ! Parameters - integer(ilp), parameter :: blklen = 128 + integer(${ik}$), parameter :: blklen = 128_${ik}$ ! some architectures propagate infinities and nans very slowly, so ! the code computes counts in blklen chunks. then a nan can @@ -29833,37 +29835,37 @@ module stdlib_linalg_lapack_s ! enough that the overhead is tiny in common cases. ! Local Scalars - integer(ilp) :: bj, j, neg1, neg2, negcnt + integer(${ik}$) :: bj, j, neg1, neg2, negcnt real(sp) :: bsav, dminus, dplus, gamma, p, t, tmp logical(lk) :: sawnan ! Intrinsic Functions intrinsic :: min,max ! Executable Statements - negcnt = 0 + negcnt = 0_${ik}$ ! i) upper part: l d l^t - sigma i = l+ d+ l+^t t = -sigma loop_210: do bj = 1, r-1, blklen - neg1 = 0 + neg1 = 0_${ik}$ bsav = t do j = bj, min(bj+blklen-1, r-1) dplus = d( j ) + t - if( dplus1 ) then - call stdlib_slassq( n-1, dl, 1, scale, sum ) - call stdlib_slassq( n-1, du, 1, scale, sum ) + call stdlib${ii}$_slassq( n, d, 1_${ik}$, scale, sum ) + if( n>1_${ik}$ ) then + call stdlib${ii}$_slassq( n-1, dl, 1_${ik}$, scale, sum ) + call stdlib${ii}$_slassq( n-1, du, 1_${ik}$, scale, sum ) end if anorm = scale*sqrt( sum ) end if - stdlib_slangt = anorm + stdlib${ii}$_slangt = anorm return - end function stdlib_slangt + end function stdlib${ii}$_slangt - real(sp) function stdlib_slanhs( norm, n, a, lda, work ) + real(sp) function stdlib${ii}$_slanhs( norm, n, a, lda, work ) !! SLANHS returns the value of the one norm, or the Frobenius norm, or !! the infinity norm, or the element of largest absolute value of a !! Hessenberg matrix A. @@ -30135,19 +30137,19 @@ module stdlib_linalg_lapack_s ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: norm - integer(ilp), intent(in) :: lda, n + integer(${ik}$), intent(in) :: lda, n ! Array Arguments real(sp), intent(in) :: a(lda,*) real(sp), intent(out) :: work(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, j + integer(${ik}$) :: i, j real(sp) :: scale, sum, value ! Intrinsic Functions intrinsic :: abs,min,sqrt ! Executable Statements - if( n==0 ) then + if( n==0_${ik}$ ) then value = zero else if( stdlib_lsame( norm, 'M' ) ) then ! find max(abs(a(i,j))). @@ -30155,10 +30157,10 @@ module stdlib_linalg_lapack_s do j = 1, n do i = 1, min( n, j+1 ) sum = abs( a( i, j ) ) - if( value < sum .or. stdlib_sisnan( sum ) ) value = sum + if( value < sum .or. stdlib${ii}$_sisnan( sum ) ) value = sum end do end do - else if( ( stdlib_lsame( norm, 'O' ) ) .or. ( norm=='1' ) ) then + else if( ( stdlib_lsame( norm, 'O' ) ) .or. ( norm=='1_${ik}$' ) ) then ! find norm1(a). value = zero do j = 1, n @@ -30166,7 +30168,7 @@ module stdlib_linalg_lapack_s do i = 1, min( n, j+1 ) sum = sum + abs( a( i, j ) ) end do - if( value < sum .or. stdlib_sisnan( sum ) ) value = sum + if( value < sum .or. stdlib${ii}$_sisnan( sum ) ) value = sum end do else if( stdlib_lsame( norm, 'I' ) ) then ! find normi(a). @@ -30181,7 +30183,7 @@ module stdlib_linalg_lapack_s value = zero do i = 1, n sum = work( i ) - if( value < sum .or. stdlib_sisnan( sum ) ) value = sum + if( value < sum .or. stdlib${ii}$_sisnan( sum ) ) value = sum end do else if( ( stdlib_lsame( norm, 'F' ) ) .or. ( stdlib_lsame( norm, 'E' ) ) ) & then @@ -30189,16 +30191,16 @@ module stdlib_linalg_lapack_s scale = zero sum = one do j = 1, n - call stdlib_slassq( min( n, j+1 ), a( 1, j ), 1, scale, sum ) + call stdlib${ii}$_slassq( min( n, j+1 ), a( 1_${ik}$, j ), 1_${ik}$, scale, sum ) end do value = scale*sqrt( sum ) end if - stdlib_slanhs = value + stdlib${ii}$_slanhs = value return - end function stdlib_slanhs + end function stdlib${ii}$_slanhs - real(sp) function stdlib_slansb( norm, uplo, n, k, ab, ldab,work ) + real(sp) function stdlib${ii}$_slansb( norm, uplo, n, k, ab, ldab,work ) !! SLANSB returns the value of the one norm, or the Frobenius norm, or !! the infinity norm, or the element of largest absolute value of an !! n by n symmetric band matrix A, with k super-diagonals. @@ -30207,19 +30209,19 @@ module stdlib_linalg_lapack_s ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: norm, uplo - integer(ilp), intent(in) :: k, ldab, n + integer(${ik}$), intent(in) :: k, ldab, n ! Array Arguments real(sp), intent(in) :: ab(ldab,*) real(sp), intent(out) :: work(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, j, l + integer(${ik}$) :: i, j, l real(sp) :: absa, scale, sum, value ! Intrinsic Functions intrinsic :: abs,max,min,sqrt ! Executable Statements - if( n==0 ) then + if( n==0_${ik}$ ) then value = zero else if( stdlib_lsame( norm, 'M' ) ) then ! find max(abs(a(i,j))). @@ -30228,25 +30230,25 @@ module stdlib_linalg_lapack_s do j = 1, n do i = max( k+2-j, 1 ), k + 1 sum = abs( ab( i, j ) ) - if( value < sum .or. stdlib_sisnan( sum ) ) value = sum + if( value < sum .or. stdlib${ii}$_sisnan( sum ) ) value = sum end do end do else do j = 1, n do i = 1, min( n+1-j, k+1 ) sum = abs( ab( i, j ) ) - if( value < sum .or. stdlib_sisnan( sum ) ) value = sum + if( value < sum .or. stdlib${ii}$_sisnan( sum ) ) value = sum end do end do end if else if( ( stdlib_lsame( norm, 'I' ) ) .or. ( stdlib_lsame( norm, 'O' ) ) .or.( & - norm=='1' ) ) then + norm=='1_${ik}$' ) ) then ! find normi(a) ( = norm1(a), since a is symmetric). value = zero if( stdlib_lsame( uplo, 'U' ) ) then do j = 1, n sum = zero - l = k + 1 - j + l = k + 1_${ik}$ - j do i = max( 1, j-k ), j - 1 absa = abs( ab( l+i, j ) ) sum = sum + absa @@ -30256,21 +30258,21 @@ module stdlib_linalg_lapack_s end do do i = 1, n sum = work( i ) - if( value < sum .or. stdlib_sisnan( sum ) ) value = sum + if( value < sum .or. stdlib${ii}$_sisnan( sum ) ) value = sum end do else do i = 1, n work( i ) = zero end do do j = 1, n - sum = work( j ) + abs( ab( 1, j ) ) - l = 1 - j + sum = work( j ) + abs( ab( 1_${ik}$, j ) ) + l = 1_${ik}$ - j do i = j + 1, min( n, j+k ) absa = abs( ab( l+i, j ) ) sum = sum + absa work( i ) = work( i ) + absa end do - if( value < sum .or. stdlib_sisnan( sum ) ) value = sum + if( value < sum .or. stdlib${ii}$_sisnan( sum ) ) value = sum end do end if else if( ( stdlib_lsame( norm, 'F' ) ) .or. ( stdlib_lsame( norm, 'E' ) ) ) & @@ -30278,32 +30280,32 @@ module stdlib_linalg_lapack_s ! find normf(a). scale = zero sum = one - if( k>0 ) then + if( k>0_${ik}$ ) then if( stdlib_lsame( uplo, 'U' ) ) then do j = 2, n - call stdlib_slassq( min( j-1, k ), ab( max( k+2-j, 1 ), j ),1, scale, sum ) + call stdlib${ii}$_slassq( min( j-1, k ), ab( max( k+2-j, 1_${ik}$ ), j ),1_${ik}$, scale, sum ) end do - l = k + 1 + l = k + 1_${ik}$ else do j = 1, n - 1 - call stdlib_slassq( min( n-j, k ), ab( 2, j ), 1, scale,sum ) + call stdlib${ii}$_slassq( min( n-j, k ), ab( 2_${ik}$, j ), 1_${ik}$, scale,sum ) end do - l = 1 + l = 1_${ik}$ end if - sum = 2*sum + sum = 2_${ik}$*sum else - l = 1 + l = 1_${ik}$ end if - call stdlib_slassq( n, ab( l, 1 ), ldab, scale, sum ) + call stdlib${ii}$_slassq( n, ab( l, 1_${ik}$ ), ldab, scale, sum ) value = scale*sqrt( sum ) end if - stdlib_slansb = value + stdlib${ii}$_slansb = value return - end function stdlib_slansb + end function stdlib${ii}$_slansb - real(sp) function stdlib_slansf( norm, transr, uplo, n, a, work ) + real(sp) function stdlib${ii}$_slansf( norm, transr, uplo, n, a, work ) !! SLANSF returns the value of the one norm, or the Frobenius norm, or !! the infinity norm, or the element of largest absolute value of a !! real symmetric matrix A in RFP format. @@ -30312,60 +30314,60 @@ module stdlib_linalg_lapack_s ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: norm, transr, uplo - integer(ilp), intent(in) :: n + integer(${ik}$), intent(in) :: n ! Array Arguments - real(sp), intent(in) :: a(0:*) - real(sp), intent(out) :: work(0:*) + real(sp), intent(in) :: a(0_${ik}$:*) + real(sp), intent(out) :: work(0_${ik}$:*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, j, ifm, ilu, noe, n1, k, l, lda + integer(${ik}$) :: i, j, ifm, ilu, noe, n1, k, l, lda real(sp) :: scale, s, value, aa, temp ! Intrinsic Functions intrinsic :: abs,sqrt ! Executable Statements - if( n==0 ) then - stdlib_slansf = zero - return - else if( n==1 ) then - stdlib_slansf = abs( a(0) ) - return - end if - ! set noe = 1 if n is odd. if n is even set noe=0 - noe = 1 - if( mod( n, 2 )==0 )noe = 0 - ! set ifm = 0 when form='t or 't' and 1 otherwise - ifm = 1 - if( stdlib_lsame( transr, 'T' ) )ifm = 0 - ! set ilu = 0 when uplo='u or 'u' and 1 otherwise - ilu = 1 - if( stdlib_lsame( uplo, 'U' ) )ilu = 0 - ! set lda = (n+1)/2 when ifm = 0 - ! set lda = n when ifm = 1 and noe = 1 - ! set lda = n+1 when ifm = 1 and noe = 0 - if( ifm==1 ) then - if( noe==1 ) then + if( n==0_${ik}$ ) then + stdlib${ii}$_slansf = zero + return + else if( n==1_${ik}$ ) then + stdlib${ii}$_slansf = abs( a(0_${ik}$) ) + return + end if + ! set noe = 1_${ik}$ if n is odd. if n is even set noe=0_${ik}$ + noe = 1_${ik}$ + if( mod( n, 2_${ik}$ )==0_${ik}$ )noe = 0_${ik}$ + ! set ifm = 0_${ik}$ when form='t or 't' and 1_${ik}$ otherwise + ifm = 1_${ik}$ + if( stdlib_lsame( transr, 'T' ) )ifm = 0_${ik}$ + ! set ilu = 0_${ik}$ when uplo='u or 'u' and 1_${ik}$ otherwise + ilu = 1_${ik}$ + if( stdlib_lsame( uplo, 'U' ) )ilu = 0_${ik}$ + ! set lda = (n+1)/2_${ik}$ when ifm = 0_${ik}$ + ! set lda = n when ifm = 1_${ik}$ and noe = 1_${ik}$ + ! set lda = n+1 when ifm = 1_${ik}$ and noe = 0_${ik}$ + if( ifm==1_${ik}$ ) then + if( noe==1_${ik}$ ) then lda = n else - ! noe=0 - lda = n + 1 + ! noe=0_${ik}$ + lda = n + 1_${ik}$ end if else - ! ifm=0 - lda = ( n+1 ) / 2 + ! ifm=0_${ik}$ + lda = ( n+1 ) / 2_${ik}$ end if if( stdlib_lsame( norm, 'M' ) ) then ! find max(abs(a(i,j))). - k = ( n+1 ) / 2 + k = ( n+1 ) / 2_${ik}$ value = zero - if( noe==1 ) then + if( noe==1_${ik}$ ) then ! n is odd - if( ifm==1 ) then + if( ifm==1_${ik}$ ) then ! a is n by k do j = 0, k - 1 do i = 0, n - 1 temp = abs( a( i+j*lda ) ) - if( value < temp .or. stdlib_sisnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_sisnan( temp ) )value = temp end do end do else @@ -30373,18 +30375,18 @@ module stdlib_linalg_lapack_s do j = 0, n - 1 do i = 0, k - 1 temp = abs( a( i+j*lda ) ) - if( value < temp .or. stdlib_sisnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_sisnan( temp ) )value = temp end do end do end if else ! n is even - if( ifm==1 ) then + if( ifm==1_${ik}$ ) then ! a is n+1 by k do j = 0, k - 1 do i = 0, n temp = abs( a( i+j*lda ) ) - if( value < temp .or. stdlib_sisnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_sisnan( temp ) )value = temp end do end do else @@ -30392,19 +30394,19 @@ module stdlib_linalg_lapack_s do j = 0, n do i = 0, k - 1 temp = abs( a( i+j*lda ) ) - if( value < temp .or. stdlib_sisnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_sisnan( temp ) )value = temp end do end do end if end if else if( ( stdlib_lsame( norm, 'I' ) ) .or. ( stdlib_lsame( norm, 'O' ) ) .or.( & - norm=='1' ) ) then + norm=='1_${ik}$' ) ) then ! find normi(a) ( = norm1(a), since a is symmetric). - if( ifm==1 ) then - k = n / 2 - if( noe==1 ) then + if( ifm==1_${ik}$ ) then + k = n / 2_${ik}$ + if( noe==1_${ik}$ ) then ! n is odd - if( ilu==0 ) then + if( ilu==0_${ik}$ ) then do i = 0, k - 1 work( i ) = zero end do @@ -30420,13 +30422,13 @@ module stdlib_linalg_lapack_s ! -> a(j+k,j+k) work( j+k ) = s + aa if( i==k+k )go to 10 - i = i + 1 + i = i + 1_${ik}$ aa = abs( a( i+j*lda ) ) ! -> a(j,j) work( j ) = work( j ) + aa s = zero do l = j + 1, k - 1 - i = i + 1 + i = i + 1_${ik}$ aa = abs( a( i+j*lda ) ) ! -> a(l,j) s = s + aa @@ -30435,15 +30437,15 @@ module stdlib_linalg_lapack_s work( j ) = work( j ) + s end do 10 continue - value = work( 0 ) + value = work( 0_${ik}$ ) do i = 1, n-1 temp = work( i ) - if( value < temp .or. stdlib_sisnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_sisnan( temp ) )value = temp end do else - ! ilu = 1 - k = k + 1 - ! k=(n+1)/2 for n odd and ilu=1 + ! ilu = 1_${ik}$ + k = k + 1_${ik}$ + ! k=(n+1)/2_${ik}$ for n odd and ilu=1_${ik}$ do i = k, n - 1 work( i ) = zero end do @@ -30455,20 +30457,20 @@ module stdlib_linalg_lapack_s s = s + aa work( i+k ) = work( i+k ) + aa end do - if( j>0 ) then + if( j>0_${ik}$ ) then aa = abs( a( i+j*lda ) ) ! -> a(j+k,j+k) s = s + aa work( i+k ) = work( i+k ) + s ! i=j - i = i + 1 + i = i + 1_${ik}$ end if aa = abs( a( i+j*lda ) ) ! -> a(j,j) work( j ) = aa s = zero do l = j + 1, n - 1 - i = i + 1 + i = i + 1_${ik}$ aa = abs( a( i+j*lda ) ) ! -> a(l,j) s = s + aa @@ -30476,15 +30478,15 @@ module stdlib_linalg_lapack_s end do work( j ) = work( j ) + s end do - value = work( 0 ) + value = work( 0_${ik}$ ) do i = 1, n-1 temp = work( i ) - if( value < temp .or. stdlib_sisnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_sisnan( temp ) )value = temp end do end if else ! n is even - if( ilu==0 ) then + if( ilu==0_${ik}$ ) then do i = 0, k - 1 work( i ) = zero end do @@ -30499,13 +30501,13 @@ module stdlib_linalg_lapack_s aa = abs( a( i+j*lda ) ) ! -> a(j+k,j+k) work( j+k ) = s + aa - i = i + 1 + i = i + 1_${ik}$ aa = abs( a( i+j*lda ) ) ! -> a(j,j) work( j ) = work( j ) + aa s = zero do l = j + 1, k - 1 - i = i + 1 + i = i + 1_${ik}$ aa = abs( a( i+j*lda ) ) ! -> a(l,j) s = s + aa @@ -30513,13 +30515,13 @@ module stdlib_linalg_lapack_s end do work( j ) = work( j ) + s end do - value = work( 0 ) + value = work( 0_${ik}$ ) do i = 1, n-1 temp = work( i ) - if( value < temp .or. stdlib_sisnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_sisnan( temp ) )value = temp end do else - ! ilu = 1 + ! ilu = 1_${ik}$ do i = k, n - 1 work( i ) = zero end do @@ -30536,13 +30538,13 @@ module stdlib_linalg_lapack_s s = s + aa work( i+k ) = work( i+k ) + s ! i=j - i = i + 1 + i = i + 1_${ik}$ aa = abs( a( i+j*lda ) ) ! -> a(j,j) work( j ) = aa s = zero do l = j + 1, n - 1 - i = i + 1 + i = i + 1_${ik}$ aa = abs( a( i+j*lda ) ) ! -> a(l,j) s = s + aa @@ -30550,22 +30552,22 @@ module stdlib_linalg_lapack_s end do work( j ) = work( j ) + s end do - value = work( 0 ) + value = work( 0_${ik}$ ) do i = 1, n-1 temp = work( i ) - if( value < temp .or. stdlib_sisnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_sisnan( temp ) )value = temp end do end if end if else - ! ifm=0 - k = n / 2 - if( noe==1 ) then + ! ifm=0_${ik}$ + k = n / 2_${ik}$ + if( noe==1_${ik}$ ) then ! n is odd - if( ilu==0 ) then + if( ilu==0_${ik}$ ) then n1 = k - ! n/2 - k = k + 1 + ! n/2_${ik}$ + k = k + 1_${ik}$ ! k is the row size and lda do i = n1, n - 1 work( i ) = zero @@ -30581,7 +30583,7 @@ module stdlib_linalg_lapack_s work( j ) = s end do ! j=n1=k-1 is special - s = abs( a( 0+j*lda ) ) + s = abs( a( 0_${ik}$+j*lda ) ) ! a(k-1,k-1) do i = 1, k - 1 aa = abs( a( i+j*lda ) ) @@ -30603,11 +30605,11 @@ module stdlib_linalg_lapack_s ! a(j-k,j-k) s = s + aa work( j-k ) = work( j-k ) + s - i = i + 1 + i = i + 1_${ik}$ s = abs( a( i+j*lda ) ) ! a(j,j) do l = j + 1, n - 1 - i = i + 1 + i = i + 1_${ik}$ aa = abs( a( i+j*lda ) ) ! a(j,l) work( l ) = work( l ) + aa @@ -30615,15 +30617,15 @@ module stdlib_linalg_lapack_s end do work( j ) = work( j ) + s end do - value = work( 0 ) + value = work( 0_${ik}$ ) do i = 1, n-1 temp = work( i ) - if( value < temp .or. stdlib_sisnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_sisnan( temp ) )value = temp end do else - ! ilu=1 - k = k + 1 - ! k=(n+1)/2 for n odd and ilu=1 + ! ilu=1_${ik}$ + k = k + 1_${ik}$ + ! k=(n+1)/2_${ik}$ for n odd and ilu=1_${ik}$ do i = k, n - 1 work( i ) = zero end do @@ -30641,12 +30643,12 @@ module stdlib_linalg_lapack_s s = s + aa work( j ) = s ! is initialised here - i = i + 1 + i = i + 1_${ik}$ ! i=j process a(j+k,j+k) aa = abs( a( i+j*lda ) ) s = aa do l = k + j + 1, n - 1 - i = i + 1 + i = i + 1_${ik}$ aa = abs( a( i+j*lda ) ) ! a(l,k+j) s = s + aa @@ -30654,7 +30656,7 @@ module stdlib_linalg_lapack_s end do work( k+j ) = work( k+j ) + s end do - ! j=k-1 is special :process col a(k-1,0:k-1) + ! j=k-1 is special :process col a(k-1,0_${ik}$:k-1) s = zero do i = 0, k - 2 aa = abs( a( i+j*lda ) ) @@ -30669,7 +30671,7 @@ module stdlib_linalg_lapack_s work( i ) = s ! done with col j=k+1 do j = k, n - 1 - ! process col j of a = a(j,0:k-1) + ! process col j of a = a(j,0_${ik}$:k-1) s = zero do i = 0, k - 1 aa = abs( a( i+j*lda ) ) @@ -30679,15 +30681,15 @@ module stdlib_linalg_lapack_s end do work( j ) = work( j ) + s end do - value = work( 0 ) + value = work( 0_${ik}$ ) do i = 1, n-1 temp = work( i ) - if( value < temp .or. stdlib_sisnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_sisnan( temp ) )value = temp end do end if else ! n is even - if( ilu==0 ) then + if( ilu==0_${ik}$ ) then do i = k, n - 1 work( i ) = zero end do @@ -30702,7 +30704,7 @@ module stdlib_linalg_lapack_s work( j ) = s end do ! j=k - aa = abs( a( 0+j*lda ) ) + aa = abs( a( 0_${ik}$+j*lda ) ) ! a(k,k) s = aa do i = 1, k - 1 @@ -30725,12 +30727,12 @@ module stdlib_linalg_lapack_s ! a(j-k-1,j-k-1) s = s + aa work( j-k-1 ) = work( j-k-1 ) + s - i = i + 1 + i = i + 1_${ik}$ aa = abs( a( i+j*lda ) ) ! a(j,j) s = aa do l = j + 1, n - 1 - i = i + 1 + i = i + 1_${ik}$ aa = abs( a( i+j*lda ) ) ! a(j,l) work( l ) = work( l ) + aa @@ -30751,18 +30753,18 @@ module stdlib_linalg_lapack_s ! a(k-1,k-1) s = s + aa work( i ) = work( i ) + s - value = work ( 0 ) + value = work ( 0_${ik}$ ) do i = 1, n-1 temp = work( i ) - if( value < temp .or. stdlib_sisnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_sisnan( temp ) )value = temp end do else - ! ilu=1 + ! ilu=1_${ik}$ do i = k, n - 1 work( i ) = zero end do - ! j=0 is special :process col a(k:n-1,k) - s = abs( a( 0 ) ) + ! j=0_${ik}$ is special :process col a(k:n-1,k) + s = abs( a( 0_${ik}$ ) ) ! a(k,k) do i = 1, k - 1 aa = abs( a( i ) ) @@ -30785,12 +30787,12 @@ module stdlib_linalg_lapack_s s = s + aa work( j-1 ) = s ! is initialised here - i = i + 1 + i = i + 1_${ik}$ ! i=j process a(j+k,j+k) aa = abs( a( i+j*lda ) ) s = aa do l = k + j + 1, n - 1 - i = i + 1 + i = i + 1_${ik}$ aa = abs( a( i+j*lda ) ) ! a(l,k+j) s = s + aa @@ -30798,7 +30800,7 @@ module stdlib_linalg_lapack_s end do work( k+j ) = work( k+j ) + s end do - ! j=k is special :process col a(k,0:k-1) + ! j=k is special :process col a(k,0_${ik}$:k-1) s = zero do i = 0, k - 2 aa = abs( a( i+j*lda ) ) @@ -30813,7 +30815,7 @@ module stdlib_linalg_lapack_s work( i ) = s ! done with col j=k+1 do j = k + 1, n - ! process col j-1 of a = a(j-1,0:k-1) + ! process col j-1 of a = a(j-1,0_${ik}$:k-1) s = zero do i = 0, k - 1 aa = abs( a( i+j*lda ) ) @@ -30823,10 +30825,10 @@ module stdlib_linalg_lapack_s end do work( j-1 ) = work( j-1 ) + s end do - value = work( 0 ) + value = work( 0_${ik}$ ) do i = 1, n-1 temp = work( i ) - if( value < temp .or. stdlib_sisnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_sisnan( temp ) )value = temp end do end if end if @@ -30834,180 +30836,180 @@ module stdlib_linalg_lapack_s else if( ( stdlib_lsame( norm, 'F' ) ) .or. ( stdlib_lsame( norm, 'E' ) ) ) & then ! find normf(a). - k = ( n+1 ) / 2 + k = ( n+1 ) / 2_${ik}$ scale = zero s = one - if( noe==1 ) then + if( noe==1_${ik}$ ) then ! n is odd - if( ifm==1 ) then + if( ifm==1_${ik}$ ) then ! a is normal - if( ilu==0 ) then + if( ilu==0_${ik}$ ) then ! a is upper do j = 0, k - 3 - call stdlib_slassq( k-j-2, a( k+j+1+j*lda ), 1, scale, s ) - ! l at a(k,0) + call stdlib${ii}$_slassq( k-j-2, a( k+j+1+j*lda ), 1_${ik}$, scale, s ) + ! l at a(k,0_${ik}$) end do do j = 0, k - 1 - call stdlib_slassq( k+j-1, a( 0+j*lda ), 1, scale, s ) - ! trap u at a(0,0) + call stdlib${ii}$_slassq( k+j-1, a( 0_${ik}$+j*lda ), 1_${ik}$, scale, s ) + ! trap u at a(0_${ik}$,0_${ik}$) end do s = s + s ! double s for the off diagonal elements - call stdlib_slassq( k-1, a( k ), lda+1, scale, s ) - ! tri l at a(k,0) - call stdlib_slassq( k, a( k-1 ), lda+1, scale, s ) - ! tri u at a(k-1,0) + call stdlib${ii}$_slassq( k-1, a( k ), lda+1, scale, s ) + ! tri l at a(k,0_${ik}$) + call stdlib${ii}$_slassq( k, a( k-1 ), lda+1, scale, s ) + ! tri u at a(k-1,0_${ik}$) else - ! ilu=1 + ! ilu=1_${ik}$ do j = 0, k - 1 - call stdlib_slassq( n-j-1, a( j+1+j*lda ), 1, scale, s ) - ! trap l at a(0,0) + call stdlib${ii}$_slassq( n-j-1, a( j+1+j*lda ), 1_${ik}$, scale, s ) + ! trap l at a(0_${ik}$,0_${ik}$) end do do j = 0, k - 2 - call stdlib_slassq( j, a( 0+( 1+j )*lda ), 1, scale, s ) - ! u at a(0,1) + call stdlib${ii}$_slassq( j, a( 0_${ik}$+( 1_${ik}$+j )*lda ), 1_${ik}$, scale, s ) + ! u at a(0_${ik}$,1_${ik}$) end do s = s + s ! double s for the off diagonal elements - call stdlib_slassq( k, a( 0 ), lda+1, scale, s ) - ! tri l at a(0,0) - call stdlib_slassq( k-1, a( 0+lda ), lda+1, scale, s ) - ! tri u at a(0,1) + call stdlib${ii}$_slassq( k, a( 0_${ik}$ ), lda+1, scale, s ) + ! tri l at a(0_${ik}$,0_${ik}$) + call stdlib${ii}$_slassq( k-1, a( 0_${ik}$+lda ), lda+1, scale, s ) + ! tri u at a(0_${ik}$,1_${ik}$) end if else ! a is xpose - if( ilu==0 ) then + if( ilu==0_${ik}$ ) then ! a**t is upper do j = 1, k - 2 - call stdlib_slassq( j, a( 0+( k+j )*lda ), 1, scale, s ) - ! u at a(0,k) + call stdlib${ii}$_slassq( j, a( 0_${ik}$+( k+j )*lda ), 1_${ik}$, scale, s ) + ! u at a(0_${ik}$,k) end do do j = 0, k - 2 - call stdlib_slassq( k, a( 0+j*lda ), 1, scale, s ) - ! k by k-1 rect. at a(0,0) + call stdlib${ii}$_slassq( k, a( 0_${ik}$+j*lda ), 1_${ik}$, scale, s ) + ! k by k-1 rect. at a(0_${ik}$,0_${ik}$) end do do j = 0, k - 2 - call stdlib_slassq( k-j-1, a( j+1+( j+k-1 )*lda ), 1,scale, s ) - ! l at a(0,k-1) + call stdlib${ii}$_slassq( k-j-1, a( j+1+( j+k-1 )*lda ), 1_${ik}$,scale, s ) + ! l at a(0_${ik}$,k-1) end do s = s + s ! double s for the off diagonal elements - call stdlib_slassq( k-1, a( 0+k*lda ), lda+1, scale, s ) - ! tri u at a(0,k) - call stdlib_slassq( k, a( 0+( k-1 )*lda ), lda+1, scale, s ) - ! tri l at a(0,k-1) + call stdlib${ii}$_slassq( k-1, a( 0_${ik}$+k*lda ), lda+1, scale, s ) + ! tri u at a(0_${ik}$,k) + call stdlib${ii}$_slassq( k, a( 0_${ik}$+( k-1 )*lda ), lda+1, scale, s ) + ! tri l at a(0_${ik}$,k-1) else ! a**t is lower do j = 1, k - 1 - call stdlib_slassq( j, a( 0+j*lda ), 1, scale, s ) - ! u at a(0,0) + call stdlib${ii}$_slassq( j, a( 0_${ik}$+j*lda ), 1_${ik}$, scale, s ) + ! u at a(0_${ik}$,0_${ik}$) end do do j = k, n - 1 - call stdlib_slassq( k, a( 0+j*lda ), 1, scale, s ) - ! k by k-1 rect. at a(0,k) + call stdlib${ii}$_slassq( k, a( 0_${ik}$+j*lda ), 1_${ik}$, scale, s ) + ! k by k-1 rect. at a(0_${ik}$,k) end do do j = 0, k - 3 - call stdlib_slassq( k-j-2, a( j+2+j*lda ), 1, scale, s ) - ! l at a(1,0) + call stdlib${ii}$_slassq( k-j-2, a( j+2+j*lda ), 1_${ik}$, scale, s ) + ! l at a(1_${ik}$,0_${ik}$) end do s = s + s ! double s for the off diagonal elements - call stdlib_slassq( k, a( 0 ), lda+1, scale, s ) - ! tri u at a(0,0) - call stdlib_slassq( k-1, a( 1 ), lda+1, scale, s ) - ! tri l at a(1,0) + call stdlib${ii}$_slassq( k, a( 0_${ik}$ ), lda+1, scale, s ) + ! tri u at a(0_${ik}$,0_${ik}$) + call stdlib${ii}$_slassq( k-1, a( 1_${ik}$ ), lda+1, scale, s ) + ! tri l at a(1_${ik}$,0_${ik}$) end if end if else ! n is even - if( ifm==1 ) then + if( ifm==1_${ik}$ ) then ! a is normal - if( ilu==0 ) then + if( ilu==0_${ik}$ ) then ! a is upper do j = 0, k - 2 - call stdlib_slassq( k-j-1, a( k+j+2+j*lda ), 1, scale, s ) - ! l at a(k+1,0) + call stdlib${ii}$_slassq( k-j-1, a( k+j+2+j*lda ), 1_${ik}$, scale, s ) + ! l at a(k+1,0_${ik}$) end do do j = 0, k - 1 - call stdlib_slassq( k+j, a( 0+j*lda ), 1, scale, s ) - ! trap u at a(0,0) + call stdlib${ii}$_slassq( k+j, a( 0_${ik}$+j*lda ), 1_${ik}$, scale, s ) + ! trap u at a(0_${ik}$,0_${ik}$) end do s = s + s ! double s for the off diagonal elements - call stdlib_slassq( k, a( k+1 ), lda+1, scale, s ) - ! tri l at a(k+1,0) - call stdlib_slassq( k, a( k ), lda+1, scale, s ) - ! tri u at a(k,0) + call stdlib${ii}$_slassq( k, a( k+1 ), lda+1, scale, s ) + ! tri l at a(k+1,0_${ik}$) + call stdlib${ii}$_slassq( k, a( k ), lda+1, scale, s ) + ! tri u at a(k,0_${ik}$) else - ! ilu=1 + ! ilu=1_${ik}$ do j = 0, k - 1 - call stdlib_slassq( n-j-1, a( j+2+j*lda ), 1, scale, s ) - ! trap l at a(1,0) + call stdlib${ii}$_slassq( n-j-1, a( j+2+j*lda ), 1_${ik}$, scale, s ) + ! trap l at a(1_${ik}$,0_${ik}$) end do do j = 1, k - 1 - call stdlib_slassq( j, a( 0+j*lda ), 1, scale, s ) - ! u at a(0,0) + call stdlib${ii}$_slassq( j, a( 0_${ik}$+j*lda ), 1_${ik}$, scale, s ) + ! u at a(0_${ik}$,0_${ik}$) end do s = s + s ! double s for the off diagonal elements - call stdlib_slassq( k, a( 1 ), lda+1, scale, s ) - ! tri l at a(1,0) - call stdlib_slassq( k, a( 0 ), lda+1, scale, s ) - ! tri u at a(0,0) + call stdlib${ii}$_slassq( k, a( 1_${ik}$ ), lda+1, scale, s ) + ! tri l at a(1_${ik}$,0_${ik}$) + call stdlib${ii}$_slassq( k, a( 0_${ik}$ ), lda+1, scale, s ) + ! tri u at a(0_${ik}$,0_${ik}$) end if else ! a is xpose - if( ilu==0 ) then + if( ilu==0_${ik}$ ) then ! a**t is upper do j = 1, k - 1 - call stdlib_slassq( j, a( 0+( k+1+j )*lda ), 1, scale, s ) - ! u at a(0,k+1) + call stdlib${ii}$_slassq( j, a( 0_${ik}$+( k+1+j )*lda ), 1_${ik}$, scale, s ) + ! u at a(0_${ik}$,k+1) end do do j = 0, k - 1 - call stdlib_slassq( k, a( 0+j*lda ), 1, scale, s ) - ! k by k rect. at a(0,0) + call stdlib${ii}$_slassq( k, a( 0_${ik}$+j*lda ), 1_${ik}$, scale, s ) + ! k by k rect. at a(0_${ik}$,0_${ik}$) end do do j = 0, k - 2 - call stdlib_slassq( k-j-1, a( j+1+( j+k )*lda ), 1, scale,s ) - ! l at a(0,k) + call stdlib${ii}$_slassq( k-j-1, a( j+1+( j+k )*lda ), 1_${ik}$, scale,s ) + ! l at a(0_${ik}$,k) end do s = s + s ! double s for the off diagonal elements - call stdlib_slassq( k, a( 0+( k+1 )*lda ), lda+1, scale, s ) - ! tri u at a(0,k+1) - call stdlib_slassq( k, a( 0+k*lda ), lda+1, scale, s ) - ! tri l at a(0,k) + call stdlib${ii}$_slassq( k, a( 0_${ik}$+( k+1 )*lda ), lda+1, scale, s ) + ! tri u at a(0_${ik}$,k+1) + call stdlib${ii}$_slassq( k, a( 0_${ik}$+k*lda ), lda+1, scale, s ) + ! tri l at a(0_${ik}$,k) else ! a**t is lower do j = 1, k - 1 - call stdlib_slassq( j, a( 0+( j+1 )*lda ), 1, scale, s ) - ! u at a(0,1) + call stdlib${ii}$_slassq( j, a( 0_${ik}$+( j+1 )*lda ), 1_${ik}$, scale, s ) + ! u at a(0_${ik}$,1_${ik}$) end do do j = k + 1, n - call stdlib_slassq( k, a( 0+j*lda ), 1, scale, s ) - ! k by k rect. at a(0,k+1) + call stdlib${ii}$_slassq( k, a( 0_${ik}$+j*lda ), 1_${ik}$, scale, s ) + ! k by k rect. at a(0_${ik}$,k+1) end do do j = 0, k - 2 - call stdlib_slassq( k-j-1, a( j+1+j*lda ), 1, scale, s ) - ! l at a(0,0) + call stdlib${ii}$_slassq( k-j-1, a( j+1+j*lda ), 1_${ik}$, scale, s ) + ! l at a(0_${ik}$,0_${ik}$) end do s = s + s ! double s for the off diagonal elements - call stdlib_slassq( k, a( lda ), lda+1, scale, s ) - ! tri l at a(0,1) - call stdlib_slassq( k, a( 0 ), lda+1, scale, s ) - ! tri u at a(0,0) + call stdlib${ii}$_slassq( k, a( lda ), lda+1, scale, s ) + ! tri l at a(0_${ik}$,1_${ik}$) + call stdlib${ii}$_slassq( k, a( 0_${ik}$ ), lda+1, scale, s ) + ! tri u at a(0_${ik}$,0_${ik}$) end if end if end if value = scale*sqrt( s ) end if - stdlib_slansf = value + stdlib${ii}$_slansf = value return - end function stdlib_slansf + end function stdlib${ii}$_slansf - real(sp) function stdlib_slansp( norm, uplo, n, ap, work ) + real(sp) function stdlib${ii}$_slansp( norm, uplo, n, ap, work ) !! SLANSP returns the value of the one norm, or the Frobenius norm, or !! the infinity norm, or the element of largest absolute value of a !! real symmetric matrix A, supplied in packed form. @@ -31016,47 +31018,47 @@ module stdlib_linalg_lapack_s ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: norm, uplo - integer(ilp), intent(in) :: n + integer(${ik}$), intent(in) :: n ! Array Arguments real(sp), intent(in) :: ap(*) real(sp), intent(out) :: work(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, j, k + integer(${ik}$) :: i, j, k real(sp) :: absa, scale, sum, value ! Intrinsic Functions intrinsic :: abs,sqrt ! Executable Statements - if( n==0 ) then + if( n==0_${ik}$ ) then value = zero else if( stdlib_lsame( norm, 'M' ) ) then ! find max(abs(a(i,j))). value = zero if( stdlib_lsame( uplo, 'U' ) ) then - k = 1 + k = 1_${ik}$ do j = 1, n do i = k, k + j - 1 sum = abs( ap( i ) ) - if( value < sum .or. stdlib_sisnan( sum ) ) value = sum + if( value < sum .or. stdlib${ii}$_sisnan( sum ) ) value = sum end do k = k + j end do else - k = 1 + k = 1_${ik}$ do j = 1, n do i = k, k + n - j sum = abs( ap( i ) ) - if( value < sum .or. stdlib_sisnan( sum ) ) value = sum + if( value < sum .or. stdlib${ii}$_sisnan( sum ) ) value = sum end do - k = k + n - j + 1 + k = k + n - j + 1_${ik}$ end do end if else if( ( stdlib_lsame( norm, 'I' ) ) .or. ( stdlib_lsame( norm, 'O' ) ) .or.( & - norm=='1' ) ) then + norm=='1_${ik}$' ) ) then ! find normi(a) ( = norm1(a), since a is symmetric). value = zero - k = 1 + k = 1_${ik}$ if( stdlib_lsame( uplo, 'U' ) ) then do j = 1, n sum = zero @@ -31064,14 +31066,14 @@ module stdlib_linalg_lapack_s absa = abs( ap( k ) ) sum = sum + absa work( i ) = work( i ) + absa - k = k + 1 + k = k + 1_${ik}$ end do work( j ) = sum + abs( ap( k ) ) - k = k + 1 + k = k + 1_${ik}$ end do do i = 1, n sum = work( i ) - if( value < sum .or. stdlib_sisnan( sum ) ) value = sum + if( value < sum .or. stdlib${ii}$_sisnan( sum ) ) value = sum end do else do i = 1, n @@ -31079,14 +31081,14 @@ module stdlib_linalg_lapack_s end do do j = 1, n sum = work( j ) + abs( ap( k ) ) - k = k + 1 + k = k + 1_${ik}$ do i = j + 1, n absa = abs( ap( k ) ) sum = sum + absa work( i ) = work( i ) + absa - k = k + 1 + k = k + 1_${ik}$ end do - if( value < sum .or. stdlib_sisnan( sum ) ) value = sum + if( value < sum .or. stdlib${ii}$_sisnan( sum ) ) value = sum end do end if else if( ( stdlib_lsame( norm, 'F' ) ) .or. ( stdlib_lsame( norm, 'E' ) ) ) & @@ -31094,44 +31096,44 @@ module stdlib_linalg_lapack_s ! find normf(a). scale = zero sum = one - k = 2 + k = 2_${ik}$ if( stdlib_lsame( uplo, 'U' ) ) then do j = 2, n - call stdlib_slassq( j-1, ap( k ), 1, scale, sum ) + call stdlib${ii}$_slassq( j-1, ap( k ), 1_${ik}$, scale, sum ) k = k + j end do else do j = 1, n - 1 - call stdlib_slassq( n-j, ap( k ), 1, scale, sum ) - k = k + n - j + 1 + call stdlib${ii}$_slassq( n-j, ap( k ), 1_${ik}$, scale, sum ) + k = k + n - j + 1_${ik}$ end do end if - sum = 2*sum - k = 1 + sum = 2_${ik}$*sum + k = 1_${ik}$ do i = 1, n if( ap( k )/=zero ) then absa = abs( ap( k ) ) if( scale1 ) then - call stdlib_slassq( n-1, e, 1, scale, sum ) - sum = 2*sum + if( n>1_${ik}$ ) then + call stdlib${ii}$_slassq( n-1, e, 1_${ik}$, scale, sum ) + sum = 2_${ik}$*sum end if - call stdlib_slassq( n, d, 1, scale, sum ) + call stdlib${ii}$_slassq( n, d, 1_${ik}$, scale, sum ) anorm = scale*sqrt( sum ) end if - stdlib_slanst = anorm + stdlib${ii}$_slanst = anorm return - end function stdlib_slanst + end function stdlib${ii}$_slanst - real(sp) function stdlib_slansy( norm, uplo, n, a, lda, work ) + real(sp) function stdlib${ii}$_slansy( norm, uplo, n, a, lda, work ) !! SLANSY returns the value of the one norm, or the Frobenius norm, or !! the infinity norm, or the element of largest absolute value of a !! real symmetric matrix A. @@ -31202,19 +31204,19 @@ module stdlib_linalg_lapack_s ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: norm, uplo - integer(ilp), intent(in) :: lda, n + integer(${ik}$), intent(in) :: lda, n ! Array Arguments real(sp), intent(in) :: a(lda,*) real(sp), intent(out) :: work(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, j + integer(${ik}$) :: i, j real(sp) :: absa, scale, sum, value ! Intrinsic Functions intrinsic :: abs,sqrt ! Executable Statements - if( n==0 ) then + if( n==0_${ik}$ ) then value = zero else if( stdlib_lsame( norm, 'M' ) ) then ! find max(abs(a(i,j))). @@ -31223,19 +31225,19 @@ module stdlib_linalg_lapack_s do j = 1, n do i = 1, j sum = abs( a( i, j ) ) - if( value < sum .or. stdlib_sisnan( sum ) ) value = sum + if( value < sum .or. stdlib${ii}$_sisnan( sum ) ) value = sum end do end do else do j = 1, n do i = j, n sum = abs( a( i, j ) ) - if( value < sum .or. stdlib_sisnan( sum ) ) value = sum + if( value < sum .or. stdlib${ii}$_sisnan( sum ) ) value = sum end do end do end if else if( ( stdlib_lsame( norm, 'I' ) ) .or. ( stdlib_lsame( norm, 'O' ) ) .or.( & - norm=='1' ) ) then + norm=='1_${ik}$' ) ) then ! find normi(a) ( = norm1(a), since a is symmetric). value = zero if( stdlib_lsame( uplo, 'U' ) ) then @@ -31250,7 +31252,7 @@ module stdlib_linalg_lapack_s end do do i = 1, n sum = work( i ) - if( value < sum .or. stdlib_sisnan( sum ) ) value = sum + if( value < sum .or. stdlib${ii}$_sisnan( sum ) ) value = sum end do else do i = 1, n @@ -31263,7 +31265,7 @@ module stdlib_linalg_lapack_s sum = sum + absa work( i ) = work( i ) + absa end do - if( value < sum .or. stdlib_sisnan( sum ) ) value = sum + if( value < sum .or. stdlib${ii}$_sisnan( sum ) ) value = sum end do end if else if( ( stdlib_lsame( norm, 'F' ) ) .or. ( stdlib_lsame( norm, 'E' ) ) ) & @@ -31273,32 +31275,32 @@ module stdlib_linalg_lapack_s sum = one if( stdlib_lsame( uplo, 'U' ) ) then do j = 2, n - call stdlib_slassq( j-1, a( 1, j ), 1, scale, sum ) + call stdlib${ii}$_slassq( j-1, a( 1_${ik}$, j ), 1_${ik}$, scale, sum ) end do else do j = 1, n - 1 - call stdlib_slassq( n-j, a( j+1, j ), 1, scale, sum ) + call stdlib${ii}$_slassq( n-j, a( j+1, j ), 1_${ik}$, scale, sum ) end do end if - sum = 2*sum - call stdlib_slassq( n, a, lda+1, scale, sum ) + sum = 2_${ik}$*sum + call stdlib${ii}$_slassq( n, a, lda+1, scale, sum ) value = scale*sqrt( sum ) end if - stdlib_slansy = value + stdlib${ii}$_slansy = value return - end function stdlib_slansy + end function stdlib${ii}$_slansy - real(sp) function stdlib_slantb( norm, uplo, diag, n, k, ab,ldab, work ) + real(sp) function stdlib${ii}$_slantb( norm, uplo, diag, n, k, ab,ldab, work ) !! SLANTB returns the value of the one norm, or the Frobenius norm, or !! the infinity norm, or the element of largest absolute value of an - !! n by n triangular band matrix A, with ( k + 1 ) diagonals. + !! n by n triangular band matrix A, with ( k + 1_${ik}$ ) diagonals. ! -- lapack auxiliary routine -- ! -- lapack is a software package provided by univ. of tennessee, -- ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: diag, norm, uplo - integer(ilp), intent(in) :: k, ldab, n + integer(${ik}$), intent(in) :: k, ldab, n ! Array Arguments real(sp), intent(in) :: ab(ldab,*) real(sp), intent(out) :: work(*) @@ -31306,12 +31308,12 @@ module stdlib_linalg_lapack_s ! Local Scalars logical(lk) :: udiag - integer(ilp) :: i, j, l + integer(${ik}$) :: i, j, l real(sp) :: scale, sum, value ! Intrinsic Functions intrinsic :: abs,max,min,sqrt ! Executable Statements - if( n==0 ) then + if( n==0_${ik}$ ) then value = zero else if( stdlib_lsame( norm, 'M' ) ) then ! find max(abs(a(i,j))). @@ -31321,14 +31323,14 @@ module stdlib_linalg_lapack_s do j = 1, n do i = max( k+2-j, 1 ), k sum = abs( ab( i, j ) ) - if( value < sum .or. stdlib_sisnan( sum ) ) value = sum + if( value < sum .or. stdlib${ii}$_sisnan( sum ) ) value = sum end do end do else do j = 1, n do i = 2, min( n+1-j, k+1 ) sum = abs( ab( i, j ) ) - if( value < sum .or. stdlib_sisnan( sum ) ) value = sum + if( value < sum .or. stdlib${ii}$_sisnan( sum ) ) value = sum end do end do end if @@ -31338,19 +31340,19 @@ module stdlib_linalg_lapack_s do j = 1, n do i = max( k+2-j, 1 ), k + 1 sum = abs( ab( i, j ) ) - if( value < sum .or. stdlib_sisnan( sum ) ) value = sum + if( value < sum .or. stdlib${ii}$_sisnan( sum ) ) value = sum end do end do else do j = 1, n do i = 1, min( n+1-j, k+1 ) sum = abs( ab( i, j ) ) - if( value < sum .or. stdlib_sisnan( sum ) ) value = sum + if( value < sum .or. stdlib${ii}$_sisnan( sum ) ) value = sum end do end do end if end if - else if( ( stdlib_lsame( norm, 'O' ) ) .or. ( norm=='1' ) ) then + else if( ( stdlib_lsame( norm, 'O' ) ) .or. ( norm=='1_${ik}$' ) ) then ! find norm1(a). value = zero udiag = stdlib_lsame( diag, 'U' ) @@ -31367,7 +31369,7 @@ module stdlib_linalg_lapack_s sum = sum + abs( ab( i, j ) ) end do end if - if( value < sum .or. stdlib_sisnan( sum ) ) value = sum + if( value < sum .or. stdlib${ii}$_sisnan( sum ) ) value = sum end do else do j = 1, n @@ -31382,7 +31384,7 @@ module stdlib_linalg_lapack_s sum = sum + abs( ab( i, j ) ) end do end if - if( value < sum .or. stdlib_sisnan( sum ) ) value = sum + if( value < sum .or. stdlib${ii}$_sisnan( sum ) ) value = sum end do end if else if( stdlib_lsame( norm, 'I' ) ) then @@ -31394,7 +31396,7 @@ module stdlib_linalg_lapack_s work( i ) = one end do do j = 1, n - l = k + 1 - j + l = k + 1_${ik}$ - j do i = max( 1, j-k ), j - 1 work( i ) = work( i ) + abs( ab( l+i, j ) ) end do @@ -31404,7 +31406,7 @@ module stdlib_linalg_lapack_s work( i ) = zero end do do j = 1, n - l = k + 1 - j + l = k + 1_${ik}$ - j do i = max( 1, j-k ), j work( i ) = work( i ) + abs( ab( l+i, j ) ) end do @@ -31416,7 +31418,7 @@ module stdlib_linalg_lapack_s work( i ) = one end do do j = 1, n - l = 1 - j + l = 1_${ik}$ - j do i = j + 1, min( n, j+k ) work( i ) = work( i ) + abs( ab( l+i, j ) ) end do @@ -31426,7 +31428,7 @@ module stdlib_linalg_lapack_s work( i ) = zero end do do j = 1, n - l = 1 - j + l = 1_${ik}$ - j do i = j, min( n, j+k ) work( i ) = work( i ) + abs( ab( l+i, j ) ) end do @@ -31435,7 +31437,7 @@ module stdlib_linalg_lapack_s end if do i = 1, n sum = work( i ) - if( value < sum .or. stdlib_sisnan( sum ) ) value = sum + if( value < sum .or. stdlib${ii}$_sisnan( sum ) ) value = sum end do else if( ( stdlib_lsame( norm, 'F' ) ) .or. ( stdlib_lsame( norm, 'E' ) ) ) & then @@ -31444,9 +31446,9 @@ module stdlib_linalg_lapack_s if( stdlib_lsame( diag, 'U' ) ) then scale = one sum = n - if( k>0 ) then + if( k>0_${ik}$ ) then do j = 2, n - call stdlib_slassq( min( j-1, k ),ab( max( k+2-j, 1 ), j ), 1, scale,& + call stdlib${ii}$_slassq( min( j-1, k ),ab( max( k+2-j, 1_${ik}$ ), j ), 1_${ik}$, scale,& sum ) end do end if @@ -31454,7 +31456,7 @@ module stdlib_linalg_lapack_s scale = zero sum = one do j = 1, n - call stdlib_slassq( min( j, k+1 ), ab( max( k+2-j, 1 ), j ),1, scale, sum ) + call stdlib${ii}$_slassq( min( j, k+1 ), ab( max( k+2-j, 1_${ik}$ ), j ),1_${ik}$, scale, sum ) end do end if @@ -31462,27 +31464,27 @@ module stdlib_linalg_lapack_s if( stdlib_lsame( diag, 'U' ) ) then scale = one sum = n - if( k>0 ) then + if( k>0_${ik}$ ) then do j = 1, n - 1 - call stdlib_slassq( min( n-j, k ), ab( 2, j ), 1, scale,sum ) + call stdlib${ii}$_slassq( min( n-j, k ), ab( 2_${ik}$, j ), 1_${ik}$, scale,sum ) end do end if else scale = zero sum = one do j = 1, n - call stdlib_slassq( min( n-j+1, k+1 ), ab( 1, j ), 1, scale,sum ) + call stdlib${ii}$_slassq( min( n-j+1, k+1 ), ab( 1_${ik}$, j ), 1_${ik}$, scale,sum ) end do end if end if value = scale*sqrt( sum ) end if - stdlib_slantb = value + stdlib${ii}$_slantb = value return - end function stdlib_slantb + end function stdlib${ii}$_slantb - real(sp) function stdlib_slantp( norm, uplo, diag, n, ap, work ) + real(sp) function stdlib${ii}$_slantp( norm, uplo, diag, n, ap, work ) !! SLANTP returns the value of the one norm, or the Frobenius norm, or !! the infinity norm, or the element of largest absolute value of a !! triangular matrix A, supplied in packed form. @@ -31491,7 +31493,7 @@ module stdlib_linalg_lapack_s ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: diag, norm, uplo - integer(ilp), intent(in) :: n + integer(${ik}$), intent(in) :: n ! Array Arguments real(sp), intent(in) :: ap(*) real(sp), intent(out) :: work(*) @@ -31499,23 +31501,23 @@ module stdlib_linalg_lapack_s ! Local Scalars logical(lk) :: udiag - integer(ilp) :: i, j, k + integer(${ik}$) :: i, j, k real(sp) :: scale, sum, value ! Intrinsic Functions intrinsic :: abs,sqrt ! Executable Statements - if( n==0 ) then + if( n==0_${ik}$ ) then value = zero else if( stdlib_lsame( norm, 'M' ) ) then ! find max(abs(a(i,j))). - k = 1 + k = 1_${ik}$ if( stdlib_lsame( diag, 'U' ) ) then value = one if( stdlib_lsame( uplo, 'U' ) ) then do j = 1, n do i = k, k + j - 2 sum = abs( ap( i ) ) - if( value < sum .or. stdlib_sisnan( sum ) ) value = sum + if( value < sum .or. stdlib${ii}$_sisnan( sum ) ) value = sum end do k = k + j end do @@ -31523,9 +31525,9 @@ module stdlib_linalg_lapack_s do j = 1, n do i = k + 1, k + n - j sum = abs( ap( i ) ) - if( value < sum .or. stdlib_sisnan( sum ) ) value = sum + if( value < sum .or. stdlib${ii}$_sisnan( sum ) ) value = sum end do - k = k + n - j + 1 + k = k + n - j + 1_${ik}$ end do end if else @@ -31534,7 +31536,7 @@ module stdlib_linalg_lapack_s do j = 1, n do i = k, k + j - 1 sum = abs( ap( i ) ) - if( value < sum .or. stdlib_sisnan( sum ) ) value = sum + if( value < sum .or. stdlib${ii}$_sisnan( sum ) ) value = sum end do k = k + j end do @@ -31542,16 +31544,16 @@ module stdlib_linalg_lapack_s do j = 1, n do i = k, k + n - j sum = abs( ap( i ) ) - if( value < sum .or. stdlib_sisnan( sum ) ) value = sum + if( value < sum .or. stdlib${ii}$_sisnan( sum ) ) value = sum end do - k = k + n - j + 1 + k = k + n - j + 1_${ik}$ end do end if end if - else if( ( stdlib_lsame( norm, 'O' ) ) .or. ( norm=='1' ) ) then + else if( ( stdlib_lsame( norm, 'O' ) ) .or. ( norm=='1_${ik}$' ) ) then ! find norm1(a). value = zero - k = 1 + k = 1_${ik}$ udiag = stdlib_lsame( diag, 'U' ) if( stdlib_lsame( uplo, 'U' ) ) then do j = 1, n @@ -31567,7 +31569,7 @@ module stdlib_linalg_lapack_s end do end if k = k + j - if( value < sum .or. stdlib_sisnan( sum ) ) value = sum + if( value < sum .or. stdlib${ii}$_sisnan( sum ) ) value = sum end do else do j = 1, n @@ -31582,13 +31584,13 @@ module stdlib_linalg_lapack_s sum = sum + abs( ap( i ) ) end do end if - k = k + n - j + 1 - if( value < sum .or. stdlib_sisnan( sum ) ) value = sum + k = k + n - j + 1_${ik}$ + if( value < sum .or. stdlib${ii}$_sisnan( sum ) ) value = sum end do end if else if( stdlib_lsame( norm, 'I' ) ) then ! find normi(a). - k = 1 + k = 1_${ik}$ if( stdlib_lsame( uplo, 'U' ) ) then if( stdlib_lsame( diag, 'U' ) ) then do i = 1, n @@ -31597,9 +31599,9 @@ module stdlib_linalg_lapack_s do j = 1, n do i = 1, j - 1 work( i ) = work( i ) + abs( ap( k ) ) - k = k + 1 + k = k + 1_${ik}$ end do - k = k + 1 + k = k + 1_${ik}$ end do else do i = 1, n @@ -31608,7 +31610,7 @@ module stdlib_linalg_lapack_s do j = 1, n do i = 1, j work( i ) = work( i ) + abs( ap( k ) ) - k = k + 1 + k = k + 1_${ik}$ end do end do end if @@ -31618,10 +31620,10 @@ module stdlib_linalg_lapack_s work( i ) = one end do do j = 1, n - k = k + 1 + k = k + 1_${ik}$ do i = j + 1, n work( i ) = work( i ) + abs( ap( k ) ) - k = k + 1 + k = k + 1_${ik}$ end do end do else @@ -31631,7 +31633,7 @@ module stdlib_linalg_lapack_s do j = 1, n do i = j, n work( i ) = work( i ) + abs( ap( k ) ) - k = k + 1 + k = k + 1_${ik}$ end do end do end if @@ -31639,7 +31641,7 @@ module stdlib_linalg_lapack_s value = zero do i = 1, n sum = work( i ) - if( value < sum .or. stdlib_sisnan( sum ) ) value = sum + if( value < sum .or. stdlib${ii}$_sisnan( sum ) ) value = sum end do else if( ( stdlib_lsame( norm, 'F' ) ) .or. ( stdlib_lsame( norm, 'E' ) ) ) & then @@ -31648,17 +31650,17 @@ module stdlib_linalg_lapack_s if( stdlib_lsame( diag, 'U' ) ) then scale = one sum = n - k = 2 + k = 2_${ik}$ do j = 2, n - call stdlib_slassq( j-1, ap( k ), 1, scale, sum ) + call stdlib${ii}$_slassq( j-1, ap( k ), 1_${ik}$, scale, sum ) k = k + j end do else scale = zero sum = one - k = 1 + k = 1_${ik}$ do j = 1, n - call stdlib_slassq( j, ap( k ), 1, scale, sum ) + call stdlib${ii}$_slassq( j, ap( k ), 1_${ik}$, scale, sum ) k = k + j end do end if @@ -31666,29 +31668,29 @@ module stdlib_linalg_lapack_s if( stdlib_lsame( diag, 'U' ) ) then scale = one sum = n - k = 2 + k = 2_${ik}$ do j = 1, n - 1 - call stdlib_slassq( n-j, ap( k ), 1, scale, sum ) - k = k + n - j + 1 + call stdlib${ii}$_slassq( n-j, ap( k ), 1_${ik}$, scale, sum ) + k = k + n - j + 1_${ik}$ end do else scale = zero sum = one - k = 1 + k = 1_${ik}$ do j = 1, n - call stdlib_slassq( n-j+1, ap( k ), 1, scale, sum ) - k = k + n - j + 1 + call stdlib${ii}$_slassq( n-j+1, ap( k ), 1_${ik}$, scale, sum ) + k = k + n - j + 1_${ik}$ end do end if end if value = scale*sqrt( sum ) end if - stdlib_slantp = value + stdlib${ii}$_slantp = value return - end function stdlib_slantp + end function stdlib${ii}$_slantp - real(sp) function stdlib_slantr( norm, uplo, diag, m, n, a, lda,work ) + real(sp) function stdlib${ii}$_slantr( norm, uplo, diag, m, n, a, lda,work ) !! SLANTR returns the value of the one norm, or the Frobenius norm, or !! the infinity norm, or the element of largest absolute value of a !! trapezoidal or triangular matrix A. @@ -31697,7 +31699,7 @@ module stdlib_linalg_lapack_s ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: diag, norm, uplo - integer(ilp), intent(in) :: lda, m, n + integer(${ik}$), intent(in) :: lda, m, n ! Array Arguments real(sp), intent(in) :: a(lda,*) real(sp), intent(out) :: work(*) @@ -31705,12 +31707,12 @@ module stdlib_linalg_lapack_s ! Local Scalars logical(lk) :: udiag - integer(ilp) :: i, j + integer(${ik}$) :: i, j real(sp) :: scale, sum, value ! Intrinsic Functions intrinsic :: abs,min,sqrt ! Executable Statements - if( min( m, n )==0 ) then + if( min( m, n )==0_${ik}$ ) then value = zero else if( stdlib_lsame( norm, 'M' ) ) then ! find max(abs(a(i,j))). @@ -31720,14 +31722,14 @@ module stdlib_linalg_lapack_s do j = 1, n do i = 1, min( m, j-1 ) sum = abs( a( i, j ) ) - if( value < sum .or. stdlib_sisnan( sum ) ) value = sum + if( value < sum .or. stdlib${ii}$_sisnan( sum ) ) value = sum end do end do else do j = 1, n do i = j + 1, m sum = abs( a( i, j ) ) - if( value < sum .or. stdlib_sisnan( sum ) ) value = sum + if( value < sum .or. stdlib${ii}$_sisnan( sum ) ) value = sum end do end do end if @@ -31737,19 +31739,19 @@ module stdlib_linalg_lapack_s do j = 1, n do i = 1, min( m, j ) sum = abs( a( i, j ) ) - if( value < sum .or. stdlib_sisnan( sum ) ) value = sum + if( value < sum .or. stdlib${ii}$_sisnan( sum ) ) value = sum end do end do else do j = 1, n do i = j, m sum = abs( a( i, j ) ) - if( value < sum .or. stdlib_sisnan( sum ) ) value = sum + if( value < sum .or. stdlib${ii}$_sisnan( sum ) ) value = sum end do end do end if end if - else if( ( stdlib_lsame( norm, 'O' ) ) .or. ( norm=='1' ) ) then + else if( ( stdlib_lsame( norm, 'O' ) ) .or. ( norm=='1_${ik}$' ) ) then ! find norm1(a). value = zero udiag = stdlib_lsame( diag, 'U' ) @@ -31766,7 +31768,7 @@ module stdlib_linalg_lapack_s sum = sum + abs( a( i, j ) ) end do end if - if( value < sum .or. stdlib_sisnan( sum ) ) value = sum + if( value < sum .or. stdlib${ii}$_sisnan( sum ) ) value = sum end do else do j = 1, n @@ -31781,7 +31783,7 @@ module stdlib_linalg_lapack_s sum = sum + abs( a( i, j ) ) end do end if - if( value < sum .or. stdlib_sisnan( sum ) ) value = sum + if( value < sum .or. stdlib${ii}$_sisnan( sum ) ) value = sum end do end if else if( stdlib_lsame( norm, 'I' ) ) then @@ -31833,7 +31835,7 @@ module stdlib_linalg_lapack_s value = zero do i = 1, m sum = work( i ) - if( value < sum .or. stdlib_sisnan( sum ) ) value = sum + if( value < sum .or. stdlib${ii}$_sisnan( sum ) ) value = sum end do else if( ( stdlib_lsame( norm, 'F' ) ) .or. ( stdlib_lsame( norm, 'E' ) ) ) & then @@ -31843,13 +31845,13 @@ module stdlib_linalg_lapack_s scale = one sum = min( m, n ) do j = 2, n - call stdlib_slassq( min( m, j-1 ), a( 1, j ), 1, scale, sum ) + call stdlib${ii}$_slassq( min( m, j-1 ), a( 1_${ik}$, j ), 1_${ik}$, scale, sum ) end do else scale = zero sum = one do j = 1, n - call stdlib_slassq( min( m, j ), a( 1, j ), 1, scale, sum ) + call stdlib${ii}$_slassq( min( m, j ), a( 1_${ik}$, j ), 1_${ik}$, scale, sum ) end do end if else @@ -31857,31 +31859,31 @@ module stdlib_linalg_lapack_s scale = one sum = min( m, n ) do j = 1, n - call stdlib_slassq( m-j, a( min( m, j+1 ), j ), 1, scale,sum ) + call stdlib${ii}$_slassq( m-j, a( min( m, j+1 ), j ), 1_${ik}$, scale,sum ) end do else scale = zero sum = one do j = 1, n - call stdlib_slassq( m-j+1, a( j, j ), 1, scale, sum ) + call stdlib${ii}$_slassq( m-j+1, a( j, j ), 1_${ik}$, scale, sum ) end do end if end if value = scale*sqrt( sum ) end if - stdlib_slantr = value + stdlib${ii}$_slantr = value return - end function stdlib_slantr + end function stdlib${ii}$_slantr - pure subroutine stdlib_slaorhr_col_getrfnp( m, n, a, lda, d, info ) + pure subroutine stdlib${ii}$_slaorhr_col_getrfnp( m, n, a, lda, d, info ) !! SLAORHR_COL_GETRFNP computes the modified LU factorization without !! pivoting of a real general M-by-N matrix A. The factorization has !! the form: !! A - S = L * U, !! where: !! S is a m-by-n diagonal sign matrix with the diagonal D, so that - !! D(i) = S(i,i), 1 <= i <= min(M,N). The diagonal D is constructed + !! D(i) = S(i,i), 1_${ik}$ <= i <= min(M,N). The diagonal D is constructed !! as D(i)=-SIGN(A(i,i)), where A(i,i) is the value after performing !! i-1 steps of Gaussian elimination. This means that the diagonal !! element at each step of "modified" Gaussian elimination is @@ -31898,66 +31900,66 @@ module stdlib_linalg_lapack_s !! the matrix S above, one can show that the diagonal element at each !! step of Gaussian elimination is the largest (in absolute value) in !! the column on or below the diagonal, so that no pivoting is required - !! for numerical stability [1]. + !! for numerical stability [1_${ik}$]. !! For more details on the Householder reconstruction algorithm, - !! including the modified LU factorization, see [1]. + !! including the modified LU factorization, see [1_${ik}$]. !! This is the blocked right-looking version of the algorithm, - !! calling Level 3 BLAS to update the submatrix. To factorize a block, + !! calling Level 3_${ik}$ BLAS to update the submatrix. To factorize a block, !! this routine calls the recursive routine SLAORHR_COL_GETRFNP2. - !! [1] "Reconstructing Householder vectors from tall-skinny QR", + !! [1_${ik}$] "Reconstructing Householder vectors from tall-skinny QR", !! G. Ballard, J. Demmel, L. Grigori, M. Jacquelin, H.D. Nguyen, !! E. Solomonik, J. Parallel Distrib. Comput., - !! vol. 85, pp. 3-31, 2015. + !! vol. 85_${ik}$, pp. 3_${ik}$-31, 2015. ! -- 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 - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda, m, n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, m, n ! Array Arguments real(sp), intent(inout) :: a(lda,*) real(sp), intent(out) :: d(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: iinfo, j, jb, nb + integer(${ik}$) :: iinfo, j, jb, nb ! Intrinsic Functions intrinsic :: max,min ! Executable Statements ! test the input parameters. - info = 0 - if( m<0 ) then - info = -1 - else if( n<0 ) then - info = -2 - else if( lda=min( m, n ) ) then + nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'SLAORHR_COL_GETRFNP', ' ', m, n, -1_${ik}$, -1_${ik}$ ) + if( nb<=1_${ik}$ .or. nb>=min( m, n ) ) then ! use unblocked code. - call stdlib_slaorhr_col_getrfnp2( m, n, a, lda, d, info ) + call stdlib${ii}$_slaorhr_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_slaorhr_col_getrfnp2( m-j+1, jb, a( j, j ), lda,d( j ), iinfo ) + call stdlib${ii}$_slaorhr_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_strsm( 'LEFT', 'LOWER', 'NO TRANSPOSE', 'UNIT', jb,n-j-jb+1, one, & + call stdlib${ii}$_strsm( '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_sgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', m-j-jb+1,n-j-jb+1, jb, -& + call stdlib${ii}$_sgemm( '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 @@ -31965,11 +31967,11 @@ module stdlib_linalg_lapack_s end do end if return - end subroutine stdlib_slaorhr_col_getrfnp + end subroutine stdlib${ii}$_slaorhr_col_getrfnp - pure real(sp) function stdlib_slapy2( x, y ) - !! SLAPY2 returns sqrt(x**2+y**2), taking care not to cause unnecessary + pure real(sp) function stdlib${ii}$_slapy2( x, y ) + !! SLAPY2 returns sqrt(x**2_${ik}$+y**2_${ik}$), taking care not to cause unnecessary !! overflow and unnecessary underflow. ! -- lapack auxiliary routine -- ! -- lapack is a software package provided by univ. of tennessee, -- @@ -31985,231 +31987,231 @@ module stdlib_linalg_lapack_s ! Intrinsic Functions intrinsic :: abs,max,min,sqrt ! Executable Statements - x_is_nan = stdlib_sisnan( x ) - y_is_nan = stdlib_sisnan( y ) - if ( x_is_nan ) stdlib_slapy2 = x - if ( y_is_nan ) stdlib_slapy2 = y - hugeval = stdlib_slamch( 'OVERFLOW' ) + x_is_nan = stdlib${ii}$_sisnan( x ) + y_is_nan = stdlib${ii}$_sisnan( y ) + if ( x_is_nan ) stdlib${ii}$_slapy2 = x + if ( y_is_nan ) stdlib${ii}$_slapy2 = y + hugeval = stdlib${ii}$_slamch( '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_slapy2 = w + stdlib${ii}$_slapy2 = w else - stdlib_slapy2 = w*sqrt( one+( z / w )**2 ) + stdlib${ii}$_slapy2 = w*sqrt( one+( z / w )**2_${ik}$ ) end if end if return - end function stdlib_slapy2 + end function stdlib${ii}$_slapy2 - pure subroutine stdlib_slaqz1( a, lda, b, ldb, sr1, sr2, si, beta1, beta2,v ) - !! Given a 3-by-3 matrix pencil (A,B), SLAQZ1: sets v to a + pure subroutine stdlib${ii}$_slaqz1( a, lda, b, ldb, sr1, sr2, si, beta1, beta2,v ) + !! Given a 3_${ik}$-by-3 matrix pencil (A,B), SLAQZ1: sets v to a !! scalar multiple of the first column of the product - !! (*) K = (A - (beta2*sr2 - i*si)*B)*B^(-1)*(beta1*A - (sr2 + i*si2)*B)*B^(-1). + !! (*) K = (A - (beta2*sr2 - i*si)*B)*B^(-1_${ik}$)*(beta1*A - (sr2 + i*si2)*B)*B^(-1_${ik}$). !! It is assumed that either - !! 1) sr1 = sr2 + !! 1_${ik}$) sr1 = sr2 !! or - !! 2) si = 0. + !! 2_${ik}$) si = 0. !! This is useful for starting double implicit shift bulges !! in the QZ algorithm. ! arguments - integer(ilp), intent( in ) :: lda, ldb + integer(${ik}$), intent( in ) :: lda, ldb real(sp), intent( in ) :: a( lda, * ), b( ldb, * ), sr1, sr2, si,beta1, beta2 real(sp), intent( out ) :: v( * ) ! local scalars - real(sp) :: w(2), safmin, safmax, scale1, scale2 - safmin = stdlib_slamch( 'SAFE MINIMUM' ) + real(sp) :: w(2_${ik}$), safmin, safmax, scale1, scale2 + safmin = stdlib${ii}$_slamch( 'SAFE MINIMUM' ) safmax = one/safmin ! calculate first shifted vector - w( 1 ) = beta1*a( 1, 1 )-sr1*b( 1, 1 ) - w( 2 ) = beta1*a( 2, 1 )-sr1*b( 2, 1 ) - scale1 = sqrt( abs( w( 1 ) ) ) * sqrt( abs( w( 2 ) ) ) + w( 1_${ik}$ ) = beta1*a( 1_${ik}$, 1_${ik}$ )-sr1*b( 1_${ik}$, 1_${ik}$ ) + w( 2_${ik}$ ) = beta1*a( 2_${ik}$, 1_${ik}$ )-sr1*b( 2_${ik}$, 1_${ik}$ ) + scale1 = sqrt( abs( w( 1_${ik}$ ) ) ) * sqrt( abs( w( 2_${ik}$ ) ) ) if( scale1 >= safmin .and. scale1 <= safmax ) then - w( 1 ) = w( 1 )/scale1 - w( 2 ) = w( 2 )/scale1 + w( 1_${ik}$ ) = w( 1_${ik}$ )/scale1 + w( 2_${ik}$ ) = w( 2_${ik}$ )/scale1 end if ! solve linear system - w( 2 ) = w( 2 )/b( 2, 2 ) - w( 1 ) = ( w( 1 )-b( 1, 2 )*w( 2 ) )/b( 1, 1 ) - scale2 = sqrt( abs( w( 1 ) ) ) * sqrt( abs( w( 2 ) ) ) + w( 2_${ik}$ ) = w( 2_${ik}$ )/b( 2_${ik}$, 2_${ik}$ ) + w( 1_${ik}$ ) = ( w( 1_${ik}$ )-b( 1_${ik}$, 2_${ik}$ )*w( 2_${ik}$ ) )/b( 1_${ik}$, 1_${ik}$ ) + scale2 = sqrt( abs( w( 1_${ik}$ ) ) ) * sqrt( abs( w( 2_${ik}$ ) ) ) if( scale2 >= safmin .and. scale2 <= safmax ) then - w( 1 ) = w( 1 )/scale2 - w( 2 ) = w( 2 )/scale2 + w( 1_${ik}$ ) = w( 1_${ik}$ )/scale2 + w( 2_${ik}$ ) = w( 2_${ik}$ )/scale2 end if ! apply second shift - v( 1 ) = beta2*( a( 1, 1 )*w( 1 )+a( 1, 2 )*w( 2 ) )-sr2*( b( 1,1 )*w( 1 )+b( 1, 2 )*w(& - 2 ) ) - v( 2 ) = beta2*( a( 2, 1 )*w( 1 )+a( 2, 2 )*w( 2 ) )-sr2*( b( 2,1 )*w( 1 )+b( 2, 2 )*w(& - 2 ) ) - v( 3 ) = beta2*( a( 3, 1 )*w( 1 )+a( 3, 2 )*w( 2 ) )-sr2*( b( 3,1 )*w( 1 )+b( 3, 2 )*w(& - 2 ) ) + v( 1_${ik}$ ) = beta2*( a( 1_${ik}$, 1_${ik}$ )*w( 1_${ik}$ )+a( 1_${ik}$, 2_${ik}$ )*w( 2_${ik}$ ) )-sr2*( b( 1_${ik}$,1_${ik}$ )*w( 1_${ik}$ )+b( 1_${ik}$, 2_${ik}$ )*w(& + 2_${ik}$ ) ) + v( 2_${ik}$ ) = beta2*( a( 2_${ik}$, 1_${ik}$ )*w( 1_${ik}$ )+a( 2_${ik}$, 2_${ik}$ )*w( 2_${ik}$ ) )-sr2*( b( 2_${ik}$,1_${ik}$ )*w( 1_${ik}$ )+b( 2_${ik}$, 2_${ik}$ )*w(& + 2_${ik}$ ) ) + v( 3_${ik}$ ) = beta2*( a( 3_${ik}$, 1_${ik}$ )*w( 1_${ik}$ )+a( 3_${ik}$, 2_${ik}$ )*w( 2_${ik}$ ) )-sr2*( b( 3_${ik}$,1_${ik}$ )*w( 1_${ik}$ )+b( 3_${ik}$, 2_${ik}$ )*w(& + 2_${ik}$ ) ) ! account for imaginary part - v( 1 ) = v( 1 )+si*si*b( 1, 1 )/scale1/scale2 + v( 1_${ik}$ ) = v( 1_${ik}$ )+si*si*b( 1_${ik}$, 1_${ik}$ )/scale1/scale2 ! check for overflow - if( abs( v( 1 ) )>safmax .or. abs( v( 2 ) ) > safmax .or.abs( v( 3 ) )>safmax .or. & - stdlib_sisnan( v( 1 ) ) .or.stdlib_sisnan( v( 2 ) ) .or. stdlib_sisnan( v( 3 ) ) ) & + if( abs( v( 1_${ik}$ ) )>safmax .or. abs( v( 2_${ik}$ ) ) > safmax .or.abs( v( 3_${ik}$ ) )>safmax .or. & + stdlib${ii}$_sisnan( v( 1_${ik}$ ) ) .or.stdlib${ii}$_sisnan( v( 2_${ik}$ ) ) .or. stdlib${ii}$_sisnan( v( 3_${ik}$ ) ) ) & then - v( 1 ) = zero - v( 2 ) = zero - v( 3 ) = zero + v( 1_${ik}$ ) = zero + v( 2_${ik}$ ) = zero + v( 3_${ik}$ ) = zero end if - end subroutine stdlib_slaqz1 + end subroutine stdlib${ii}$_slaqz1 - pure subroutine stdlib_slaqz2( ilq, ilz, k, istartm, istopm, ihi, a, lda, b,ldb, nq, qstart, & - !! SLAQZ2 chases a 2x2 shift bulge in a matrix pencil down a single position + pure subroutine stdlib${ii}$_slaqz2( ilq, ilz, k, istartm, istopm, ihi, a, lda, b,ldb, nq, qstart, & + !! SLAQZ2 chases a 2_${ik}$x2 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, & + integer(${ik}$), intent( in ) :: k, lda, ldb, ldq, ldz, istartm, istopm,nq, nz, qstart, & zstart, ihi real(sp), intent(inout) :: a(lda,*), b(ldb,*), q(ldq,*), z(ldz,*) ! local variables - real(sp) :: h(2,3), c1, s1, c2, s2, temp + real(sp) :: h(2_${ik}$,3_${ik}$), 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_slartg( h( 1, 1 ), h( 2, 1 ), c1, s1, temp ) - h( 2, 1 ) = zero - h( 1, 1 ) = temp - call stdlib_srot( 2, h( 1, 2 ), 2, h( 2, 2 ), 2, c1, s1 ) - call stdlib_slartg( h( 2, 3 ), h( 2, 2 ), c1, s1, temp ) - call stdlib_srot( 1, h( 1, 3 ), 1, h( 1, 2 ), 1, c1, s1 ) - call stdlib_slartg( h( 1, 2 ), h( 1, 1 ), c2, s2, temp ) - call stdlib_srot( ihi-istartm+1, b( istartm, ihi ), 1, b( istartm,ihi-1 ), 1, c1, & + call stdlib${ii}$_slartg( h( 1_${ik}$, 1_${ik}$ ), h( 2_${ik}$, 1_${ik}$ ), c1, s1, temp ) + h( 2_${ik}$, 1_${ik}$ ) = zero + h( 1_${ik}$, 1_${ik}$ ) = temp + call stdlib${ii}$_srot( 2_${ik}$, h( 1_${ik}$, 2_${ik}$ ), 2_${ik}$, h( 2_${ik}$, 2_${ik}$ ), 2_${ik}$, c1, s1 ) + call stdlib${ii}$_slartg( h( 2_${ik}$, 3_${ik}$ ), h( 2_${ik}$, 2_${ik}$ ), c1, s1, temp ) + call stdlib${ii}$_srot( 1_${ik}$, h( 1_${ik}$, 3_${ik}$ ), 1_${ik}$, h( 1_${ik}$, 2_${ik}$ ), 1_${ik}$, c1, s1 ) + call stdlib${ii}$_slartg( h( 1_${ik}$, 2_${ik}$ ), h( 1_${ik}$, 1_${ik}$ ), c2, s2, temp ) + call stdlib${ii}$_srot( ihi-istartm+1, b( istartm, ihi ), 1_${ik}$, b( istartm,ihi-1 ), 1_${ik}$, c1, & s1 ) - call stdlib_srot( ihi-istartm+1, b( istartm, ihi-1 ), 1, b( istartm,ihi-2 ), 1, c2, & + call stdlib${ii}$_srot( ihi-istartm+1, b( istartm, ihi-1 ), 1_${ik}$, b( istartm,ihi-2 ), 1_${ik}$, c2, & s2 ) b( ihi-1, ihi-2 ) = zero b( ihi, ihi-2 ) = zero - call stdlib_srot( ihi-istartm+1, a( istartm, ihi ), 1, a( istartm,ihi-1 ), 1, c1, & + call stdlib${ii}$_srot( ihi-istartm+1, a( istartm, ihi ), 1_${ik}$, a( istartm,ihi-1 ), 1_${ik}$, c1, & s1 ) - call stdlib_srot( ihi-istartm+1, a( istartm, ihi-1 ), 1, a( istartm,ihi-2 ), 1, c2, & + call stdlib${ii}$_srot( ihi-istartm+1, a( istartm, ihi-1 ), 1_${ik}$, a( istartm,ihi-2 ), 1_${ik}$, c2, & s2 ) if ( ilz ) then - call stdlib_srot( nz, z( 1, ihi-zstart+1 ), 1, z( 1, ihi-1-zstart+1 ), 1, c1, s1 & + call stdlib${ii}$_srot( nz, z( 1_${ik}$, ihi-zstart+1 ), 1_${ik}$, z( 1_${ik}$, ihi-1-zstart+1 ), 1_${ik}$, c1, s1 & ) - call stdlib_srot( nz, z( 1, ihi-1-zstart+1 ), 1, z( 1,ihi-2-zstart+1 ), 1, c2, & + call stdlib${ii}$_srot( nz, z( 1_${ik}$, ihi-1-zstart+1 ), 1_${ik}$, z( 1_${ik}$,ihi-2-zstart+1 ), 1_${ik}$, c2, & s2 ) end if - call stdlib_slartg( a( ihi-1, ihi-2 ), a( ihi, ihi-2 ), c1, s1,temp ) + call stdlib${ii}$_slartg( 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_srot( istopm-ihi+2, a( ihi-1, ihi-1 ), lda, a( ihi,ihi-1 ), lda, c1, s1 & + call stdlib${ii}$_srot( istopm-ihi+2, a( ihi-1, ihi-1 ), lda, a( ihi,ihi-1 ), lda, c1, s1 & ) - call stdlib_srot( istopm-ihi+2, b( ihi-1, ihi-1 ), ldb, b( ihi,ihi-1 ), ldb, c1, s1 & + call stdlib${ii}$_srot( istopm-ihi+2, b( ihi-1, ihi-1 ), ldb, b( ihi,ihi-1 ), ldb, c1, s1 & ) if ( ilq ) then - call stdlib_srot( nq, q( 1, ihi-1-qstart+1 ), 1, q( 1, ihi-qstart+1 ), 1, c1, s1 & + call stdlib${ii}$_srot( nq, q( 1_${ik}$, ihi-1-qstart+1 ), 1_${ik}$, q( 1_${ik}$, ihi-qstart+1 ), 1_${ik}$, c1, s1 & ) end if - call stdlib_slartg( b( ihi, ihi ), b( ihi, ihi-1 ), c1, s1, temp ) + call stdlib${ii}$_slartg( b( ihi, ihi ), b( ihi, ihi-1 ), c1, s1, temp ) b( ihi, ihi ) = temp b( ihi, ihi-1 ) = zero - call stdlib_srot( ihi-istartm, b( istartm, ihi ), 1, b( istartm,ihi-1 ), 1, c1, s1 ) + call stdlib${ii}$_srot( ihi-istartm, b( istartm, ihi ), 1_${ik}$, b( istartm,ihi-1 ), 1_${ik}$, c1, s1 ) - call stdlib_srot( ihi-istartm+1, a( istartm, ihi ), 1, a( istartm,ihi-1 ), 1, c1, & + call stdlib${ii}$_srot( ihi-istartm+1, a( istartm, ihi ), 1_${ik}$, a( istartm,ihi-1 ), 1_${ik}$, c1, & s1 ) if ( ilz ) then - call stdlib_srot( nz, z( 1, ihi-zstart+1 ), 1, z( 1, ihi-1-zstart+1 ), 1, c1, s1 & + call stdlib${ii}$_srot( nz, z( 1_${ik}$, ihi-zstart+1 ), 1_${ik}$, z( 1_${ik}$, ihi-1-zstart+1 ), 1_${ik}$, 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_slartg( h( 1, 1 ), h( 2, 1 ), c1, s1, temp ) - h( 2, 1 ) = zero - h( 1, 1 ) = temp - call stdlib_srot( 2, h( 1, 2 ), 2, h( 2, 2 ), 2, c1, s1 ) + call stdlib${ii}$_slartg( h( 1_${ik}$, 1_${ik}$ ), h( 2_${ik}$, 1_${ik}$ ), c1, s1, temp ) + h( 2_${ik}$, 1_${ik}$ ) = zero + h( 1_${ik}$, 1_${ik}$ ) = temp + call stdlib${ii}$_srot( 2_${ik}$, h( 1_${ik}$, 2_${ik}$ ), 2_${ik}$, h( 2_${ik}$, 2_${ik}$ ), 2_${ik}$, c1, s1 ) ! calculate z1 and z2 - call stdlib_slartg( h( 2, 3 ), h( 2, 2 ), c1, s1, temp ) - call stdlib_srot( 1, h( 1, 3 ), 1, h( 1, 2 ), 1, c1, s1 ) - call stdlib_slartg( h( 1, 2 ), h( 1, 1 ), c2, s2, temp ) + call stdlib${ii}$_slartg( h( 2_${ik}$, 3_${ik}$ ), h( 2_${ik}$, 2_${ik}$ ), c1, s1, temp ) + call stdlib${ii}$_srot( 1_${ik}$, h( 1_${ik}$, 3_${ik}$ ), 1_${ik}$, h( 1_${ik}$, 2_${ik}$ ), 1_${ik}$, c1, s1 ) + call stdlib${ii}$_slartg( h( 1_${ik}$, 2_${ik}$ ), h( 1_${ik}$, 1_${ik}$ ), c2, s2, temp ) ! apply transformations from the right - call stdlib_srot( k+3-istartm+1, a( istartm, k+2 ), 1, a( istartm,k+1 ), 1, c1, s1 ) + call stdlib${ii}$_srot( k+3-istartm+1, a( istartm, k+2 ), 1_${ik}$, a( istartm,k+1 ), 1_${ik}$, c1, s1 ) - call stdlib_srot( k+3-istartm+1, a( istartm, k+1 ), 1, a( istartm,k ), 1, c2, s2 ) + call stdlib${ii}$_srot( k+3-istartm+1, a( istartm, k+1 ), 1_${ik}$, a( istartm,k ), 1_${ik}$, c2, s2 ) - call stdlib_srot( k+2-istartm+1, b( istartm, k+2 ), 1, b( istartm,k+1 ), 1, c1, s1 ) + call stdlib${ii}$_srot( k+2-istartm+1, b( istartm, k+2 ), 1_${ik}$, b( istartm,k+1 ), 1_${ik}$, c1, s1 ) - call stdlib_srot( k+2-istartm+1, b( istartm, k+1 ), 1, b( istartm,k ), 1, c2, s2 ) + call stdlib${ii}$_srot( k+2-istartm+1, b( istartm, k+1 ), 1_${ik}$, b( istartm,k ), 1_${ik}$, c2, s2 ) if ( ilz ) then - call stdlib_srot( nz, z( 1, k+2-zstart+1 ), 1, z( 1, k+1-zstart+1 ), 1, c1, s1 ) + call stdlib${ii}$_srot( nz, z( 1_${ik}$, k+2-zstart+1 ), 1_${ik}$, z( 1_${ik}$, k+1-zstart+1 ), 1_${ik}$, c1, s1 ) - call stdlib_srot( nz, z( 1, k+1-zstart+1 ), 1, z( 1, k-zstart+1 ),1, c2, s2 ) + call stdlib${ii}$_srot( nz, z( 1_${ik}$, k+1-zstart+1 ), 1_${ik}$, z( 1_${ik}$, k-zstart+1 ),1_${ik}$, c2, s2 ) end if b( k+1, k ) = zero b( k+2, k ) = zero ! calculate q1 and q2 - call stdlib_slartg( a( k+2, k ), a( k+3, k ), c1, s1, temp ) + call stdlib${ii}$_slartg( a( k+2, k ), a( k+3, k ), c1, s1, temp ) a( k+2, k ) = temp a( k+3, k ) = zero - call stdlib_slartg( a( k+1, k ), a( k+2, k ), c2, s2, temp ) + call stdlib${ii}$_slartg( 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_srot( istopm-k, a( k+2, k+1 ), lda, a( k+3, k+1 ), lda,c1, s1 ) - call stdlib_srot( istopm-k, a( k+1, k+1 ), lda, a( k+2, k+1 ), lda,c2, s2 ) - call stdlib_srot( istopm-k, b( k+2, k+1 ), ldb, b( k+3, k+1 ), ldb,c1, s1 ) - call stdlib_srot( istopm-k, b( k+1, k+1 ), ldb, b( k+2, k+1 ), ldb,c2, s2 ) + call stdlib${ii}$_srot( istopm-k, a( k+2, k+1 ), lda, a( k+3, k+1 ), lda,c1, s1 ) + call stdlib${ii}$_srot( istopm-k, a( k+1, k+1 ), lda, a( k+2, k+1 ), lda,c2, s2 ) + call stdlib${ii}$_srot( istopm-k, b( k+2, k+1 ), ldb, b( k+3, k+1 ), ldb,c1, s1 ) + call stdlib${ii}$_srot( istopm-k, b( k+1, k+1 ), ldb, b( k+2, k+1 ), ldb,c2, s2 ) if ( ilq ) then - call stdlib_srot( nq, q( 1, k+2-qstart+1 ), 1, q( 1, k+3-qstart+1 ), 1, c1, s1 ) + call stdlib${ii}$_srot( nq, q( 1_${ik}$, k+2-qstart+1 ), 1_${ik}$, q( 1_${ik}$, k+3-qstart+1 ), 1_${ik}$, c1, s1 ) - call stdlib_srot( nq, q( 1, k+1-qstart+1 ), 1, q( 1, k+2-qstart+1 ), 1, c2, s2 ) + call stdlib${ii}$_srot( nq, q( 1_${ik}$, k+1-qstart+1 ), 1_${ik}$, q( 1_${ik}$, k+2-qstart+1 ), 1_${ik}$, c2, s2 ) end if end if - end subroutine stdlib_slaqz2 + end subroutine stdlib${ii}$_slaqz2 - pure subroutine stdlib_slaqz4( ilschur, ilq, ilz, n, ilo, ihi, nshifts,nblock_desired, sr, & + pure subroutine stdlib${ii}$_slaqz4( ilschur, ilq, ilz, n, ilo, ihi, nshifts,nblock_desired, sr, & !! SLAQZ4 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, & + integer(${ik}$), intent( in ) :: n, ilo, ihi, lda, ldb, ldq, ldz, lwork,nshifts, & nblock_desired, ldqc, ldzc real(sp), intent( inout ) :: a( lda, * ), b( ldb, * ), q( ldq, * ),z( ldz, * ), qc( & ldqc, * ), zc( ldzc, * ), work( * ), sr( * ),si( * ), ss( * ) - integer(ilp), intent( out ) :: info + integer(${ik}$), intent( out ) :: info ! local scalars - integer(ilp) :: i, j, ns, istartm, istopm, sheight, swidth, k, np, istartb, istopb, & + integer(${ik}$) :: i, j, ns, istartm, istopm, sheight, swidth, k, np, istartb, istopb, & ishift, nblock, npos - real(sp) :: temp, v(3), c1, s1, c2, s2, swap - info = 0 + real(sp) :: temp, v(3_${ik}$), c1, s1, c2, s2, swap + info = 0_${ik}$ if ( nblock_desired < nshifts+1 ) then - info = -8 + info = -8_${ik}$ end if - if ( lwork ==-1 ) then + if ( lwork ==-1_${ik}$ ) then ! workspace query, quick return - work( 1 ) = n*nblock_desired + work( 1_${ik}$ ) = n*nblock_desired return else if ( lwork < n*nblock_desired ) then - info = -25 + info = -25_${ik}$ end if - if( info/=0 ) then - call stdlib_xerbla( 'SLAQZ4', -info ) + if( info/=0_${ik}$ ) then + call stdlib${ii}$_xerbla( 'SLAQZ4', -info ) return end if ! executable statements - if ( nshifts < 2 ) then + if ( nshifts < 2_${ik}$ ) then return end if if ( ilo >= ihi ) then return end if if ( ilschur ) then - istartm = 1 + istartm = 1_${ik}$ istopm = n else istartm = ilo @@ -32239,71 +32241,71 @@ module stdlib_linalg_lapack_s ! then simply reduce it by one. the shuffle above ! ensures that the dropped shift is real and that ! the remaining shifts are paired. - ns = nshifts-mod( nshifts, 2 ) - npos = max( nblock_desired-ns, 1 ) + ns = nshifts-mod( nshifts, 2_${ik}$ ) + npos = max( nblock_desired-ns, 1_${ik}$ ) ! the following block introduces the shifts and chases ! 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_slaset( 'FULL', ns+1, ns+1, zero, one, qc, ldqc ) - call stdlib_slaset( 'FULL', ns, ns, zero, one, zc, ldzc ) + call stdlib${ii}$_slaset( 'FULL', ns+1, ns+1, zero, one, qc, ldqc ) + call stdlib${ii}$_slaset( 'FULL', ns, ns, zero, one, zc, ldzc ) do i = 1, ns, 2 ! introduce the shift - call stdlib_slaqz1( a( ilo, ilo ), lda, b( ilo, ilo ), ldb, sr( i ),sr( i+1 ), si( & + call stdlib${ii}$_slaqz1( 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_slartg( temp, v( 3 ), c1, s1, v( 2 ) ) - call stdlib_slartg( v( 1 ), v( 2 ), c2, s2, temp ) - call stdlib_srot( ns, a( ilo+1, ilo ), lda, a( ilo+2, ilo ), lda, c1,s1 ) - call stdlib_srot( ns, a( ilo, ilo ), lda, a( ilo+1, ilo ), lda, c2,s2 ) - call stdlib_srot( ns, b( ilo+1, ilo ), ldb, b( ilo+2, ilo ), ldb, c1,s1 ) - call stdlib_srot( ns, b( ilo, ilo ), ldb, b( ilo+1, ilo ), ldb, c2,s2 ) - call stdlib_srot( ns+1, qc( 1, 2 ), 1, qc( 1, 3 ), 1, c1, s1 ) - call stdlib_srot( ns+1, qc( 1, 1 ), 1, qc( 1, 2 ), 1, c2, s2 ) + temp = v( 2_${ik}$ ) + call stdlib${ii}$_slartg( temp, v( 3_${ik}$ ), c1, s1, v( 2_${ik}$ ) ) + call stdlib${ii}$_slartg( v( 1_${ik}$ ), v( 2_${ik}$ ), c2, s2, temp ) + call stdlib${ii}$_srot( ns, a( ilo+1, ilo ), lda, a( ilo+2, ilo ), lda, c1,s1 ) + call stdlib${ii}$_srot( ns, a( ilo, ilo ), lda, a( ilo+1, ilo ), lda, c2,s2 ) + call stdlib${ii}$_srot( ns, b( ilo+1, ilo ), ldb, b( ilo+2, ilo ), ldb, c1,s1 ) + call stdlib${ii}$_srot( ns, b( ilo, ilo ), ldb, b( ilo+1, ilo ), ldb, c2,s2 ) + call stdlib${ii}$_srot( ns+1, qc( 1_${ik}$, 2_${ik}$ ), 1_${ik}$, qc( 1_${ik}$, 3_${ik}$ ), 1_${ik}$, c1, s1 ) + call stdlib${ii}$_srot( ns+1, qc( 1_${ik}$, 1_${ik}$ ), 1_${ik}$, qc( 1_${ik}$, 2_${ik}$ ), 1_${ik}$, c2, s2 ) ! chase the shift down do j = 1, ns-1-i - call stdlib_slaqz2( .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 ) + call stdlib${ii}$_slaqz2( .true., .true., j, 1_${ik}$, ns, ihi-ilo+1, a( ilo,ilo ), lda, b( & + ilo, ilo ), ldb, ns+1, 1_${ik}$, qc,ldqc, ns, 1_${ik}$, zc, ldzc ) end do end do ! update the rest of the pencil ! update a(ilo:ilo+ns,ilo+ns:istopm) and b(ilo:ilo+ns,ilo+ns:istopm) - ! from the left with qc(1:ns+1,1:ns+1)' + ! from the left with qc(1_${ik}$:ns+1,1_${ik}$:ns+1)' sheight = ns+1 - swidth = istopm-( ilo+ns )+1 - if ( swidth > 0 ) then - call stdlib_sgemm( 'T', 'N', sheight, swidth, sheight, one, qc, ldqc,a( ilo, ilo+ns & + swidth = istopm-( ilo+ns )+1_${ik}$ + if ( swidth > 0_${ik}$ ) then + call stdlib${ii}$_sgemm( 'T', 'N', sheight, swidth, sheight, one, qc, ldqc,a( ilo, ilo+ns & ), lda, zero, work, sheight ) - call stdlib_slacpy( 'ALL', sheight, swidth, work, sheight, a( ilo,ilo+ns ), lda ) + call stdlib${ii}$_slacpy( 'ALL', sheight, swidth, work, sheight, a( ilo,ilo+ns ), lda ) - call stdlib_sgemm( 'T', 'N', sheight, swidth, sheight, one, qc, ldqc,b( ilo, ilo+ns & + call stdlib${ii}$_sgemm( 'T', 'N', sheight, swidth, sheight, one, qc, ldqc,b( ilo, ilo+ns & ), ldb, zero, work, sheight ) - call stdlib_slacpy( 'ALL', sheight, swidth, work, sheight, b( ilo,ilo+ns ), ldb ) + call stdlib${ii}$_slacpy( 'ALL', sheight, swidth, work, sheight, b( ilo,ilo+ns ), ldb ) end if if ( ilq ) then - call stdlib_sgemm( 'N', 'N', n, sheight, sheight, one, q( 1, ilo ),ldq, qc, ldqc, & + call stdlib${ii}$_sgemm( 'N', 'N', n, sheight, sheight, one, q( 1_${ik}$, ilo ),ldq, qc, ldqc, & zero, work, n ) - call stdlib_slacpy( 'ALL', n, sheight, work, n, q( 1, ilo ), ldq ) + call stdlib${ii}$_slacpy( 'ALL', n, sheight, work, n, q( 1_${ik}$, 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) + ! from the right with zc(1_${ik}$:ns,1_${ik}$:ns) sheight = ilo-1-istartm+1 swidth = ns - if ( sheight > 0 ) then - call stdlib_sgemm( 'N', 'N', sheight, swidth, swidth, one, a( istartm,ilo ), lda, & + if ( sheight > 0_${ik}$ ) then + call stdlib${ii}$_sgemm( 'N', 'N', sheight, swidth, swidth, one, a( istartm,ilo ), lda, & zc, ldzc, zero, work, sheight ) - call stdlib_slacpy( 'ALL', sheight, swidth, work, sheight, a( istartm,ilo ), lda ) + call stdlib${ii}$_slacpy( 'ALL', sheight, swidth, work, sheight, a( istartm,ilo ), lda ) - call stdlib_sgemm( 'N', 'N', sheight, swidth, swidth, one, b( istartm,ilo ), ldb, & + call stdlib${ii}$_sgemm( 'N', 'N', sheight, swidth, swidth, one, b( istartm,ilo ), ldb, & zc, ldzc, zero, work, sheight ) - call stdlib_slacpy( 'ALL', sheight, swidth, work, sheight, b( istartm,ilo ), ldb ) + call stdlib${ii}$_slacpy( 'ALL', sheight, swidth, work, sheight, b( istartm,ilo ), ldb ) end if if ( ilz ) then - call stdlib_sgemm( 'N', 'N', n, swidth, swidth, one, z( 1, ilo ), ldz,zc, ldzc, & + call stdlib${ii}$_sgemm( 'N', 'N', n, swidth, swidth, one, z( 1_${ik}$, ilo ), ldz,zc, ldzc, & zero, work, n ) - call stdlib_slacpy( 'ALL', n, swidth, work, n, z( 1, ilo ), ldz ) + call stdlib${ii}$_slacpy( 'ALL', n, swidth, work, n, z( 1_${ik}$, ilo ), ldz ) end if ! the following block chases the shifts down to the bottom ! right block. if possible, a shift is moved down npos @@ -32317,64 +32319,64 @@ module stdlib_linalg_lapack_s istartb = k+1 ! istopb points to the last column we will be updating istopb = k+nblock-1 - call stdlib_slaset( 'FULL', ns+np, ns+np, zero, one, qc, ldqc ) - call stdlib_slaset( 'FULL', ns+np, ns+np, zero, one, zc, ldzc ) + call stdlib${ii}$_slaset( 'FULL', ns+np, ns+np, zero, one, qc, ldqc ) + call stdlib${ii}$_slaset( '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_slaqz2( .true., .true., k+i+j-1, istartb, istopb,ihi, a, lda, b, & + call stdlib${ii}$_slaqz2( .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 ! update rest of the pencil ! update a(k+1:k+ns+np, k+ns+np:istopm) and ! b(k+1:k+ns+np, k+ns+np:istopm) - ! from the left with qc(1:ns+np,1:ns+np)' + ! from the left with qc(1_${ik}$:ns+np,1_${ik}$:ns+np)' sheight = ns+np - swidth = istopm-( k+ns+np )+1 - if ( swidth > 0 ) then - call stdlib_sgemm( 'T', 'N', sheight, swidth, sheight, one, qc,ldqc, a( k+1, k+& + swidth = istopm-( k+ns+np )+1_${ik}$ + if ( swidth > 0_${ik}$ ) then + call stdlib${ii}$_sgemm( 'T', 'N', sheight, swidth, sheight, one, qc,ldqc, a( k+1, k+& ns+np ), lda, zero, work,sheight ) - call stdlib_slacpy( 'ALL', sheight, swidth, work, sheight, a( k+1,k+ns+np ), lda & + call stdlib${ii}$_slacpy( 'ALL', sheight, swidth, work, sheight, a( k+1,k+ns+np ), lda & ) - call stdlib_sgemm( 'T', 'N', sheight, swidth, sheight, one, qc,ldqc, b( k+1, k+& + call stdlib${ii}$_sgemm( 'T', 'N', sheight, swidth, sheight, one, qc,ldqc, b( k+1, k+& ns+np ), ldb, zero, work,sheight ) - call stdlib_slacpy( 'ALL', sheight, swidth, work, sheight, b( k+1,k+ns+np ), ldb & + call stdlib${ii}$_slacpy( 'ALL', sheight, swidth, work, sheight, b( k+1,k+ns+np ), ldb & ) end if if ( ilq ) then - call stdlib_sgemm( 'N', 'N', n, nblock, nblock, one, q( 1, k+1 ),ldq, qc, ldqc, & + call stdlib${ii}$_sgemm( 'N', 'N', n, nblock, nblock, one, q( 1_${ik}$, k+1 ),ldq, qc, ldqc, & zero, work, n ) - call stdlib_slacpy( 'ALL', n, nblock, work, n, q( 1, k+1 ), ldq ) + call stdlib${ii}$_slacpy( 'ALL', n, nblock, work, n, q( 1_${ik}$, 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) + ! from the right with zc(1_${ik}$:ns+np,1_${ik}$:ns+np) sheight = k-istartm+1 swidth = nblock - if ( sheight > 0 ) then - call stdlib_sgemm( 'N', 'N', sheight, swidth, swidth, one,a( istartm, k ), lda, & + if ( sheight > 0_${ik}$ ) then + call stdlib${ii}$_sgemm( 'N', 'N', sheight, swidth, swidth, one,a( istartm, k ), lda, & zc, ldzc, zero, work,sheight ) - call stdlib_slacpy( 'ALL', sheight, swidth, work, sheight,a( istartm, k ), lda ) + call stdlib${ii}$_slacpy( 'ALL', sheight, swidth, work, sheight,a( istartm, k ), lda ) - call stdlib_sgemm( 'N', 'N', sheight, swidth, swidth, one,b( istartm, k ), ldb, & + call stdlib${ii}$_sgemm( 'N', 'N', sheight, swidth, swidth, one,b( istartm, k ), ldb, & zc, ldzc, zero, work,sheight ) - call stdlib_slacpy( 'ALL', sheight, swidth, work, sheight,b( istartm, k ), ldb ) + call stdlib${ii}$_slacpy( 'ALL', sheight, swidth, work, sheight,b( istartm, k ), ldb ) end if if ( ilz ) then - call stdlib_sgemm( 'N', 'N', n, nblock, nblock, one, z( 1, k ),ldz, zc, ldzc, & + call stdlib${ii}$_sgemm( 'N', 'N', n, nblock, nblock, one, z( 1_${ik}$, k ),ldz, zc, ldzc, & zero, work, n ) - call stdlib_slacpy( 'ALL', n, nblock, work, n, z( 1, k ), ldz ) + call stdlib${ii}$_slacpy( 'ALL', n, nblock, work, n, z( 1_${ik}$, 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_slaset( 'FULL', ns, ns, zero, one, qc, ldqc ) - call stdlib_slaset( 'FULL', ns+1, ns+1, zero, one, zc, ldzc ) + call stdlib${ii}$_slaset( 'FULL', ns, ns, zero, one, qc, ldqc ) + call stdlib${ii}$_slaset( '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 @@ -32382,53 +32384,53 @@ module stdlib_linalg_lapack_s do i = 1, ns, 2 ! chase the shift down to the bottom right corner do ishift = ihi-i-1, ihi-2 - call stdlib_slaqz2( .true., .true., ishift, istartb, istopb, ihi,a, lda, b, ldb, & + call stdlib${ii}$_slaqz2( .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 ! update rest of the pencil ! update a(ihi-ns+1:ihi, ihi+1:istopm) - ! from the left with qc(1:ns,1:ns)' + ! from the left with qc(1_${ik}$:ns,1_${ik}$:ns)' sheight = ns - swidth = istopm-( ihi+1 )+1 - if ( swidth > 0 ) then - call stdlib_sgemm( 'T', 'N', sheight, swidth, sheight, one, qc, ldqc,a( ihi-ns+1, & + swidth = istopm-( ihi+1 )+1_${ik}$ + if ( swidth > 0_${ik}$ ) then + call stdlib${ii}$_sgemm( 'T', 'N', sheight, swidth, sheight, one, qc, ldqc,a( ihi-ns+1, & ihi+1 ), lda, zero, work, sheight ) - call stdlib_slacpy( 'ALL', sheight, swidth, work, sheight,a( ihi-ns+1, ihi+1 ), lda & + call stdlib${ii}$_slacpy( 'ALL', sheight, swidth, work, sheight,a( ihi-ns+1, ihi+1 ), lda & ) - call stdlib_sgemm( 'T', 'N', sheight, swidth, sheight, one, qc, ldqc,b( ihi-ns+1, & + call stdlib${ii}$_sgemm( 'T', 'N', sheight, swidth, sheight, one, qc, ldqc,b( ihi-ns+1, & ihi+1 ), ldb, zero, work, sheight ) - call stdlib_slacpy( 'ALL', sheight, swidth, work, sheight,b( ihi-ns+1, ihi+1 ), ldb & + call stdlib${ii}$_slacpy( 'ALL', sheight, swidth, work, sheight,b( ihi-ns+1, ihi+1 ), ldb & ) end if if ( ilq ) then - call stdlib_sgemm( 'N', 'N', n, ns, ns, one, q( 1, ihi-ns+1 ), ldq,qc, ldqc, zero, & + call stdlib${ii}$_sgemm( 'N', 'N', n, ns, ns, one, q( 1_${ik}$, ihi-ns+1 ), ldq,qc, ldqc, zero, & work, n ) - call stdlib_slacpy( 'ALL', n, ns, work, n, q( 1, ihi-ns+1 ), ldq ) + call stdlib${ii}$_slacpy( 'ALL', n, ns, work, n, q( 1_${ik}$, 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) + ! from the right with zc(1_${ik}$:ns+1,1_${ik}$:ns+1) sheight = ihi-ns-istartm+1 swidth = ns+1 - if ( sheight > 0 ) then - call stdlib_sgemm( 'N', 'N', sheight, swidth, swidth, one, a( istartm,ihi-ns ), lda,& + if ( sheight > 0_${ik}$ ) then + call stdlib${ii}$_sgemm( 'N', 'N', sheight, swidth, swidth, one, a( istartm,ihi-ns ), lda,& zc, ldzc, zero, work, sheight ) - call stdlib_slacpy( 'ALL', sheight, swidth, work, sheight, a( istartm,ihi-ns ), lda & + call stdlib${ii}$_slacpy( 'ALL', sheight, swidth, work, sheight, a( istartm,ihi-ns ), lda & ) - call stdlib_sgemm( 'N', 'N', sheight, swidth, swidth, one, b( istartm,ihi-ns ), ldb,& + call stdlib${ii}$_sgemm( 'N', 'N', sheight, swidth, swidth, one, b( istartm,ihi-ns ), ldb,& zc, ldzc, zero, work, sheight ) - call stdlib_slacpy( 'ALL', sheight, swidth, work, sheight, b( istartm,ihi-ns ), ldb & + call stdlib${ii}$_slacpy( 'ALL', sheight, swidth, work, sheight, b( istartm,ihi-ns ), ldb & ) end if if ( ilz ) then - call stdlib_sgemm( 'N', 'N', n, ns+1, ns+1, one, z( 1, ihi-ns ), ldz, zc,ldzc, zero, & + call stdlib${ii}$_sgemm( 'N', 'N', n, ns+1, ns+1, one, z( 1_${ik}$, ihi-ns ), ldz, zc,ldzc, zero, & work, n ) - call stdlib_slacpy( 'ALL', n, ns+1, work, n, z( 1, ihi-ns ), ldz ) + call stdlib${ii}$_slacpy( 'ALL', n, ns+1, work, n, z( 1_${ik}$, ihi-ns ), ldz ) end if - end subroutine stdlib_slaqz4 + end subroutine stdlib${ii}$_slaqz4 - pure subroutine stdlib_slar1v( n, b1, bn, lambda, d, l, ld, lld,pivmin, gaptol, z, wantnc, & + pure subroutine stdlib${ii}$_slar1v( n, b1, bn, lambda, d, l, ld, lld,pivmin, gaptol, z, wantnc, & !! SLAR1V 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 @@ -32450,13 +32452,13 @@ module stdlib_linalg_lapack_s ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments logical(lk), intent(in) :: wantnc - integer(ilp), intent(in) :: b1, bn, n - integer(ilp), intent(out) :: negcnt - integer(ilp), intent(inout) :: r + integer(${ik}$), intent(in) :: b1, bn, n + integer(${ik}$), intent(out) :: negcnt + integer(${ik}$), intent(inout) :: r real(sp), intent(in) :: gaptol, lambda, pivmin real(sp), intent(out) :: mingma, nrminv, resid, rqcorr, ztz ! Array Arguments - integer(ilp), intent(out) :: isuppz(*) + integer(${ik}$), intent(out) :: isuppz(*) real(sp), intent(in) :: d(*), l(*), ld(*), lld(*) real(sp), intent(out) :: work(*) real(sp), intent(inout) :: z(*) @@ -32464,13 +32466,13 @@ module stdlib_linalg_lapack_s ! Local Scalars logical(lk) :: sawnan1, sawnan2 - integer(ilp) :: i, indlpl, indp, inds, indumn, neg1, neg2, r1, r2 + integer(${ik}$) :: i, indlpl, indp, inds, indumn, neg1, neg2, r1, r2 real(sp) :: dminus, dplus, eps, s, tmp ! Intrinsic Functions intrinsic :: abs ! Executable Statements - eps = stdlib_slamch( 'PRECISION' ) - if( r==0 ) then + eps = stdlib${ii}$_slamch( 'PRECISION' ) + if( r==0_${ik}$ ) then r1 = b1 r2 = bn else @@ -32478,12 +32480,12 @@ module stdlib_linalg_lapack_s r2 = r end if ! storage for lplus - indlpl = 0 + indlpl = 0_${ik}$ ! storage for uminus indumn = n - inds = 2*n + 1 - indp = 3*n + 1 - if( b1==1 ) then + inds = 2_${ik}$*n + 1_${ik}$ + indp = 3_${ik}$*n + 1_${ik}$ + if( b1==1_${ik}$ ) then work( inds ) = zero else work( inds+b1-1 ) = lld( b1-1 ) @@ -32491,16 +32493,16 @@ module stdlib_linalg_lapack_s ! compute the stationary transform (using the differential form) ! until the index r2. sawnan1 = .false. - neg1 = 0 + neg1 = 0_${ik}$ s = work( inds+b1-1 ) - lambda do i = b1, r1 - 1 dplus = d( i ) + s work( indlpl+i ) = ld( i ) / dplus - if(dplus= 0. + ! h = [+/-1_${ik}$, 0_${ik}$; i], sign chosen so alpha >= 0. if( alpha>=zero ) then ! when tau.eq.zero, the vector is special-cased to be ! all zeros in the application routines. we do not need @@ -32766,27 +32768,27 @@ module stdlib_linalg_lapack_s ! zero checks when tau.ne.zero, and we must clear x. tau = two do j = 1, n-1 - x( 1 + (j-1)*incx ) = 0 + x( 1_${ik}$ + (j-1)*incx ) = 0_${ik}$ end do alpha = -alpha end if else ! general case - beta = sign( stdlib_slapy2( alpha, xnorm ), alpha ) - smlnum = stdlib_slamch( 'S' ) / stdlib_slamch( 'E' ) - knt = 0 + beta = sign( stdlib${ii}$_slapy2( alpha, xnorm ), alpha ) + smlnum = stdlib${ii}$_slamch( 'S' ) / stdlib${ii}$_slamch( 'E' ) + knt = 0_${ik}$ if( abs( beta )=zero ) then tau = zero else tau = two do j = 1, n-1 - x( 1 + (j-1)*incx ) = 0 + x( 1_${ik}$ + (j-1)*incx ) = 0_${ik}$ end do beta = -savealpha end if else ! this is the general case. - call stdlib_sscal( n-1, one / alpha, x, incx ) + call stdlib${ii}$_sscal( n-1, one / alpha, x, incx ) end if ! if beta is subnormal, it may lose relative accuracy do j = 1, knt @@ -32824,66 +32826,66 @@ module stdlib_linalg_lapack_s alpha = beta end if return - end subroutine stdlib_slarfgp + end subroutine stdlib${ii}$_slarfgp - pure subroutine stdlib_slarnv( idist, iseed, n, x ) + pure subroutine stdlib${ii}$_slarnv( idist, iseed, n, x ) !! SLARNV returns a vector of n random real numbers from a uniform or !! normal distribution. ! -- 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) :: idist, n + integer(${ik}$), intent(in) :: idist, n ! Array Arguments - integer(ilp), intent(inout) :: iseed(4) + integer(${ik}$), intent(inout) :: iseed(4_${ik}$) real(sp), intent(out) :: x(*) ! ===================================================================== ! Parameters - integer(ilp), parameter :: lv = 128 + integer(${ik}$), parameter :: lv = 128_${ik}$ real(sp), parameter :: twopi = 6.28318530717958647692528676655900576839e+0_sp ! Local Scalars - integer(ilp) :: i, il, il2, iv + integer(${ik}$) :: i, il, il2, iv ! Local Arrays real(sp) :: u(lv) ! Intrinsic Functions intrinsic :: cos,log,min,sqrt ! Executable Statements do 40 iv = 1, n, lv / 2 - il = min( lv / 2, n-iv+1 ) - if( idist==3 ) then - il2 = 2*il + il = min( lv / 2_${ik}$, n-iv+1 ) + if( idist==3_${ik}$ ) then + il2 = 2_${ik}$*il else il2 = il end if - ! call stdlib_slaruv to generate il2 numbers from a uniform (0,1) + ! call stdlib${ii}$_slaruv to generate il2 numbers from a uniform (0_${ik}$,1_${ik}$) ! distribution (il2 <= lv) - call stdlib_slaruv( iseed, il2, u ) - if( idist==1 ) then + call stdlib${ii}$_slaruv( iseed, il2, u ) + if( idist==1_${ik}$ ) then ! copy generated numbers do i = 1, il x( iv+i-1 ) = u( i ) end do - else if( idist==2 ) then - ! convert generated numbers to uniform (-1,1) distribution + else if( idist==2_${ik}$ ) then + ! convert generated numbers to uniform (-1_${ik}$,1_${ik}$) distribution do i = 1, il x( iv+i-1 ) = two*u( i ) - one end do - else if( idist==3 ) then - ! convert generated numbers to normal (0,1) distribution + else if( idist==3_${ik}$ ) then + ! convert generated numbers to normal (0_${ik}$,1_${ik}$) distribution do i = 1, il - x( iv+i-1 ) = sqrt( -two*log( u( 2*i-1 ) ) )*cos( twopi*u( 2*i ) ) + x( iv+i-1 ) = sqrt( -two*log( u( 2_${ik}$*i-1 ) ) )*cos( twopi*u( 2_${ik}$*i ) ) end do end if 40 continue return - end subroutine stdlib_slarnv + end subroutine stdlib${ii}$_slarnv - pure subroutine stdlib_slarrb( n, d, lld, ifirst, ilast, rtol1,rtol2, offset, w, wgap, werr, & + pure subroutine stdlib${ii}$_slarrb( n, d, lld, ifirst, ilast, rtol1,rtol2, offset, w, wgap, werr, & !! Given the relatively robust representation(RRR) L D L^T, SLARRB: !! does "limited" bisection to refine the eigenvalues of L D L^T, !! W( IFIRST-OFFSET ) through W( ILAST-OFFSET ), to more accuracy. Initial @@ -32897,46 +32899,46 @@ module stdlib_linalg_lapack_s ! -- 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) :: ifirst, ilast, n, offset, twist - integer(ilp), intent(out) :: info + integer(${ik}$), intent(in) :: ifirst, ilast, n, offset, twist + integer(${ik}$), intent(out) :: info real(sp), intent(in) :: pivmin, rtol1, rtol2, spdiam ! Array Arguments - integer(ilp), intent(out) :: iwork(*) + integer(${ik}$), intent(out) :: iwork(*) real(sp), intent(in) :: d(*), lld(*) real(sp), intent(inout) :: w(*), werr(*), wgap(*) real(sp), intent(out) :: work(*) ! ===================================================================== - integer(ilp) :: maxitr + integer(${ik}$) :: maxitr ! Local Scalars - integer(ilp) :: i, i1, ii, ip, iter, k, negcnt, next, nint, olnint, prev, r + integer(${ik}$) :: i, i1, ii, ip, iter, k, negcnt, next, nint, olnint, prev, r real(sp) :: back, cvrgd, gap, left, lgap, mid, mnwdth, rgap, right, tmp, width ! Intrinsic Functions intrinsic :: abs,max,min ! Executable Statements - info = 0 + info = 0_${ik}$ ! quick return if possible - if( n<=0 ) then + if( n<=0_${ik}$ ) then return end if - maxitr = int( ( log( spdiam+pivmin )-log( pivmin ) ) /log( two ),KIND=ilp) + 2 + maxitr = int( ( log( spdiam+pivmin )-log( pivmin ) ) /log( two ),KIND=${ik}$) + 2_${ik}$ mnwdth = two * pivmin r = twist - if((r<1).or.(r>n)) r = n - ! initialize unconverged intervals in [ work(2*i-1), work(2*i) ]. - ! the sturm count, count( work(2*i-1) ) is arranged to be i-1, while - ! count( work(2*i) ) is stored in iwork( 2*i ). the integer iwork( 2*i-1 ) + if((r<1_${ik}$).or.(r>n)) r = n + ! initialize unconverged intervals in [ work(2_${ik}$*i-1), work(2_${ik}$*i) ]. + ! the sturm count, count( work(2_${ik}$*i-1) ) is arranged to be i-1, while + ! count( work(2_${ik}$*i) ) is stored in iwork( 2_${ik}$*i ). the integer iwork( 2_${ik}$*i-1 ) ! for an unconverged interval is set to the index of the next unconverged - ! interval, and is -1 or 0 for a converged interval. thus a linked + ! interval, and is -1_${ik}$ or 0_${ik}$ for a converged interval. thus a linked ! list of unconverged intervals is set up. i1 = ifirst ! the number of unconverged intervals - nint = 0 + nint = 0_${ik}$ ! the last unconverged interval found - prev = 0 + prev = 0_${ik}$ rgap = wgap( i1-offset ) loop_75: do i = i1, ilast - k = 2*i + k = 2_${ik}$*i ii = i - offset left = w( ii ) - werr( ii ) right = w( ii ) + werr( ii ) @@ -32948,7 +32950,7 @@ module stdlib_linalg_lapack_s ! do while( negcnt(left)>i-1 ) back = werr( ii ) 20 continue - negcnt = stdlib_slaneg( n, d, lld, left, pivmin, r ) + negcnt = stdlib${ii}$_slaneg( n, d, lld, left, pivmin, r ) if( negcnt>i-1 ) then left = left - back back = two*back @@ -32958,7 +32960,7 @@ module stdlib_linalg_lapack_s ! compute negcount from dstqds facto l+d+l+^t = l d l^t - right back = werr( ii ) 50 continue - negcnt = stdlib_slaneg( n, d, lld, right, pivmin, r ) + negcnt = stdlib${ii}$_slaneg( n, d, lld, right, pivmin, r ) if( negcnt=i1).and.(i<=ilast)) iwork( 2*prev-1 ) = i + 1 + if((i==i1).and.(i=i1).and.(i<=ilast)) iwork( 2_${ik}$*prev-1 ) = i + 1_${ik}$ else ! unconverged interval found prev = i - nint = nint + 1 - iwork( k-1 ) = i + 1 + nint = nint + 1_${ik}$ + iwork( k-1 ) = i + 1_${ik}$ iwork( k ) = negcnt end if work( k-1 ) = left @@ -32988,17 +32990,17 @@ module stdlib_linalg_lapack_s end do loop_75 ! do while( nint>0 ), i.e. there are still unconverged intervals ! and while (iter1) lgap = wgap( ii-1 ) + if(ii>1_${ik}$) lgap = wgap( ii-1 ) gap = min( lgap, rgap ) next = iwork( k-1 ) left = work( k-1 ) @@ -33010,21 +33012,21 @@ module stdlib_linalg_lapack_s cvrgd = max(rtol1*gap,rtol2*tmp) if( ( width<=cvrgd ) .or. ( width<=mnwdth ).or.( iter==maxitr ) )then ! reduce number of unconverged intervals - nint = nint - 1 + nint = nint - 1_${ik}$ ! mark interval as converged. - iwork( k-1 ) = 0 + iwork( k-1 ) = 0_${ik}$ if( i1==i ) then i1 = next else ! prev holds the last unconverged interval previously examined - if(prev>=i1) iwork( 2*prev-1 ) = next + if(prev>=i1) iwork( 2_${ik}$*prev-1 ) = next end if i = next cycle loop_100 end if prev = i ! perform one bisection step - negcnt = stdlib_slaneg( n, d, lld, mid, pivmin, r ) + negcnt = stdlib${ii}$_slaneg( n, d, lld, mid, pivmin, r ) if( negcnt<=i-1 ) then work( k-1 ) = mid else @@ -33032,31 +33034,31 @@ module stdlib_linalg_lapack_s end if i = next end do loop_100 - iter = iter + 1 + iter = iter + 1_${ik}$ ! do another loop if there are still unconverged intervals ! however, in the last iteration, all intervals are accepted ! since this is the best we can do. if( ( nint>0 ).and.(iter<=maxitr) ) go to 80 ! at this point, all the intervals have converged do i = ifirst, ilast - k = 2*i + k = 2_${ik}$*i ii = i - offset - ! all intervals marked by '0' have been refined. - if( iwork( k-1 )==0 ) then + ! all intervals marked by '0_${ik}$' have been refined. + if( iwork( k-1 )==0_${ik}$ ) then w( ii ) = half*( work( k-1 )+work( k ) ) werr( ii ) = work( k ) - w( ii ) end if end do do i = ifirst+1, ilast - k = 2*i + k = 2_${ik}$*i ii = i - offset wgap( ii-1 ) = max( zero,w(ii) - werr (ii) - w( ii-1 ) - werr( ii-1 )) end do return - end subroutine stdlib_slarrb + end subroutine stdlib${ii}$_slarrb - pure subroutine stdlib_slarrf( n, d, l, ld, clstrt, clend,w, wgap, werr,spdiam, clgapl, & + pure subroutine stdlib${ii}$_slarrf( 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 ), SLARRF: finds a new relatively robust representation @@ -33067,8 +33069,8 @@ module stdlib_linalg_lapack_s ! -- 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) :: clstrt, clend, n - integer(ilp), intent(out) :: info + integer(${ik}$), intent(in) :: clstrt, clend, n + integer(${ik}$), intent(out) :: info real(sp), intent(in) :: clgapl, clgapr, pivmin, spdiam real(sp), intent(out) :: sigma ! Array Arguments @@ -33080,27 +33082,27 @@ module stdlib_linalg_lapack_s real(sp), parameter :: quart = 0.25_sp real(sp), parameter :: maxgrowth1 = 8._sp real(sp), parameter :: maxgrowth2 = 8._sp - integer(ilp), parameter :: ktrymax = 1 - integer(ilp), parameter :: sleft = 1 - integer(ilp), parameter :: sright = 2 + integer(${ik}$), parameter :: ktrymax = 1_${ik}$ + integer(${ik}$), parameter :: sleft = 1_${ik}$ + integer(${ik}$), parameter :: sright = 2_${ik}$ ! Local Scalars logical(lk) :: dorrr1, forcer, nofail, sawnan1, sawnan2, tryrrr1 - integer(ilp) :: i, indx, ktry, shift + integer(${ik}$) :: i, indx, ktry, shift real(sp) :: 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 intrinsic :: abs ! Executable Statements - info = 0 + info = 0_${ik}$ ! quick return if possible - if( n<=0 ) then + if( n<=0_${ik}$ ) then return end if - fact = real(2**ktrymax,KIND=sp) - eps = stdlib_slamch( 'PRECISION' ) - shift = 0 + fact = real(2_${ik}$**ktrymax,KIND=sp) + eps = stdlib${ii}$_slamch( 'PRECISION' ) + shift = 0_${ik}$ forcer = .false. ! note that we cannot guarantee that for any of the shifts tried, ! the factorization has a small or even moderate element growth. @@ -33112,8 +33114,8 @@ module stdlib_linalg_lapack_s ! least the l d l^t factorization exists. it can be checked afterwards ! whether the element growth caused bad residuals/orthogonality. ! decide whether the code should accept the best among all - ! representations despite large element growth or signal info=1 - ! setting nofail to .false. for quick fix for bug 113 + ! representations despite large element growth or signal info=1_${ik}$ + ! setting nofail to .false. for quick fix for bug 113_${ik}$ nofail = .false. ! compute the average gap length of the cluster clwdth = abs(w(clend)-w(clstrt)) + werr(clend) + werr(clstrt) @@ -33131,13 +33133,13 @@ module stdlib_linalg_lapack_s ldelta = max(avgap,wgap( clstrt ))/fact rdelta = max(avgap,wgap( clend-1 ))/fact ! initialize the record of the best representation found - s = stdlib_slamch( 'S' ) + s = stdlib${ii}$_slamch( 'S' ) smlgrowth = one / s fail = real(n-1,KIND=sp)*mingap/(spdiam*eps) fail2 = real(n-1,KIND=sp)*mingap/(spdiam*sqrt(eps)) bestshift = lsigma ! while (ktry <= ktrymax) - ktry = 0 + ktry = 0_${ik}$ growthbound = maxgrowth1*spdiam 5 continue sawnan1 = .false. @@ -33149,14 +33151,14 @@ module stdlib_linalg_lapack_s ! accept the shift if there is no element growth at one of the two ends ! left end s = -lsigma - dplus( 1 ) = d( 1 ) + s - if(abs(dplus(1))1) then + zusedl = 1_${ik}$ + if(dol>1_${ik}$) then ! set lower bound for use of z zusedl = dol-1 endif @@ -33389,13 +33391,13 @@ module stdlib_linalg_lapack_s zusedu = dou+1 endif ! the width of the part of z that is used - zusedw = zusedu - zusedl + 1 - call stdlib_slaset( 'FULL', n, zusedw, zero, zero,z(1,zusedl), ldz ) - eps = stdlib_slamch( 'PRECISION' ) + zusedw = zusedu - zusedl + 1_${ik}$ + call stdlib${ii}$_slaset( 'FULL', n, zusedw, zero, zero,z(1_${ik}$,zusedl), ldz ) + eps = stdlib${ii}$_slamch( 'PRECISION' ) rqtol = two * eps ! set expert flags for standard code. tryrqc = .true. - if((dol==1).and.(dou==m)) then + if((dol==1_${ik}$).and.(dou==m)) then else ! only selected eigenpairs are computed. since the other evalues ! are not refined by rq iteration, bisection has to compute to full @@ -33409,54 +33411,54 @@ module stdlib_linalg_lapack_s ! remark that if k eigenpairs are desired, then the eigenvectors ! are stored in k contiguous columns of z. ! done is the number of eigenvectors already computed - done = 0 - ibegin = 1 - wbegin = 1 + done = 0_${ik}$ + ibegin = 1_${ik}$ + wbegin = 1_${ik}$ loop_170: do jblk = 1, iblock( m ) iend = isplit( jblk ) sigma = l( iend ) ! find the eigenvectors of the submatrix indexed ibegin ! through iend. - wend = wbegin - 1 + wend = wbegin - 1_${ik}$ 15 continue if( wenddou) ) then - ibegin = iend + 1 - wbegin = wend + 1 + ibegin = iend + 1_${ik}$ + wbegin = wend + 1_${ik}$ cycle loop_170 end if ! find local spectral diameter of the block - gl = gers( 2*ibegin-1 ) - gu = gers( 2*ibegin ) + gl = gers( 2_${ik}$*ibegin-1 ) + gu = gers( 2_${ik}$*ibegin ) do i = ibegin+1 , iend - gl = min( gers( 2*i-1 ), gl ) - gu = max( gers( 2*i ), gu ) + gl = min( gers( 2_${ik}$*i-1 ), gl ) + gu = max( gers( 2_${ik}$*i ), gu ) end do spdiam = gu - gl ! oldien is the last index of the previous block - oldien = ibegin - 1 + oldien = ibegin - 1_${ik}$ ! calculate the size of the current block - in = iend - ibegin + 1 + in = iend - ibegin + 1_${ik}$ ! the number of eigenvalues in the current block - im = wend - wbegin + 1 - ! this is for a 1x1 block + im = wend - wbegin + 1_${ik}$ + ! this is for a 1_${ik}$x1 block if( ibegin==iend ) then done = done+1 z( ibegin, wbegin ) = one - isuppz( 2*wbegin-1 ) = ibegin - isuppz( 2*wbegin ) = ibegin + isuppz( 2_${ik}$*wbegin-1 ) = ibegin + isuppz( 2_${ik}$*wbegin ) = ibegin w( wbegin ) = w( wbegin ) + sigma work( wbegin ) = w( wbegin ) - ibegin = iend + 1 - wbegin = wbegin + 1 + ibegin = iend + 1_${ik}$ + wbegin = wbegin + 1_${ik}$ cycle loop_170 end if ! the desired (shifted) eigenvalues are stored in w(wbegin:wend) @@ -33465,24 +33467,24 @@ module stdlib_linalg_lapack_s ! the eigenvalue approximations will be refined when necessary as ! high relative accuracy is required for the computation of the ! corresponding eigenvectors. - call stdlib_scopy( im, w( wbegin ), 1,work( wbegin ), 1 ) + call stdlib${ii}$_scopy( im, w( wbegin ), 1_${ik}$,work( wbegin ), 1_${ik}$ ) ! we store in w the eigenvalue approximations w.r.t. the original ! matrix t. do i=1,im w(wbegin+i-1) = w(wbegin+i-1)+sigma end do ! ndepth is the current depth of the representation tree - ndepth = 0 - ! parity is either 1 or 0 - parity = 1 + ndepth = 0_${ik}$ + ! parity is either 1_${ik}$ or 0_${ik}$ + parity = 1_${ik}$ ! nclus is the number of clusters for the next level of the - ! representation tree, we start with nclus = 1 for the root - nclus = 1 - iwork( iindc1+1 ) = 1 + ! representation tree, we start with nclus = 1_${ik}$ for the root + nclus = 1_${ik}$ + iwork( iindc1+1 ) = 1_${ik}$ iwork( iindc1+2 ) = im ! idone is the number of eigenvectors already computed in the current ! block - idone = 0 + idone = 0_${ik}$ ! loop while( idonem ) then - info = -2 + info = -2_${ik}$ return endif ! breadth first processing of the current level of the representation ! tree: oldncl = number of clusters on current level oldncl = nclus ! reset nclus to count the number of child clusters - nclus = 0 - parity = 1 - parity - if( parity==0 ) then + nclus = 0_${ik}$ + parity = 1_${ik}$ - parity + if( parity==0_${ik}$ ) then oldcls = iindc1 newcls = iindc2 else @@ -33508,37 +33510,37 @@ module stdlib_linalg_lapack_s end if ! process the clusters on the current level loop_150: do i = 1, oldncl - j = oldcls + 2*i + j = oldcls + 2_${ik}$*i ! oldfst, oldlst = first, last index of current cluster. - ! cluster indices start with 1 and are relative + ! cluster indices start with 1_${ik}$ and are relative ! to wbegin when accessing w, wgap, werr, z oldfst = iwork( j-1 ) oldlst = iwork( j ) - if( ndepth>0 ) then + if( ndepth>0_${ik}$ ) then ! retrieve relatively robust representation (rrr) of cluster ! that has been computed at the previous level ! the rrr is stored in z and overwritten once the eigenvectors ! have been computed or when the cluster is refined - if((dol==1).and.(dou==m)) then + if((dol==1_${ik}$).and.(dou==m)) then ! get representation from location of the leftmost evalue ! of the cluster - j = wbegin + oldfst - 1 + j = wbegin + oldfst - 1_${ik}$ else if(wbegin+oldfst-1dou) then ! get representation from the right end of z array j = dou else - j = wbegin + oldfst - 1 + j = wbegin + oldfst - 1_${ik}$ endif endif - call stdlib_scopy( in, z( ibegin, j ), 1, d( ibegin ), 1 ) - call stdlib_scopy( in-1, z( ibegin, j+1 ), 1, l( ibegin ),1 ) + call stdlib${ii}$_scopy( in, z( ibegin, j ), 1_${ik}$, d( ibegin ), 1_${ik}$ ) + call stdlib${ii}$_scopy( in-1, z( ibegin, j+1 ), 1_${ik}$, l( ibegin ),1_${ik}$ ) sigma = z( iend, j+1 ) ! set the corresponding entries in z to zero - call stdlib_slaset( 'FULL', in, 2, zero, zero,z( ibegin, j), ldz ) + call stdlib${ii}$_slaset( 'FULL', in, 2_${ik}$, zero, zero,z( ibegin, j), ldz ) end if ! compute dl and dll of current rrr do j = ibegin, iend-1 @@ -33546,7 +33548,7 @@ module stdlib_linalg_lapack_s work( indld-1+j ) = tmp work( indlld-1+j ) = tmp*l( j ) end do - if( ndepth>0 ) then + if( ndepth>0_${ik}$ ) then ! p and q are index of the first and last eigenvalue to compute ! within the current block p = indexw( wbegin-1+oldfst ) @@ -33554,29 +33556,29 @@ module stdlib_linalg_lapack_s ! offset for the arrays work, wgap and werr, i.e., the p-offset ! through the q-offset elements of these arrays are to be used. ! offset = p-oldfst - offset = indexw( wbegin ) - 1 + offset = indexw( wbegin ) - 1_${ik}$ ! perform limited bisection (if necessary) to get approximate ! eigenvalues to the precision needed. - call stdlib_slarrb( in, d( ibegin ),work(indlld+ibegin-1),p, q, rtol1, & + call stdlib${ii}$_slarrb( 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 - info = -1 + if( iinfo/=0_${ik}$ ) then + info = -1_${ik}$ return endif ! we also recompute the extremal gaps. w holds all eigenvalues ! 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_slarrb. + ! wbegin-1+oldlst are correctly computed in stdlib${ii}$_slarrb. ! however, we only allow the gaps to become greater since ! this is what should happen when we decrease werr - if( oldfst>1) then + if( oldfst>1_${ik}$) then wgap( wbegin+oldfst-2 ) =max(wgap(wbegin+oldfst-2),w(wbegin+oldfst-1)-& werr(wbegin+oldfst-1)- w(wbegin+oldfst-2)-werr(wbegin+oldfst-2) ) endif - if( wbegin + oldlst -1 < wend ) then + if( wbegin + oldlst -1_${ik}$ < wend ) then wgap( wbegin+oldlst-1 ) =max(wgap(wbegin+oldlst-1),w(wbegin+oldlst)-& werr(wbegin+oldlst)- w(wbegin+oldlst-1)-werr(wbegin+oldlst-1) ) endif @@ -33593,7 +33595,7 @@ module stdlib_linalg_lapack_s ! we are at the right end of the cluster, this is also the ! boundary of the child cluster newlst = j - else if ( wgap( wbegin + j -1)>=minrgp* abs( work(wbegin + j -1) ) ) & + else if ( wgap( wbegin + j -1_${ik}$)>=minrgp* abs( work(wbegin + j -1_${ik}$) ) ) & then ! the right relative gap is big enough, the child cluster ! (newfst,..,newlst) is well separated from the following @@ -33604,25 +33606,25 @@ module stdlib_linalg_lapack_s cycle loop_140 end if ! compute size of child cluster found - newsiz = newlst - newfst + 1 + newsiz = newlst - newfst + 1_${ik}$ ! newftt is the place in z where the new rrr or the computed ! eigenvector is to be stored - if((dol==1).and.(dou==m)) then + if((dol==1_${ik}$).and.(dou==m)) then ! store representation at location of the leftmost evalue ! of the cluster - newftt = wbegin + newfst - 1 + newftt = wbegin + newfst - 1_${ik}$ else if(wbegin+newfst-1dou) then ! store representation at the right end of z array newftt = dou else - newftt = wbegin + newfst - 1 + newftt = wbegin + newfst - 1_${ik}$ endif endif - if( newsiz>1) then + if( newsiz>1_${ik}$) then ! current child is not a singleton but a cluster. ! compute and store new representation of child. ! compute left and right cluster gap. @@ -33633,7 +33635,7 @@ module stdlib_linalg_lapack_s ! have to be computed from work since the entries ! in w might be of the same order so that gaps are not ! exhibited correctly for very close eigenvalues. - if( newfst==1 ) then + if( newfst==1_${ik}$ ) then lgap = max( zero,w(wbegin)-werr(wbegin) - vl ) else lgap = wgap( wbegin+newfst-2 ) @@ -33644,13 +33646,13 @@ module stdlib_linalg_lapack_s ! as possible and obtain as large relative gaps ! as possible do k =1,2 - if(k==1) then + if(k==1_${ik}$) then p = indexw( wbegin-1+newfst ) else p = indexw( wbegin-1+newlst ) endif - offset = indexw( wbegin ) - 1 - call stdlib_slarrb( in, d(ibegin),work( indlld+ibegin-1 ),p,p,rqtol, & + offset = indexw( wbegin ) - 1_${ik}$ + call stdlib${ii}$_slarrb( 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 @@ -33661,18 +33663,18 @@ module stdlib_linalg_lapack_s ! eigenvalues of the child, but then the representation ! tree could be different from the one when nothing is ! skipped. for this reason we skip at this place. - idone = idone + newlst - newfst + 1 + idone = idone + newlst - newfst + 1_${ik}$ goto 139 endif ! compute rrr of child cluster. ! note that the new rrr is stored in z - ! stdlib_slarrf needs lwork = 2*n - call stdlib_slarrf( in, d( ibegin ), l( ibegin ),work(indld+ibegin-1),& + ! stdlib${ii}$_slarrf needs lwork = 2_${ik}$*n + call stdlib${ii}$_slarrf( 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_slarrf + if( iinfo==0_${ik}$ ) then + ! a new rrr for the cluster was found by stdlib${ii}$_slarrf ! update shift and store it ssigma = sigma + tau z( iend, newftt+1 ) = ssigma @@ -33680,10 +33682,10 @@ module stdlib_linalg_lapack_s ! note that the entries in w are unchanged. do k = newfst, newlst fudge =three*eps*abs(work(wbegin+k-1)) - work( wbegin + k - 1 ) =work( wbegin + k - 1) - tau + work( wbegin + k - 1_${ik}$ ) =work( wbegin + k - 1_${ik}$) - tau fudge = fudge +four*eps*abs(work(wbegin+k-1)) ! fudge errors - werr( wbegin + k - 1 ) =werr( wbegin + k - 1 ) + fudge + werr( wbegin + k - 1_${ik}$ ) =werr( wbegin + k - 1_${ik}$ ) + fudge ! gaps are not fudged. provided that werr is small ! when eigenvalues are close, a zero gap indicates ! that a new representation is needed for resolving @@ -33692,24 +33694,24 @@ module stdlib_linalg_lapack_s ! reality are not. this could have a negative impact ! on the orthogonality of the computed eigenvectors. end do - nclus = nclus + 1 - k = newcls + 2*nclus + nclus = nclus + 1_${ik}$ + k = newcls + 2_${ik}$*nclus iwork( k-1 ) = newfst iwork( k ) = newlst else - info = -2 + info = -2_${ik}$ return endif else ! compute eigenvector of singleton - iter = 0 + iter = 0_${ik}$ tol = four * log(real(in,KIND=sp)) * eps k = newfst - windex = wbegin + k - 1 - windmn = max(windex - 1,1) - windpl = min(windex + 1,m) + windex = wbegin + k - 1_${ik}$ + windmn = max(windex - 1_${ik}$,1_${ik}$) + windpl = min(windex + 1_${ik}$,m) lambda = work( windex ) - done = done + 1 + done = done + 1_${ik}$ ! check if eigenvector computation is to be skipped if((windexdou)) then eskip = .true. @@ -33726,7 +33728,7 @@ module stdlib_linalg_lapack_s ! computing the gaps since they exhibit even very small ! differences in the eigenvalues, as opposed to the ! entries in w which might "look" the same. - if( k == 1) then + if( k == 1_${ik}$) then ! in the case range='i' and with not much initial ! accuracy in lambda and vl, the formula ! lgap = max( zero, (sigma - vl) + lambda ) @@ -33748,7 +33750,7 @@ module stdlib_linalg_lapack_s rgap = wgap(windex) endif gap = min( lgap, rgap ) - if(( k == 1).or.(k == im)) then + if(( k == 1_${ik}$).or.(k == im)) then ! the eigenvector support can become wrong ! because significant entries could be cut off due to a ! large gaptol parameter in lar1v. prevent this. @@ -33757,7 +33759,7 @@ module stdlib_linalg_lapack_s gaptol = gap * eps endif isupmn = in - isupmx = 1 + isupmx = 1_${ik}$ ! update wgap so that it holds the minimum gap ! to the left or the right. this is crucial in the ! case where bisection is used to ensure that the @@ -33781,34 +33783,34 @@ module stdlib_linalg_lapack_s ! take the bisection as new iterate usedbs = .true. itmp1 = iwork( iindr+windex ) - offset = indexw( wbegin ) - 1 - call stdlib_slarrb( in, d(ibegin),work(indlld+ibegin-1),indeig,& + offset = indexw( wbegin ) - 1_${ik}$ + call stdlib${ii}$_slarrb( 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 - info = -3 + if( iinfo/=0_${ik}$ ) then + info = -3_${ik}$ return endif lambda = work( windex ) ! reset twist index from inaccurate lambda to ! force computation of true mingma - iwork( iindr+windex ) = 0 + iwork( iindr+windex ) = 0_${ik}$ endif ! given lambda, compute the eigenvector. - call stdlib_slar1v( in, 1, in, lambda, d( ibegin ),l( ibegin ), work(& + call stdlib${ii}$_slar1v( in, 1_${ik}$, 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 ) ) - if(iter == 0) then + 2_${ik}$*windex-1 ),nrminv, resid, rqcorr, work( indwrk ) ) + if(iter == 0_${ik}$) then bstres = resid bstw = lambda elseif(resid1) then + if( k>1_${ik}$) then wgap( windmn ) = max( wgap(windmn),w(windex)-werr(windex)- w(& windmn)-werr(windmn) ) endif @@ -33928,25 +33930,25 @@ module stdlib_linalg_lapack_s windex )-werr( windex) ) endif endif - idone = idone + 1 + idone = idone + 1_${ik}$ endif ! here ends the code for the current child 139 continue ! proceed to any remaining child nodes - newfst = j + 1 + newfst = j + 1_${ik}$ end do loop_140 end do loop_150 - ndepth = ndepth + 1 + ndepth = ndepth + 1_${ik}$ go to 40 end if - ibegin = iend + 1 - wbegin = wend + 1 + ibegin = iend + 1_${ik}$ + wbegin = wend + 1_${ik}$ end do loop_170 return - end subroutine stdlib_slarrv + end subroutine stdlib${ii}$_slarrv - pure subroutine stdlib_slascl( type, kl, ku, cfrom, cto, m, n, a, lda, info ) + pure subroutine stdlib${ii}$_slascl( type, kl, ku, cfrom, cto, m, n, a, lda, info ) !! SLASCL multiplies the M by N real matrix A by the real scalar !! CTO/CFROM. This is done without over/underflow as long as the final !! result CTO*A(I,J)/CFROM does not over/underflow. TYPE specifies that @@ -33957,8 +33959,8 @@ module stdlib_linalg_lapack_s ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: type - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: kl, ku, lda, m, n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: kl, ku, lda, m, n real(sp), intent(in) :: cfrom, cto ! Array Arguments real(sp), intent(inout) :: a(lda,*) @@ -33966,61 +33968,61 @@ module stdlib_linalg_lapack_s ! Local Scalars logical(lk) :: done - integer(ilp) :: i, itype, j, k1, k2, k3, k4 + integer(${ik}$) :: i, itype, j, k1, k2, k3, k4 real(sp) :: bignum, cfrom1, cfromc, cto1, ctoc, mul, smlnum ! Intrinsic Functions intrinsic :: abs,max,min ! Executable Statements ! test the input arguments - info = 0 + info = 0_${ik}$ if( stdlib_lsame( type, 'G' ) ) then - itype = 0 + itype = 0_${ik}$ else if( stdlib_lsame( type, 'L' ) ) then - itype = 1 + itype = 1_${ik}$ else if( stdlib_lsame( type, 'U' ) ) then - itype = 2 + itype = 2_${ik}$ else if( stdlib_lsame( type, 'H' ) ) then - itype = 3 + itype = 3_${ik}$ else if( stdlib_lsame( type, 'B' ) ) then - itype = 4 + itype = 4_${ik}$ else if( stdlib_lsame( type, 'Q' ) ) then - itype = 5 + itype = 5_${ik}$ else if( stdlib_lsame( type, 'Z' ) ) then - itype = 6 - else - itype = -1 - end if - if( itype==-1 ) then - info = -1 - else if( cfrom==zero .or. stdlib_sisnan(cfrom) ) then - info = -4 - else if( stdlib_sisnan(cto) ) then - info = -5 - else if( m<0 ) then - info = -6 - else if( n<0 .or. ( itype==4 .and. n/=m ) .or.( itype==5 .and. n/=m ) ) then - info = -7 - else if( itype<=3 .and. lda=4 ) then - if( kl<0 .or. kl>max( m-1, 0 ) ) then - info = -2 - else if( ku<0 .or. ku>max( n-1, 0 ) .or.( ( itype==4 .or. itype==5 ) .and. kl/=ku ) & + itype = 6_${ik}$ + else + itype = -1_${ik}$ + end if + if( itype==-1_${ik}$ ) then + info = -1_${ik}$ + else if( cfrom==zero .or. stdlib${ii}$_sisnan(cfrom) ) then + info = -4_${ik}$ + else if( stdlib${ii}$_sisnan(cto) ) then + info = -5_${ik}$ + else if( m<0_${ik}$ ) then + info = -6_${ik}$ + else if( n<0_${ik}$ .or. ( itype==4_${ik}$ .and. n/=m ) .or.( itype==5_${ik}$ .and. n/=m ) ) then + info = -7_${ik}$ + else if( itype<=3_${ik}$ .and. lda=4_${ik}$ ) then + if( kl<0_${ik}$ .or. kl>max( m-1, 0_${ik}$ ) ) then + info = -2_${ik}$ + else if( ku<0_${ik}$ .or. ku>max( n-1, 0_${ik}$ ) .or.( ( itype==4_${ik}$ .or. itype==5_${ik}$ ) .and. kl/=ku ) & )then - info = -3 - else if( ( itype==4 .and. lda 0. This is arranged by the calling routine, and is !! no loss in generality. The rank-one modified system is thus !! diag( D ) * diag( D ) + RHO * Z * Z_transpose. @@ -34132,8 +34134,8 @@ module stdlib_linalg_lapack_s ! -- 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) :: i, n - integer(ilp), intent(out) :: info + integer(${ik}$), intent(in) :: i, n + integer(${ik}$), intent(out) :: info real(sp), intent(in) :: rho real(sp), intent(out) :: sigma ! Array Arguments @@ -34141,48 +34143,48 @@ module stdlib_linalg_lapack_s real(sp), intent(out) :: delta(*), work(*) ! ===================================================================== ! Parameters - integer(ilp), parameter :: maxit = 400 + integer(${ik}$), parameter :: maxit = 400_${ik}$ ! Local Scalars logical(lk) :: orgati, swtch, swtch3, geomavg - integer(ilp) :: ii, iim1, iip1, ip1, iter, j, niter + integer(${ik}$) :: ii, iim1, iip1, ip1, iter, j, niter real(sp) :: 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(sp) :: dd(3), zz(3) + real(sp) :: dd(3_${ik}$), zz(3_${ik}$) ! Intrinsic Functions intrinsic :: abs,max,min,sqrt ! Executable Statements ! since this routine is called in an inner loop, we do no argument ! checking. ! quick return for n=1 and 2. - info = 0 - if( n==1 ) then - ! presumably, i=1 upon entry - sigma = sqrt( d( 1 )*d( 1 )+rho*z( 1 )*z( 1 ) ) - delta( 1 ) = one - work( 1 ) = one + info = 0_${ik}$ + if( n==1_${ik}$ ) then + ! presumably, i=1_${ik}$ upon entry + sigma = sqrt( d( 1_${ik}$ )*d( 1_${ik}$ )+rho*z( 1_${ik}$ )*z( 1_${ik}$ ) ) + delta( 1_${ik}$ ) = one + work( 1_${ik}$ ) = one return end if - if( n==2 ) then - call stdlib_slasd5( i, d, z, delta, rho, sigma, work ) + if( n==2_${ik}$ ) then + call stdlib${ii}$_slasd5( i, d, z, delta, rho, sigma, work ) return end if ! compute machine epsilon - eps = stdlib_slamch( 'EPSILON' ) + eps = stdlib${ii}$_slamch( 'EPSILON' ) rhoinv = one / rho tau2= zero ! the case i = n if( i==n ) then ! initialize some basic variables - ii = n - 1 - niter = 1 + ii = n - 1_${ik}$ + niter = 1_${ik}$ ! calculate initial guess temp = rho / two ! if ||z||_2 is not one, then temp should be set to - ! rho * ||z||_2^2 / two + ! rho * ||z||_2^2_${ik}$ / two temp1 = temp / ( d( n )+sqrt( d( n )*d( n )+temp ) ) do j = 1, n work( j ) = d( j ) + d( n ) + temp1 @@ -34200,7 +34202,7 @@ module stdlib_linalg_lapack_s temp = z( n-1 )*z( n-1 ) / ( ( d( n-1 )+temp1 )*( d( n )-d( n-1 )+rho / ( d( n )+& temp1 ) ) ) +z( n )*z( n ) / rho ! the following tau2 is to approximate - ! sigma_n^2 - d( n )*d( n ) + ! sigma_n^2_${ik}$ - d( n )*d( n ) if( c<=temp ) then tau = rho else @@ -34215,13 +34217,13 @@ module stdlib_linalg_lapack_s tau = tau2 / ( d( n )+sqrt( d( n )*d( n )+tau2 ) ) end if ! it can be proved that - ! d(n)^2+rho/2 <= sigma_n^2 < d(n)^2+tau2 <= d(n)^2+rho + ! d(n)^2_${ik}$+rho/2_${ik}$ <= sigma_n^2_${ik}$ < d(n)^2_${ik}$+tau2 <= d(n)^2_${ik}$+rho else delsq = ( d( n )-d( n-1 ) )*( d( n )+d( n-1 ) ) a = -c*delsq + z( n-1 )*z( n-1 ) + z( n )*z( n ) b = z( n )*z( n )*delsq ! the following tau2 is to approximate - ! sigma_n^2 - d( n )*d( n ) + ! sigma_n^2_${ik}$ - d( n )*d( n ) if( a 0, + ! if for some reason caused by roundoff, eta*w > 0_${ik}$, ! we simply use one newton step instead. this way ! will guarantee eta*w < 0. if( w*eta>zero )eta = -w / ( dpsi+dphi ) @@ -34310,7 +34312,7 @@ module stdlib_linalg_lapack_s ! $ + abs( tau2 )*( dpsi+dphi ) w = rhoinv + phi + psi ! main loop to update the values of the array delta - iter = niter + 1 + iter = niter + 1_${ik}$ loop_90: do niter = iter, maxit ! test for convergence if( abs( w )<=eps*erretm ) then @@ -34329,7 +34331,7 @@ module stdlib_linalg_lapack_s end if ! note, eta should be positive if w is negative, and ! eta should be negative otherwise. however, - ! if for some reason caused by roundoff, eta*w > 0, + ! if for some reason caused by roundoff, eta*w > 0_${ik}$, ! we simply use one newton step instead. this way ! will guarantee eta*w < 0. if( w*eta>zero )eta = -w / ( dpsi+dphi ) @@ -34363,13 +34365,13 @@ module stdlib_linalg_lapack_s w = rhoinv + phi + psi end do loop_90 ! return with info = 1, niter = maxit and not converged - info = 1 + info = 1_${ik}$ go to 240 ! end for the case i = n else ! the case for i < n - niter = 1 - ip1 = i + 1 + niter = 1_${ik}$ + ip1 = i + 1_${ik}$ ! calculate initial guess delsq = ( d( ip1 )-d( i ) )*( d( ip1 )+d( i ) ) delsq2 = delsq / two @@ -34392,7 +34394,7 @@ module stdlib_linalg_lapack_s *delta( ip1 ) ) geomavg = .false. if( w>zero ) then - ! d(i)^2 < the ith sigma^2 < (d(i)^2+d(i+1)^2)/2 + ! d(i)^2_${ik}$ < the ith sigma^2_${ik}$ < (d(i)^2_${ik}$+d(i+1)^2_${ik}$)/2_${ik}$ ! we choose d(i) as origin. orgati = .true. ii = i @@ -34405,7 +34407,7 @@ module stdlib_linalg_lapack_s else tau2 = ( a-sqrt( abs( a*a-four*b*c ) ) ) / ( two*c ) end if - ! tau2 now is an estimation of sigma^2 - d( i )^2. the + ! tau2 now is an estimation of sigma^2_${ik}$ - d( i )^2. the ! following, however, is the corresponding estimation of ! sigma - d( i ). tau = tau2 / ( d( i )+sqrt( d( i )*d( i )+tau2 ) ) @@ -34415,7 +34417,7 @@ module stdlib_linalg_lapack_s geomavg = .true. end if else - ! (d(i)^2+d(i+1)^2)/2 <= the ith sigma^2 < d(i+1)^2/2 + ! (d(i)^2_${ik}$+d(i+1)^2_${ik}$)/2_${ik}$ <= the ith sigma^2_${ik}$ < d(i+1)^2_${ik}$/2_${ik}$ ! we choose d(i+1) as origin. orgati = .false. ii = ip1 @@ -34428,7 +34430,7 @@ module stdlib_linalg_lapack_s else tau2 = -( a+sqrt( abs( a*a+four*b*c ) ) ) / ( two*c ) end if - ! tau2 now is an estimation of sigma^2 - d( ip1 )^2. the + ! tau2 now is an estimation of sigma^2_${ik}$ - d( ip1 )^2. the ! following, however, is the corresponding estimation of ! sigma - d( ip1 ). tau = tau2 / ( d( ip1 )+sqrt( abs( d( ip1 )*d( ip1 )+tau2 ) ) ) @@ -34438,8 +34440,8 @@ module stdlib_linalg_lapack_s work( j ) = d( j ) + d( ii ) + tau delta( j ) = ( d( j )-d( ii ) ) - tau end do - iim1 = ii - 1 - iip1 = ii + 1 + iim1 = ii - 1_${ik}$ + iip1 = ii + 1_${ik}$ ! evaluate psi and the derivative dpsi dpsi = zero psi = zero @@ -34469,7 +34471,7 @@ module stdlib_linalg_lapack_s else if( w>zero )swtch3 = .true. end if - if( ii==1 .or. ii==n )swtch3 = .false. + if( ii==1_${ik}$ .or. ii==n )swtch3 = .false. temp = z( ii ) / ( work( ii )*delta( ii ) ) dw = dpsi + dphi + temp*temp temp = z( ii )*temp @@ -34486,14 +34488,14 @@ module stdlib_linalg_lapack_s sgub = min( sgub, tau ) end if ! calculate the new step - niter = niter + 1 + niter = niter + 1_${ik}$ if( .not.swtch3 ) then dtipsq = work( ip1 )*delta( ip1 ) dtisq = work( i )*delta( i ) if( orgati ) then - c = w - dtipsq*dw + delsq*( z( i ) / dtisq )**2 + c = w - dtipsq*dw + delsq*( z( i ) / dtisq )**2_${ik}$ else - c = w - dtisq*dw - delsq*( z( ip1 ) / dtipsq )**2 + c = w - dtisq*dw - delsq*( z( ip1 ) / dtipsq )**2_${ik}$ end if a = ( dtipsq+dtisq )*w - dtipsq*dtisq*dw b = dtipsq*dtisq*w @@ -34521,11 +34523,11 @@ module stdlib_linalg_lapack_s temp1 = temp1*temp1 c = ( temp - dtiip*( dpsi+dphi ) ) -( d( iim1 )-d( iip1 ) )*( d( iim1 )+d( & iip1 ) )*temp1 - zz( 1 ) = z( iim1 )*z( iim1 ) + zz( 1_${ik}$ ) = z( iim1 )*z( iim1 ) if( dpsi 0, + ! if for some reason caused by roundoff, eta*w > 0_${ik}$, ! we simply use one newton step instead. this way ! will guarantee eta*w < 0. if( w*eta>=zero )eta = -w / dw @@ -34641,7 +34643,7 @@ module stdlib_linalg_lapack_s if( w>abs( prew ) / ten )swtch = .true. end if ! main loop to update the values of the array delta and work - iter = niter + 1 + iter = niter + 1_${ik}$ loop_230: do niter = iter, maxit ! test for convergence if( abs( w )<=eps*erretm ) then @@ -34659,9 +34661,9 @@ module stdlib_linalg_lapack_s dtisq = work( i )*delta( i ) if( .not.swtch ) then if( orgati ) then - c = w - dtipsq*dw + delsq*( z( i ) / dtisq )**2 + c = w - dtipsq*dw + delsq*( z( i ) / dtisq )**2_${ik}$ else - c = w - dtisq*dw - delsq*( z( ip1 ) / dtipsq )**2 + c = w - dtisq*dw - delsq*( z( ip1 ) / dtipsq )**2_${ik}$ end if else temp = z( ii ) / ( work( ii )*delta( ii ) ) @@ -34699,19 +34701,19 @@ module stdlib_linalg_lapack_s temp = rhoinv + psi + phi if( swtch ) then c = temp - dtiim*dpsi - dtiip*dphi - zz( 1 ) = dtiim*dtiim*dpsi - zz( 3 ) = dtiip*dtiip*dphi + zz( 1_${ik}$ ) = dtiim*dtiim*dpsi + zz( 3_${ik}$ ) = dtiip*dtiip*dphi else if( orgati ) then temp1 = z( iim1 ) / dtiim temp1 = temp1*temp1 temp2 = ( d( iim1 )-d( iip1 ) )*( d( iim1 )+d( iip1 ) )*temp1 c = temp - dtiip*( dpsi+dphi ) - temp2 - zz( 1 ) = z( iim1 )*z( iim1 ) + zz( 1_${ik}$ ) = z( iim1 )*z( iim1 ) if( dpsi 0, + ! if for some reason caused by roundoff, eta*w > 0_${ik}$, ! we simply use one newton step instead. this way ! will guarantee eta*w < 0. if( w*eta>=zero )eta = -w / dw @@ -34837,14 +34839,14 @@ module stdlib_linalg_lapack_s if( w*prew>zero .and. abs( w )>abs( prew ) / ten )swtch = .not.swtch end do loop_230 ! return with info = 1, niter = maxit and not converged - info = 1 + info = 1_${ik}$ end if 240 continue return - end subroutine stdlib_slasd4 + end subroutine stdlib${ii}$_slasd4 - pure subroutine stdlib_slasd7( icompq, nl, nr, sqre, k, d, z, zw, vf, vfw, vl,vlw, alpha, & + pure subroutine stdlib${ii}$_slasd7( icompq, nl, nr, sqre, k, d, z, zw, vf, vfw, vl,vlw, alpha, & !! SLASD7 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 @@ -34858,49 +34860,49 @@ module stdlib_linalg_lapack_s ! -- 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) :: givptr, info, k - integer(ilp), intent(in) :: icompq, ldgcol, ldgnum, nl, nr, sqre + integer(${ik}$), intent(out) :: givptr, info, k + integer(${ik}$), intent(in) :: icompq, ldgcol, ldgnum, nl, nr, sqre real(sp), intent(in) :: alpha, beta real(sp), intent(out) :: c, s ! Array Arguments - integer(ilp), intent(out) :: givcol(ldgcol,*), idx(*), idxp(*), perm(*) - integer(ilp), intent(inout) :: idxq(*) + integer(${ik}$), intent(out) :: givcol(ldgcol,*), idx(*), idxp(*), perm(*) + integer(${ik}$), intent(inout) :: idxq(*) real(sp), intent(inout) :: d(*), vf(*), vl(*) real(sp), 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 + integer(${ik}$) :: i, idxi, idxj, idxjp, j, jp, jprev, k2, m, n, nlp1, nlp2 real(sp) :: eps, hlftol, tau, tol, z1 ! Intrinsic Functions intrinsic :: abs,max ! Executable Statements ! test the input parameters. - info = 0 - n = nl + nr + 1 + info = 0_${ik}$ + n = nl + nr + 1_${ik}$ m = n + sqre - if( ( icompq<0 ) .or. ( icompq>1 ) ) then - info = -1 - else if( nl<1 ) then - info = -2 - else if( nr<1 ) then - info = -3 - else if( ( sqre<0 ) .or. ( sqre>1 ) ) then - info = -4 + if( ( icompq<0_${ik}$ ) .or. ( icompq>1_${ik}$ ) ) then + info = -1_${ik}$ + else if( nl<1_${ik}$ ) then + info = -2_${ik}$ + else if( nr<1_${ik}$ ) then + info = -3_${ik}$ + else if( ( sqre<0_${ik}$ ) .or. ( sqre>1_${ik}$ ) ) then + info = -4_${ik}$ else if( ldgcoln )go to 90 if( abs( z( j ) )<=tol ) then ! deflate due to small z component. - k2 = k2 - 1 + k2 = k2 - 1_${ik}$ idxp( k2 ) = j else ! check if singular values are close enough to allow deflation. @@ -34986,36 +34988,36 @@ module stdlib_linalg_lapack_s ! deflation is possible. s = z( jprev ) c = z( j ) - ! find sqrt(a**2+b**2) without overflow or + ! find sqrt(a**2_${ik}$+b**2_${ik}$) without overflow or ! destructive underflow. - tau = stdlib_slapy2( c, s ) + tau = stdlib${ii}$_slapy2( c, s ) z( j ) = tau z( jprev ) = zero c = c / tau s = -s / tau ! record the appropriate givens rotation - if( icompq==1 ) then - givptr = givptr + 1 - idxjp = idxq( idx( jprev )+1 ) - idxj = idxq( idx( j )+1 ) + if( icompq==1_${ik}$ ) then + givptr = givptr + 1_${ik}$ + idxjp = idxq( idx( jprev )+1_${ik}$ ) + idxj = idxq( idx( j )+1_${ik}$ ) if( idxjp<=nlp1 ) then - idxjp = idxjp - 1 + idxjp = idxjp - 1_${ik}$ end if if( idxj<=nlp1 ) then - idxj = idxj - 1 + idxj = idxj - 1_${ik}$ end if - givcol( givptr, 2 ) = idxjp - givcol( givptr, 1 ) = idxj - givnum( givptr, 2 ) = c - givnum( givptr, 1 ) = s + givcol( givptr, 2_${ik}$ ) = idxjp + givcol( givptr, 1_${ik}$ ) = idxj + givnum( givptr, 2_${ik}$ ) = c + givnum( givptr, 1_${ik}$ ) = s end if - call stdlib_srot( 1, vf( jprev ), 1, vf( j ), 1, c, s ) - call stdlib_srot( 1, vl( jprev ), 1, vl( j ), 1, c, s ) - k2 = k2 - 1 + call stdlib${ii}$_srot( 1_${ik}$, vf( jprev ), 1_${ik}$, vf( j ), 1_${ik}$, c, s ) + call stdlib${ii}$_srot( 1_${ik}$, vl( jprev ), 1_${ik}$, vl( j ), 1_${ik}$, c, s ) + k2 = k2 - 1_${ik}$ idxp( k2 ) = jprev jprev = j else - k = k + 1 + k = k + 1_${ik}$ zw( k ) = z( jprev ) dsigma( k ) = d( jprev ) idxp( k ) = jprev @@ -35025,65 +35027,65 @@ module stdlib_linalg_lapack_s go to 80 90 continue ! record the last singular value. - k = k + 1 + k = k + 1_${ik}$ zw( k ) = z( jprev ) dsigma( k ) = d( jprev ) idxp( k ) = jprev 100 continue ! sort the singular values into dsigma. the singular values which ! were not deflated go into the first k slots of dsigma, except - ! that dsigma(1) is treated separately. + ! that dsigma(1_${ik}$) is treated separately. do j = 2, n jp = idxp( j ) dsigma( j ) = d( jp ) vfw( j ) = vf( jp ) vlw( j ) = vl( jp ) end do - if( icompq==1 ) then + if( icompq==1_${ik}$ ) then do j = 2, n jp = idxp( j ) - perm( j ) = idxq( idx( jp )+1 ) + perm( j ) = idxq( idx( jp )+1_${ik}$ ) if( perm( j )<=nlp1 ) then - perm( j ) = perm( j ) - 1 + perm( j ) = perm( j ) - 1_${ik}$ end if end do end if ! the deflated singular values go back into the last n - k slots of ! d. - call stdlib_scopy( n-k, dsigma( k+1 ), 1, d( k+1 ), 1 ) - ! determine dsigma(1), dsigma(2), z(1), vf(1), vl(1), vf(m), and + call stdlib${ii}$_scopy( n-k, dsigma( k+1 ), 1_${ik}$, d( k+1 ), 1_${ik}$ ) + ! determine dsigma(1_${ik}$), dsigma(2_${ik}$), z(1_${ik}$), vf(1_${ik}$), vl(1_${ik}$), vf(m), and ! vl(m). - dsigma( 1 ) = zero + dsigma( 1_${ik}$ ) = zero hlftol = tol / two - if( abs( dsigma( 2 ) )<=hlftol )dsigma( 2 ) = hlftol + if( abs( dsigma( 2_${ik}$ ) )<=hlftol )dsigma( 2_${ik}$ ) = hlftol if( m>n ) then - z( 1 ) = stdlib_slapy2( z1, z( m ) ) - if( z( 1 )<=tol ) then + z( 1_${ik}$ ) = stdlib${ii}$_slapy2( z1, z( m ) ) + if( z( 1_${ik}$ )<=tol ) then c = one s = zero - z( 1 ) = tol + z( 1_${ik}$ ) = tol else - c = z1 / z( 1 ) - s = -z( m ) / z( 1 ) + c = z1 / z( 1_${ik}$ ) + s = -z( m ) / z( 1_${ik}$ ) end if - call stdlib_srot( 1, vf( m ), 1, vf( 1 ), 1, c, s ) - call stdlib_srot( 1, vl( m ), 1, vl( 1 ), 1, c, s ) + call stdlib${ii}$_srot( 1_${ik}$, vf( m ), 1_${ik}$, vf( 1_${ik}$ ), 1_${ik}$, c, s ) + call stdlib${ii}$_srot( 1_${ik}$, vl( m ), 1_${ik}$, vl( 1_${ik}$ ), 1_${ik}$, c, s ) else if( abs( z1 )<=tol ) then - z( 1 ) = tol + z( 1_${ik}$ ) = tol else - z( 1 ) = z1 + z( 1_${ik}$ ) = z1 end if end if ! restore z, vf, and vl. - call stdlib_scopy( k-1, zw( 2 ), 1, z( 2 ), 1 ) - call stdlib_scopy( n-1, vfw( 2 ), 1, vf( 2 ), 1 ) - call stdlib_scopy( n-1, vlw( 2 ), 1, vl( 2 ), 1 ) + call stdlib${ii}$_scopy( k-1, zw( 2_${ik}$ ), 1_${ik}$, z( 2_${ik}$ ), 1_${ik}$ ) + call stdlib${ii}$_scopy( n-1, vfw( 2_${ik}$ ), 1_${ik}$, vf( 2_${ik}$ ), 1_${ik}$ ) + call stdlib${ii}$_scopy( n-1, vlw( 2_${ik}$ ), 1_${ik}$, vl( 2_${ik}$ ), 1_${ik}$ ) return - end subroutine stdlib_slasd7 + end subroutine stdlib${ii}$_slasd7 - pure subroutine stdlib_slasd8( icompq, k, d, z, vf, vl, difl, difr, lddifr,dsigma, work, & + pure subroutine stdlib${ii}$_slasd8( icompq, k, d, z, vf, vl, difl, difr, lddifr,dsigma, work, & !! SLASD8 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 SLASD4, and stores, for each element in D, the distance @@ -35096,49 +35098,49 @@ module stdlib_linalg_lapack_s ! -- 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) :: icompq, k, lddifr - integer(ilp), intent(out) :: info + integer(${ik}$), intent(in) :: icompq, k, lddifr + integer(${ik}$), intent(out) :: info ! Array Arguments real(sp), intent(out) :: d(*), difl(*), difr(lddifr,*), work(*) real(sp), intent(inout) :: dsigma(*), vf(*), vl(*), z(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, iwk1, iwk2, iwk2i, iwk3, iwk3i, j + integer(${ik}$) :: i, iwk1, iwk2, iwk2i, iwk3, iwk3i, j real(sp) :: diflj, difrj, dj, dsigj, dsigjp, rho, temp ! Intrinsic Functions intrinsic :: abs,sign,sqrt ! Executable Statements ! test the input parameters. - info = 0 - if( ( icompq<0 ) .or. ( icompq>1 ) ) then - info = -1 - else if( k<1 ) then - info = -2 + info = 0_${ik}$ + if( ( icompq<0_${ik}$ ) .or. ( icompq>1_${ik}$ ) ) then + info = -1_${ik}$ + else if( k<1_${ik}$ ) then + info = -2_${ik}$ else if( lddifrtol2*( sigma+z( nn-3 ) ) .and.z( nn-2*pp-4 )>tol2*z( nn-7 ) )go to & - 30 + ! check whether e(n0-1) is negligible, 1_${ik}$ eigenvalue. + if( z( nn-5 )>tol2*( sigma+z( nn-3 ) ) .and.z( nn-2*pp-4 )>tol2*z( nn-7 ) )go to 30 + 20 continue - z( 4*n0-3 ) = z( 4*n0+pp-3 ) + sigma - n0 = n0 - 1 + z( 4_${ik}$*n0-3 ) = z( 4_${ik}$*n0+pp-3 ) + sigma + n0 = n0 - 1_${ik}$ go to 10 - ! check whether e(n0-2) is negligible, 2 eigenvalues. + ! check whether e(n0-2) is negligible, 2_${ik}$ eigenvalues. 30 continue if( z( nn-9 )>tol2*sigma .and.z( nn-2*pp-8 )>tol2*z( nn-11 ) )go to 50 40 continue @@ -35287,16 +35289,16 @@ module stdlib_linalg_lapack_s z( nn-3 ) = z( nn-3 )*( z( nn-7 ) / t ) z( nn-7 ) = t end if - z( 4*n0-7 ) = z( nn-7 ) + sigma - z( 4*n0-3 ) = z( nn-3 ) + sigma - n0 = n0 - 2 + z( 4_${ik}$*n0-7 ) = z( nn-7 ) + sigma + z( 4_${ik}$*n0-3 ) = z( nn-3 ) + sigma + n0 = n0 - 2_${ik}$ go to 10 50 continue - if( pp==2 )pp = 0 + if( pp==2_${ik}$ )pp = 0_${ik}$ ! reverse the qd-array, if warranted. if( dmin<=zero .or. n0 0. 70 continue - call stdlib_slasq5( i0, n0, z, pp, tau, sigma, dmin, dmin1, dmin2, dn,dn1, dn2, ieee, & + call stdlib${ii}$_slasq5( i0, n0, z, pp, tau, sigma, dmin, dmin1, dmin2, dn,dn1, dn2, ieee, & eps ) ndiv = ndiv + ( n0-i0+2 ) - iter = iter + 1 + iter = iter + 1_${ik}$ ! check status. if( dmin>=zero .and. dmin1>=zero ) then ! success. go to 90 - else if( dminzero .and.z( 4*( n0-1 )-pp )zero .and.z( 4_${ik}$*( n0-1 )-pp )